1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module BangState (
BangState,
initBangState,
getBangsJSON,
getBangsBrotli,
addBang,
) where
import Codec.Compression.Brotli (compress)
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,
brotliBangs :: TVar ByteString,
syncFileNotifications :: TChan ()
}
reserialize :: BangState -> STM ()
reserialize s = do
own <- readTVar $ ownBangs s
ddg <- readTVar $ ddgBangs s
let jsonBs = encode $ own <> ddg -- left biased union
writeTVar (serializedBangs s) $ toStrict $ jsonBs
writeTVar (brotliBangs s) $ toStrict $ compress jsonBs
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'
<*> newTVarIO empty -- same as above
<*> newBroadcastTChanIO
spawnFileSyncThread s
return s
getBangsJSON :: BangState -> IO ByteString
getBangsJSON s = readTVarIO $ serializedBangs s
getBangsBrotli :: BangState -> IO ByteString
getBangsBrotli s = readTVarIO $ brotliBangs s
addBang :: Text -> Text -> BangState -> IO ()
addBang bang url s = error "TODO"
|
