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
83
|
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module BangState (
BangState,
initBangState,
getBangsJSON,
getBangsBrotli,
addBang,
) where
import Codec.Compression.Brotli (compress)
import Control.Applicative ((<|>))
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" <|> return (Left "") >>= \case
Left e -> return mempty
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"
|
