refactor: move PendingBang out of Main

6 files changed, 59 insertions, 44 deletions

diff --git a/fastbangs.cabal b/fastbangs.cabal
index 386e42d..e6eb3c6 100644
--- a/fastbangs.cabal
+++ b/fastbangs.cabal
@@ -21,6 +21,7 @@ executable fastbangs
       BangState
       Config
       Data.Bang
+      Data.PendingBang
       Paths_fastbangs
   hs-source-dirs:
       src
@@ -37,6 +38,7 @@ executable fastbangs
     , http-conduit
     , memory
     , monad-logger
+    , persistent
     , persistent-sqlite
     , resourcet
     , stm
diff --git a/makefile b/makefile
index 12be4bd..b2e49af 100644
--- a/makefile
+++ b/makefile
@@ -32,4 +32,4 @@ deploy/style.css: frontend/style.sass
 	sassc $< $@
 
 frontend/fuzzysort.js:
-	curl 'https://cdn.jsdelivr.net/npm/fuzzysort@2.0.4/fuzzysort.min.js' -o $@
+	curl -s 'https://cdn.jsdelivr.net/npm/fuzzysort@2.0.4/fuzzysort.min.js' -o $@
diff --git a/package.yaml b/package.yaml
index 825d37c..382537c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -13,6 +13,7 @@ extra-source-files: []
 dependencies:
 - base >= 4.7 && < 5
 - yesod
+- persistent
 - aeson
 - bytestring
 - http-conduit
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