out-source bangs state serialization, listen on both ipv4 and ipv6

2 files changed, 112 insertions, 45 deletions

diff --git a/src/BangState.hs b/src/BangState.hs
new file mode 100644
index 0000000..6175289
--- /dev/null
+++ b/src/BangState.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+
+module BangState (
+    BangState,
+    initBangState,
+    getBangsJSON,
+    getBangsBrotli,
+    addBang,
+) where
+
+import Control.Concurrent.STM.TChan
+import Control.Monad (forever)
+import Data.Aeson
+import Data.ByteString (ByteString, toStrict, empty)
+import Data.Text (Text)
+import GHC.Conc
+import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
+import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
+
+import Bangs
+
+data BangState = BangState {
+    ownBangs :: TVar Bangs,
+    ddgBangs :: TVar Bangs,
+    serializedBangs :: TVar ByteString,
+    syncFileNotifications :: TChan ()
+}
+
+reserialize :: BangState -> STM ()
+reserialize s = do
+    own <- readTVar $ ownBangs s
+    ddg <- readTVar $ ddgBangs s
+    writeTVar (serializedBangs s) $ toStrict $ encode $ own <> ddg -- left biased union
+    writeTChan (syncFileNotifications s) ()
+
+-- spawns a thread for syncing the current state to disk. do *NOT* use forkIO on this
+-- function, it does so internally, and using forkIO may result in a (hard to trigger)
+-- race condition
+spawnFileSyncThread :: BangState -> IO ()
+spawnFileSyncThread s = do
+    readableChan <- atomically $ dupTChan (syncFileNotifications s)
+
+    _ <- forkIO $ forever $ do
+        nextBangs <- atomically $ do
+            readTChan readableChan
+            readTVar (ownBangs s)
+        atomicWriteFile "bangs.json" $ encode nextBangs
+
+    atomically $ reserialize s
+
+loadOwnBangs :: IO Bangs
+loadOwnBangs = eitherDecodeFileStrict "bangs.json" >>= \case
+    Left e -> error e
+    Right b -> return b
+
+-- also spawns a thread for disk synchronization
+initBangState :: IO BangState
+initBangState = do
+    ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response DDGBangs)
+    s <- BangState
+        <$> (loadOwnBangs >>= newTVarIO)
+        <*> newTVarIO (toBangs $ getResponseBody ans)
+        <*> newTVarIO empty -- initially filled in by 'spawnFileSyncThread'
+        <*> newBroadcastTChanIO
+
+    spawnFileSyncThread s
+    return s
+
+getBangsJSON :: BangState -> IO ByteString
+getBangsJSON s = readTVarIO $ serializedBangs s
+
+getBangsBrotli :: BangState -> IO ByteString
+getBangsBrotli s = error "TODO"
+
+addBang :: Text -> Text -> BangState -> IO ()
+addBang bang url s = error "TODO"
diff --git a/src/Main.hs b/src/Main.hs
index c8290db..feb199b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,65 +1,56 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
+    TypeFamilies, ViewPatterns, LambdaCase #-}
 
 module Main (main) where
 
-import Control.Concurrent.STM.TChan
-import Control.Monad (forever)
-import Data.Aeson
-import Data.ByteString (ByteString, toStrict)
-import GHC.Conc
-import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
-import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
 import Yesod
+import Network.Wai.Handler.Warp
+import Data.Function ((&))
 
 import qualified Data.ByteString as BS
 
 import Bangs
+import BangState
 
 data Search = Search {
-    ownBangs :: TVar Bangs,
-    ddgBangs :: TVar Bangs,
-    serializedBangs :: TVar ByteString,
-    syncFileNotifications :: TChan ()
+    bangState :: BangState
 }
 
-reserialize :: Search -> STM ()
-reserialize s = do
-    own <- readTVar $ ownBangs s
-    ddg <- readTVar $ ddgBangs s
-    writeTVar (serializedBangs s) $ toStrict $ encode $ own <> ddg -- left biased union
-    writeTChan (syncFileNotifications s) ()
+mkYesod "Search" [parseRoutes|
+/           HomeR GET
+/bangs.json BangsR GET
+/submitBang SubmitR POST
+|]
 
--- second argument: readable tchan, duped from the tchan in 'Search'
-fileSyncThread :: Search -> TChan () -> IO a
-fileSyncThread s rc = forever $ do
-    nextBangs <- atomically $ do
-        readTChan rc
-        readTVar (ownBangs s)
-    atomicWriteFile "bangs.json" $ encode nextBangs
+instance Yesod Search where
+    makeSessionBackend _ = return Nothing
 
-spawnFileSyncThread :: Search -> IO ()
-spawnFileSyncThread s = do
-    readableChan <- atomically $ dupTChan (syncFileNotifications s)
-    forkIO $ fileSyncThread s readableChan
-    return ()
+getHomeR :: Handler String
+getHomeR = return "TODO"
 
-loadOwnBangs :: IO Bangs
-loadOwnBangs = eitherDecodeFileStrict "bangs.json" >>= \case
-    Left e -> error e
-    Right b -> return b
+getBangsR :: Handler TypedContent
+getBangsR = do
+    bangsAccessor <- lookupHeader "accept-encoding" >>= \case
+        Just ae | "br" `BS.isInfixOf` ae -> do
+            addHeader "transfer-encoding" "br"
+            return getBangsBrotli
+        _ -> do
+            return getBangsJSON
+
+    bs <- liftIO . bangsAccessor . bangState =<< getYesod
+    return $ TypedContent typeJson $ toContent bs
+
+postSubmitR :: Handler String
+postSubmitR = return "TODO"
 
 main :: IO ()
 main = do
-    ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response DDGBangs)
     s <- Search
-        <$> (loadOwnBangs >>= newTVarIO)
-        <*> newTVarIO (toBangs $ getResponseBody ans)
-        <*> newTVarIO BS.empty
-        <*> newBroadcastTChanIO
-
-    spawnFileSyncThread s
-    atomically $ reserialize s
+        <$> initBangState
 
-    print =<< readTVarIO (serializedBangs s)
-    _ <- getLine
-    return ()
+    sApp <- toWaiApp s -- includes middlewares
+    let settings = defaultSettings
+            -- currently, "*" seems to bind only to ipv4 while "*6" binds to both
+            & setHost "*6"
+            & setPort 20546
+    runSettings settings sApp