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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module BangState (
BangState,
initBangState,
getBangsJSON,
getBangsBrotli,
addBang,
getBangsHash,
) where
import Codec.Compression.Brotli (compress)
import Control.Applicative ((<|>))
import Control.Concurrent.STM.TQueue
import Control.Concurrent.STM.TVar
import Control.Monad (forever)
import Crypto.Hash (hashlazy, Digest, SHA512)
import Data.Aeson
import Data.ByteArray.Encoding (convertToBase, Base(Base64))
import Data.ByteString (ByteString, toStrict, empty, take)
import Data.Text (Text)
import Data.Text.Encoding (decodeASCII)
import GHC.Conc
import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
import Data.Bang
data BangState = BangState {
ownBangs :: TVar Bangs,
ddgBangs :: TVar Bangs,
serializedBangs :: TVar ByteString,
brotliBangs :: TVar ByteString,
serializedHash :: TVar Text,
syncFileNotifications :: TQueue ()
}
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
-- hash: for now, base64 of the first 120 bits of the SHA512 of the bangs
writeTVar (serializedHash s) $ decodeASCII $ Data.ByteString.take 20
$ convertToBase Base64 $ (hashlazy jsonBs :: Digest SHA512)
writeTQueue (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
_ <- forkIO $ forever $ do
nextBangs <- atomically $ do
readTQueue $ syncFileNotifications s
readTVar (ownBangs s)
atomicWriteFile "bangs.json" $ encode nextBangs
atomically $ reserialize s
loadOwnBangs :: IO Bangs
loadOwnBangs = eitherDecodeFileStrict "bangs.json" <|> return (Left "") >>= \case
Left _ -> return mempty
Right b -> return b
-- also spawns a thread for disk synchronization
initBangState :: IO BangState
initBangState = do
-- we may want to actually poll this. oops.
ans <- httpJSON "https://duckduckgo.com/bang.js" :: IO (Response DDGBangs)
s <- BangState
<$> (loadOwnBangs >>= newTVarIO)
<*> newTVarIO (toBangs $ getResponseBody ans)
<*> newTVarIO empty -- initially filled in by 'spawnFileSyncThread'
<*> newTVarIO empty -- same as above
<*> newTVarIO "" -- same as above
<*> newTQueueIO
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 -> Text -> BangState -> IO ()
addBang bn bu bdp s = atomically $ do
modifyTVar (ownBangs s) (singletonBangs bn bu bdp <>)
reserialize s
getBangsHash :: BangState -> IO Text
getBangsHash s = readTVarIO $ serializedHash s
|
