blob: c8290db4bb6f9ff278f6a2d1e5c9591f02d83980 (
plain)
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
|
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module Main (main) where
import Control.Concurrent.STM.TChan
import Control.Monad (forever)
import Data.Aeson
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 {
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)
s <- Search
<$> (loadOwnBangs >>= newTVarIO)
<*> newTVarIO (toBangs $ getResponseBody ans)
<*> newTVarIO BS.empty
<*> newBroadcastTChanIO
spawnFileSyncThread s
atomically $ reserialize s
print =<< readTVarIO (serializedBangs s)
_ <- getLine
return ()
|
