xdcc-1.1.3: src/ZNC.hs

{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}

module ZNC (autoConnectHooks) where

import           IRC.Types

import           Control.Concurrent.STM (TVar, atomically, newTVar,
                                         readTVar, writeTVar)
import           Control.Monad          (unless)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Text              as T (Text)
import           Network.IRC.Client     (Event (..), EventHandler (..),
                                         EventType (EPrivmsg), Message (..),
                                         Source (..), StatefulIRC, send)

{- TODO Additional checks
   host == "znc.in"
   user == "znc"
-}
pattern ZncStatusUser :: Source T.Text
pattern ZncStatusUser = User "*status"

pattern ZncDisconnectedMsg :: T.Text -> Message T.Text
pattern ZncDisconnectedMsg target =
    Privmsg target (Right
        "You are currently disconnected from IRC. Use 'connect' to reconnect.")

autoConnectHooks :: IO (Hook s)
autoConnectHooks = do
  wasConnected <- atomically $ newTVar True
  return Hook { onConnect    = return ()
              , events       = [autoReconnect wasConnected]
              , onDisconnect = disconnect wasConnected }

autoReconnect :: TVar Bool -> EventHandler s
autoReconnect wasConnected = EventHandler
    { _description = "Auto-reconnect when ZNC is enabled"
    , _matchType   = EPrivmsg
    , _eventFunc   = handler
    }
  where
    handler Event { _source  = ZncStatusUser
                  , _message = ZncDisconnectedMsg _ } = do
        liftIO $ atomically $ writeTVar wasConnected False
        send' "connect"
    handler _ = return ()

disconnect :: TVar Bool -> StatefulIRC s ()
disconnect wasConnected = do
    wasConnected' <- liftIO $ atomically $ readTVar wasConnected
    unless wasConnected' $ send' "disconnect"

send' :: T.Text -> StatefulIRC s ()
send' = send . Privmsg "*status" . Right