bang accept/reject api

1 files changed, 21 insertions, 1 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 8a82da3..0733c61 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,7 +10,7 @@ module Main (main) where
 
 import Control.Monad.Logger (runStdoutLoggingT)
 import Control.Monad.Trans.Resource (runResourceT)
-import Control.Monad (unless)
+import Control.Monad (when, unless)
 import Data.Aeson
 import Database.Persist.Sqlite
 import Data.Char (isAlphaNum)
@@ -65,6 +65,8 @@ mkYesod "Search" [parseRoutes|
 /bangs.json   BangsR GET
 /search.xml   OpenSearchR GET
 /submitBang   SubmitR POST
+/acceptBang   AcceptR POST
+/rejectBang   RejectR POST
 /pendingBangs PendingR GET
 |]
 
@@ -131,6 +133,24 @@ getOpenSearchR = do
         .   toContent
         <$> makeOpenSearch url
 
+postVerdictR :: Bool -> Handler ()
+postVerdictR b = do
+    ensureAuth
+
+    (PendingBang n u dp mayEm) <- requireCheckJsonBody
+    -- NOTE: known race condition: the bang bang may be deleted from the database
+    -- before the updated bangs are written to disk, leading to the loss of
+    -- a pending bang on very specific crash timing.
+    st <- bangState <$> getYesod
+    when b $ liftIO $ addBang n u dp st
+    --sendEmail mayEm $ "your bang was " <> bool b "rejected" "accepted" -- TODO
+    runDB $ deleteBy $ UniqueBang n
+    return ()
+
+postAcceptR, postRejectR :: Handler ()
+postAcceptR = postVerdictR True
+postRejectR = postVerdictR False
+
 getPendingR :: Handler Value
 getPendingR = do
     ensureAuth