From b4800d051a71b38cce8dc0ee89edc0742f272384 Mon Sep 17 00:00:00 2001
From: Lia Lenckowski <lialenck@protonmail.com>
Date: Sat, 26 Aug 2023 19:16:57 +0200
Subject: refactor: move PendingBang out of Main

---
 src/BangState.hs        |  4 ++--
 src/Data/PendingBang.hs | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/Main.hs             | 45 ++++-----------------------------------------
 3 files changed, 55 insertions(+), 43 deletions(-)
 create mode 100644 src/Data/PendingBang.hs

(limited to 'src')

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
-- 
cgit v1.2.3-70-g09d2