diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/BangState.hs | 6 | ||||
| -rw-r--r-- | src/Bangs.hs | 1 | ||||
| -rw-r--r-- | src/Main.hs | 60 |
3 files changed, 50 insertions, 17 deletions
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 |