{-# LANGUAGE ViewPatterns #-}

module Thermoprint.Server.Push
       ( Notification
       , withPush
       , protocolSpec
       , notifyOnChange
       ) where

import Network.WebSockets
import Network.Wai.Handler.WebSockets
import Network.Wai (Application)

import Network.URI

import Control.Concurrent.STM

import Thermoprint.Server.Queue

import Control.Monad.IO.Class
import Control.Monad

import Paths_thermoprint_server (version)
import Data.Version (showVersion)

import           Data.ByteString.Char8        (ByteString)
import qualified Data.ByteString.Char8 as CBS

import           Data.Text         (Text)
import qualified Data.Text as Text

type Notification = URI

withPush :: TChan Notification -> Application -> Application
withPush chan = websocketsOr defaultConnectionOptions $ flip acceptRequestWith (AcceptRequest (Just protocolSpec) []) >=> handleClient chan

protocolSpec :: ByteString
protocolSpec = CBS.pack $ "thermoprint-server.notification." ++ showVersion version

handleClient :: TChan Notification -> Connection -> IO ()
handleClient chan conn = do
  cChan <- atomically $ dupTChan chan
  forkPingThread conn 10
  forever . void $ atomically (readTChan cChan) >>= sendTextData conn . packNotification

packNotification :: Notification -> Text
packNotification = Text.pack . show

notifyOnChange :: MonadIO m => TChan Notification -> (a -> a -> Bool) -> Notification -> TVar a -> m ()
notifyOnChange chan cmp n q = void . liftIO $ readTVarIO q >>= notifyOnChange'
  where
    notifyOnChange' last = do
      current <- atomically $ (\current -> current <$ check (not $ cmp last current)) =<< readTVar q
      atomically $ writeTChan chan n
      notifyOnChange' current