{-# 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 _ -> 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 -> Text -> BangState -> IO ()
addBang _ _ _ _ = error $ "TODO"