sync own bangs with disk

5 files changed, 57 insertions, 8 deletions

diff --git a/.gitignore b/.gitignore
index 8ee1bf9..ad2d920 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,2 @@
 .stack-work
+bangs.json
diff --git a/bangs-ddgless.cabal b/bangs-ddgless.cabal
index 38ff3d1..eb3ed42 100644
--- a/bangs-ddgless.cabal
+++ b/bangs-ddgless.cabal
@@ -24,11 +24,13 @@ executable bangs-ddgless
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
   build-depends:
       aeson
+    , atomic-write
     , base >=4.7 && <5
     , bytestring
     , containers
     , ghc-prim
     , http-conduit
+    , stm
     , text
     , time
     , yesod
diff --git a/bangs.json b/bangs.json
new file mode 100644
index 0000000..9e26dfe
--- /dev/null
+++ b/bangs.json
@@ -0,0 +1 @@
+{}
\ No newline at end of file
diff --git a/package.yaml b/package.yaml
index 1cf2c86..c9a6703 100644
--- a/package.yaml
+++ b/package.yaml
@@ -20,6 +20,8 @@ dependencies:
 - containers
 - text
 - ghc-prim
+- atomic-write
+- stm
 
 ghc-options:
 - -Wall
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 ()