sync own bangs with disk

1 files changed, 51 insertions, 8 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 1517ebd..c8290db 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,22 +1,65 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
 
 module Main (main) where
 
+import Control.Concurrent.STM.TChan
+import Control.Monad (forever)
 import Data.Aeson
-import Data.ByteString (ByteString)
-import Data.IORef
-import Network.HTTP.Simple
+import Data.ByteString (ByteString, toStrict)
+import GHC.Conc
+import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
+import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
 import Yesod
 
+import qualified Data.ByteString as BS
+
 import Bangs
 
 data Search = Search {
-    ddgBangs :: IORef Bangs,
-    ownBangs :: IORef Bangs,
-    serializedBangs :: IORef ByteString
+    ownBangs :: TVar Bangs,
+    ddgBangs :: TVar Bangs,
+    serializedBangs :: TVar ByteString,
+    syncFileNotifications :: TChan ()
 }
 
+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) ()
+
+-- 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
+
+spawnFileSyncThread :: Search -> IO ()
+spawnFileSyncThread s = do
+    readableChan <- atomically $ dupTChan (syncFileNotifications s)
+    forkIO $ fileSyncThread s readableChan
+    return ()
+
+loadOwnBangs :: IO Bangs
+loadOwnBangs = eitherDecodeFileStrict "bangs.json" >>= \case
+    Left e -> error e
+    Right b -> return b
+
 main :: IO ()
 main = do
     ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response DDGBangs)
-    print ans
+    s <- Search
+        <$> (loadOwnBangs >>= newTVarIO)
+        <*> newTVarIO (toBangs $ getResponseBody ans)
+        <*> newTVarIO BS.empty
+        <*> newBroadcastTChanIO
+
+    spawnFileSyncThread s
+    atomically $ reserialize s
+
+    print =<< readTVarIO (serializedBangs s)
+    _ <- getLine
+    return ()