1 files changed, 76 insertions, 0 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"