(prototype) authentication, route for getting pending bangs

5 files changed, 69 insertions, 19 deletions

diff --git a/fastbangs.cabal b/fastbangs.cabal
index 9972f7a..a5b8a22 100644
--- a/fastbangs.cabal
+++ b/fastbangs.cabal
@@ -17,9 +17,10 @@ build-type:     Simple
 executable fastbangs
   main-is: Main.hs
   other-modules:
-      Bangs
+      Auth
       BangState
       Config
+      Data.Bang
       Paths_fastbangs
   hs-source-dirs:
       src
diff --git a/src/Auth.hs b/src/Auth.hs
new file mode 100644
index 0000000..397dd75
--- /dev/null
+++ b/src/Auth.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+
+module Auth (
+    ensureAuth
+) where
+
+import Control.Monad (unless)
+import Crypto.Hash (hash, Digest, SHA512)
+import Data.ByteArray.Encoding (convertToBase, Base(Base64))
+import Data.ByteString (ByteString)
+import Data.Text.Encoding (encodeUtf8)
+import Yesod
+
+ensureAuth :: MonadHandler m => m ()
+ensureAuth = lookupBasicAuth >>= \case
+    Nothing -> notAuthenticated
+    Just (user, pw) -> unless (hashSha512 pw == hardcodedPw && user == "bleb") notAuthenticated
+  where hashSha512 pw = convertToBase Base64 $ (hash $ encodeUtf8 pw :: Digest SHA512)
+        hardcodedPw :: ByteString
+        hardcodedPw = "l2gTDo5UCimSIQcdK4IrAvJtCIE7KPB7IyS5N7EN4ic78/1mI+8pikPTQTn06+W1XTOk39TgqGEX5KfpAQVm4w=="
diff --git a/src/BangState.hs b/src/BangState.hs
index 8eba764..d53fc47 100644
--- a/src/BangState.hs
+++ b/src/BangState.hs
@@ -23,7 +23,7 @@ import GHC.Conc
 import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
 import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
 
-import Bangs
+import Data.Bang
 
 data BangState = BangState {
     ownBangs :: TVar Bangs,
diff --git a/src/Bangs.hs b/src/Data/Bang.hs
index 02ec02c..2bf0966 100644
--- a/src/Bangs.hs
+++ b/src/Data/Bang.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
 
-module Bangs (
+module Data.Bang (
     DDGBangs,
     toBangs,
     Bangs
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