diff options
Diffstat (limited to 'src/Main.hs')
-rw-r--r-- | src/Main.hs | 45 |
1 files changed, 4 insertions, 41 deletions
diff --git a/src/Main.hs b/src/Main.hs index 626983c..ec4204a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,5 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, - TypeFamilies, ViewPatterns, LambdaCase, EmptyDataDecls, - FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving, - UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-} + TypeFamilies, LambdaCase, EmptyDataDecls #-} {-# OPTIONS -Wno-unused-top-binds #-} @@ -11,11 +8,8 @@ module Main (main) where import Control.Monad.Logger (runStdoutLoggingT) import Control.Monad.Trans.Resource (runResourceT) import Control.Monad (when, unless) -import Data.Aeson import Database.Persist.Sqlite -import Data.Char (isAlphaNum) import Data.Function ((&)) -import Data.Maybe (maybeToList) import Network.Wai.Handler.Warp hiding (getPort, getHost) import Yesod @@ -25,35 +19,7 @@ import qualified Data.Text as T import Auth import BangState import Config - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -PendingBang - bang T.Text - url T.Text - displayName T.Text - notifyEmail (Maybe T.Text) - UniqueBang bang url displayName - 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] - - toEncoding (PendingBang b u dp em) = pairs $ case em of - Nothing -> withoutEmail - Just e -> withoutEmail <> "email" .= e - where withoutEmail = "bang" .= b <> "url" .= u <> "name" .= dp - -instance FromJSON PendingBang where - parseJSON = withObject "PendingBang" $ \ob -> - PendingBang - <$> ob .: "bang" - <*> ob .: "url" - <*> ob .: "name" - <*> ob .:? "email" +import Data.PendingBang data Search = Search { bangState :: BangState, @@ -117,11 +83,8 @@ getBangsR = do postSubmitR :: Handler () 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 [] - + pb <- requireCheckJsonBody + unless (verifyPendingBang pb) $ invalidArgs [] runDB $ insert400_ pb getOpenSearchR :: Handler TypedContent |