From 9dc2650910bcca92980f0b16fbd5e9e8c94c0473 Mon Sep 17 00:00:00 2001 From: Lia Lenckowski Date: Sat, 29 Jul 2023 15:27:21 +0200 Subject: (prototype) authentication, route for getting pending bangs --- src/Auth.hs | 20 +++++++++++++++++++ src/BangState.hs | 2 +- src/Bangs.hs | 47 ------------------------------------------- src/Data/Bang.hs | 47 +++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 61 +++++++++++++++++++++++++++++++++++++++++--------------- 5 files changed, 113 insertions(+), 64 deletions(-) create mode 100644 src/Auth.hs delete mode 100644 src/Bangs.hs create mode 100644 src/Data/Bang.hs (limited to '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/Bangs.hs deleted file mode 100644 index 02ec02c..0000000 --- a/src/Bangs.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} - -module Bangs ( - DDGBangs, - toBangs, - Bangs -) where - -import GHC.Prim -import GHC.Generics (Generic) -import Data.Aeson -import Data.Text (Text) -import qualified Data.Map.Strict as M - --- M.Map BangName (SearchUrl, DisplayName) -newtype Bangs = Bangs { - unBangs :: M.Map Text (Text, Text) -} deriving (Show, Generic) - -instance FromJSON Bangs where - parseJSON b = parseJSON b >>= fmap Bangs . sequence . fmap getInfo - where getInfo v = (,) <$> v .: "url" <*> v .: "name" - -instance ToJSON Bangs where - toJSON (Bangs m) = toJSON - $ (\(url, name) -> object ["url" .= url, "name" .= name]) - <$> m - - -- TODO toEncoding. semi important; makes startup/updates faster - -newtype DDGBangs = DDGBangs (M.Map Text (Text, Text)) deriving (Show) -toBangs :: DDGBangs -> Bangs -toBangs = coerce - -instance FromJSON DDGBangs where - parseJSON b = fmap (DDGBangs . M.fromList) - $ parseJSON b - >>= mapM - (\ob -> (,) <$> ob .: "t" <*> ((,) <$> ob .: "u" <*> ob .: "s")) - --- left-biased union -instance Semigroup Bangs where - Bangs a <> Bangs b = Bangs $ a `M.union` b - -instance Monoid Bangs where - mempty = Bangs M.empty - mconcat = Bangs . M.unions . map unBangs diff --git a/src/Data/Bang.hs b/src/Data/Bang.hs new file mode 100644 index 0000000..2bf0966 --- /dev/null +++ b/src/Data/Bang.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} + +module Data.Bang ( + DDGBangs, + toBangs, + Bangs +) where + +import GHC.Prim +import GHC.Generics (Generic) +import Data.Aeson +import Data.Text (Text) +import qualified Data.Map.Strict as M + +-- M.Map BangName (SearchUrl, DisplayName) +newtype Bangs = Bangs { + unBangs :: M.Map Text (Text, Text) +} deriving (Show, Generic) + +instance FromJSON Bangs where + parseJSON b = parseJSON b >>= fmap Bangs . sequence . fmap getInfo + where getInfo v = (,) <$> v .: "url" <*> v .: "name" + +instance ToJSON Bangs where + toJSON (Bangs m) = toJSON + $ (\(url, name) -> object ["url" .= url, "name" .= name]) + <$> m + + -- TODO toEncoding. semi important; makes startup/updates faster + +newtype DDGBangs = DDGBangs (M.Map Text (Text, Text)) deriving (Show) +toBangs :: DDGBangs -> Bangs +toBangs = coerce + +instance FromJSON DDGBangs where + parseJSON b = fmap (DDGBangs . M.fromList) + $ parseJSON b + >>= mapM + (\ob -> (,) <$> ob .: "t" <*> ((,) <$> ob .: "u" <*> ob .: "s")) + +-- left-biased union +instance Semigroup Bangs where + Bangs a <> Bangs b = Bangs $ a `M.union` b + +instance Monoid Bangs where + mempty = Bangs M.empty + mconcat = Bangs . M.unions . map unBangs 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 -- cgit v1.2.3-70-g09d2