insert submitted bangs into a database

7 files changed, 57 insertions, 18 deletions

diff --git a/.gitignore b/.gitignore
index c798acb..bb0f949 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,2 @@
 .stack-work
-bangs.json
 /deploy
diff --git a/bangs-ddgless.cabal b/bangs-ddgless.cabal
index 8f6b091..c0b5f07 100644
--- a/bangs-ddgless.cabal
+++ b/bangs-ddgless.cabal
@@ -33,6 +33,9 @@ executable bangs-ddgless
     , containers
     , ghc-prim
     , http-conduit
+    , monad-logger
+    , persistent-sqlite
+    , resourcet
     , stm
     , text
     , time
diff --git a/bangs.json b/bangs.json
new file mode 100644
index 0000000..9e26dfe
--- /dev/null
+++ b/bangs.json
@@ -0,0 +1 @@
+{}
\ No newline at end of file
diff --git a/package.yaml b/package.yaml
index 49cf0f7..e331e84 100644
--- a/package.yaml
+++ b/package.yaml
@@ -24,6 +24,9 @@ dependencies:
 - stm
 - warp
 - brotli
+- resourcet
+- monad-logger
+- persistent-sqlite
 
 ghc-options:
 - -Wall
diff --git a/src/BangState.hs b/src/BangState.hs
index b091532..fd3bbaa 100644
--- a/src/BangState.hs
+++ b/src/BangState.hs
@@ -56,7 +56,7 @@ spawnFileSyncThread s = do
 
 loadOwnBangs :: IO Bangs
 loadOwnBangs = eitherDecodeFileStrict "bangs.json" <|> return (Left "") >>= \case
-    Left e -> return mempty
+    Left _ -> return mempty
     Right b -> return b
 
 -- also spawns a thread for disk synchronization
@@ -79,5 +79,5 @@ getBangsJSON s = readTVarIO $ serializedBangs s
 getBangsBrotli :: BangState -> IO ByteString
 getBangsBrotli s = readTVarIO $ brotliBangs s
 
-addBang :: Text -> Text -> BangState -> IO ()
-addBang bang url s = error "TODO"
+addBang :: Text -> Text -> Text -> BangState -> IO ()
+addBang _ _ _ _ = error $ "TODO"
diff --git a/src/Bangs.hs b/src/Bangs.hs
index 699ce38..02ec02c 100644
--- a/src/Bangs.hs
+++ b/src/Bangs.hs
@@ -9,7 +9,6 @@ module Bangs (
 import GHC.Prim
 import GHC.Generics (Generic)
 import Data.Aeson
-import Data.Aeson.Types (Parser)
 import Data.Text (Text)
 import qualified Data.Map.Strict as M
 
diff --git a/src/Main.hs b/src/Main.hs
index 3f372f6..69cbdb4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,21 +1,39 @@
 {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
-    TypeFamilies, ViewPatterns, LambdaCase #-}
+    TypeFamilies, ViewPatterns, LambdaCase, EmptyDataDecls,
+    FlexibleContexts, GADTs, GeneralizedNewtypeDeriving,
+    MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving,
+    UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-}
 
 module Main (main) where
 
-import Yesod
-import Network.Wai.Handler.Warp hiding (getPort, getHost)
+import Control.Monad.Logger (runStdoutLoggingT)
+import Control.Monad.Trans.Resource (runResourceT)
+import Control.Monad (unless)
+import Data.Char (isAlphaNum)
+import Database.Persist.Sqlite
 import Data.Function ((&))
 import Data.Functor ((<&>))
+import Network.Wai.Handler.Warp hiding (getPort, getHost)
+import Yesod
 
 import qualified Data.ByteString as BS
+import qualified Data.Text as T
 
-import Bangs
 import BangState
 import Config
 
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+PendingBang
+    name T.Text
+    url T.Text
+    displayName T.Text
+    UniqueBang name
+    deriving Show
+|]
+
 data Search = Search {
-    bangState :: BangState
+    bangState :: BangState,
+    sqlPool :: ConnectionPool
 }
 
 mkYesod "Search" [parseRoutes|
@@ -30,6 +48,11 @@ mkYesod "Search" [parseRoutes|
 instance Yesod Search where
     makeSessionBackend _ = return Nothing
 
+instance YesodPersist Search where
+    type YesodPersistBackend Search = SqlBackend
+
+    runDB action = getYesod >>= runSqlPool action . sqlPool
+
 getHomeR :: Handler ()
 getHomeR = sendFile typeHtml "index.html"
 
@@ -51,8 +74,15 @@ getBangsR = do
     bs <- liftIO . bangsAccessor . bangState =<< getYesod
     return $ TypedContent typeJson $ toContent bs
 
-postSubmitR :: Handler String
-postSubmitR = return "TODO"
+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
+
+    _ -> invalidArgs []
 
 getOpenSearchR :: Handler TypedContent
 getOpenSearchR = do
@@ -67,14 +97,18 @@ getOpenSearchR = do
         <$> makeOpenSearch url
 
 main :: IO ()
-main = do
+main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
+    runResourceT $ flip runSqlPool pool $ runMigration migrateAll
+
     s <- Search
-        <$> initBangState
-    sApp <- toWaiApp s -- includes middlewares
+        <$> liftIO initBangState
+        <*> pure pool
+    sApp <- liftIO $ toWaiApp s -- includes middlewares
 
-    host <- getHost
-    port <- getPort
+    host <- liftIO getHost
+    port <- liftIO getPort
     let settings = defaultSettings
             & setHost host
             & setPort port
-    runSettings settings sApp
+
+    liftIO $ runSettings settings sApp