diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/BangState.hs | 4 | ||||
| -rw-r--r-- | src/Data/PendingBang.hs | 49 | ||||
| -rw-r--r-- | src/Main.hs | 45 |
3 files changed, 55 insertions, 43 deletions
diff --git a/src/BangState.hs b/src/BangState.hs index fc3afab..1b76649 100644 --- a/src/BangState.hs +++ b/src/BangState.hs @@ -69,8 +69,8 @@ loadOwnBangs = eitherDecodeFileStrict "bangs.json" <|> return (Left "") >>= \cas -- also spawns a thread for disk synchronization initBangState :: IO BangState initBangState = do - -- TODO error handling for ddg bang polling, as well as regular polling - ans <- httpJSON "https://duckduckgo.com/bang.v260.js" :: IO (Response DDGBangs) + -- we may want to actually poll this. oops. + ans <- httpJSON "https://duckduckgo.com/bang.js" :: IO (Response DDGBangs) s <- BangState <$> (loadOwnBangs >>= newTVarIO) <*> newTVarIO (toBangs $ getResponseBody ans) diff --git a/src/Data/PendingBang.hs b/src/Data/PendingBang.hs new file mode 100644 index 0000000..05fafba --- /dev/null +++ b/src/Data/PendingBang.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, + TypeFamilies, GADTs, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving, + UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-} + +{-# OPTIONS -Wno-missing-export-lists #-} + +module Data.PendingBang where + +import Data.Aeson +import Database.Persist.TH +import Data.Char (isAlphaNum) +import Data.Maybe (maybeToList) + +import qualified Data.Text as T + +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" + +verifyPendingBang :: PendingBang -> Bool +verifyPendingBang (PendingBang n u dp mayEm) = + T.all isAlphaNum n && all ((<255) . T.length) strings + where strings = [n, u, dp] <> maybeToList mayEm 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 |