diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | bangs-ddgless.cabal | 2 | ||||
| -rw-r--r-- | bangs.json | 1 | ||||
| -rw-r--r-- | package.yaml | 2 | ||||
| -rw-r--r-- | src/Main.hs | 59 |
5 files changed, 57 insertions, 8 deletions
@@ -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 () |