1 files changed, 45 insertions, 16 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 55ad17d..8a82da3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,45 +4,68 @@
     MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving,
     UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-}
 
+{-# OPTIONS -Wno-unused-top-binds #-}
+
 module Main (main) where
 
 import Control.Monad.Logger (runStdoutLoggingT)
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad (unless)
-import Data.Char (isAlphaNum)
+import Data.Aeson
 import Database.Persist.Sqlite
+import Data.Char (isAlphaNum)
 import Data.Function ((&))
 import Data.Functor ((<&>))
+import Data.Maybe (maybeToList)
 import Network.Wai.Handler.Warp hiding (getPort, getHost)
 import Yesod
 
 import qualified Data.ByteString as BS
 import qualified Data.Text as T
 
+import Auth
 import BangState
 import Config
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 PendingBang
-    name T.Text
+    bang T.Text
     url T.Text
     displayName T.Text
-    UniqueBang name
+    notifyEmail (Maybe T.Text)
+    UniqueBang bang
     deriving Show
 |]
 
+instance ToJSON PendingBang where
+    toJSON (PendingBang b u dp em) = object $
+        ["bang" .= b, "url" .= u, "name" .= dp] ++ case em of
+            Nothing -> []
+            Just e -> ["email" .= e]
+
+    -- TODO toEncoding. Not sure how much value that holds though
+
+instance FromJSON PendingBang where
+    parseJSON = withObject "PendingBang" $ \ob ->
+        PendingBang
+        <$> ob .:  "bang"
+        <*> ob .:  "url"
+        <*> ob .:  "name"
+        <*> ob .:? "email"
+
 data Search = Search {
     bangState :: BangState,
     sqlPool :: ConnectionPool
 }
 
 mkYesod "Search" [parseRoutes|
-/           HomeR GET
-/bundle.js  BundleR GET
-/style.css  StyleR GET
-/bangs.json BangsR GET
-/submitBang SubmitR POST
-/search.xml OpenSearchR GET
+/             HomeR GET
+/bundle.js    BundleR GET
+/style.css    StyleR GET
+/bangs.json   BangsR GET
+/search.xml   OpenSearchR GET
+/submitBang   SubmitR POST
+/pendingBangs PendingR GET
 |]
 
 instance Yesod Search where
@@ -87,14 +110,13 @@ getBangsR = do
     return $ TypedContent typeJson $ toContent bs
 
 postSubmitR :: Handler ()
-postSubmitR = sequence (map lookupPostParam ["bang", "url", "name"])
-  >>= \l -> case sequence l of
-    Just [bn, bu, bdp] -> do
-        unless (T.all isAlphaNum bn)                   $ invalidArgs []
-        unless (all ((<255) . T.length) [bn, bu, bdp]) $ invalidArgs []
-        runDB $ insert400_ $ PendingBang bn bu bdp
+postSubmitR = do
+    pb@(PendingBang n u dp mayEm) <- requireCheckJsonBody
+    unless (T.all isAlphaNum n) $ invalidArgs []
+    let strings = [n, u, dp] <> maybeToList mayEm
+    unless (all ((<255) . T.length) strings) $ invalidArgs []
 
-    _ -> invalidArgs []
+    runDB $ insert400_ pb
 
 getOpenSearchR :: Handler TypedContent
 getOpenSearchR = do
@@ -109,6 +131,13 @@ getOpenSearchR = do
         .   toContent
         <$> makeOpenSearch url
 
+getPendingR :: Handler Value
+getPendingR = do
+    ensureAuth
+
+    pendingBangs <- runDB $ selectList [] []
+    return $ toJSON $ map entityVal (pendingBangs :: [Entity PendingBang])
+
 main :: IO ()
 main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
     runResourceT $ flip runSqlPool pool $ runMigration migrateAll