diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | bangs-ddgless.cabal | 3 | ||||
| -rw-r--r-- | bangs.json | 1 | ||||
| -rw-r--r-- | package.yaml | 3 | ||||
| -rw-r--r-- | src/BangState.hs | 6 | ||||
| -rw-r--r-- | src/Bangs.hs | 1 | ||||
| -rw-r--r-- | src/Main.hs | 60 |
7 files changed, 57 insertions, 18 deletions
@@ -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 |