aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs45
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