-- |
-- Module      : Network.IRC.Client.Utils
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : portable
--
-- Commonly-used utility functions for IRC clients.
module Network.IRC.Client.Utils
  ( -- * Nicks
    setNick

    -- * Channels
  , leaveChannel
  , delChan

    -- * Events
  , addHandler
  , reply
  , replyTo

    -- * CTCPs
  , ctcp
  , ctcpReply

    -- * Connection state
  , isConnected
  , isDisconnecting
  , isDisconnected
  , snapConnState

    -- * Concurrency
  , fork

    -- * Lenses
  , snapshot
  , snapshotModify
  , get
  , set
  , modify
  ) where

import           Control.Concurrent          (ThreadId, forkFinally, myThreadId)
import           Control.Concurrent.STM      (STM, TVar, atomically, modifyTVar)
import           Control.Monad.IO.Class      (liftIO)
import qualified Data.Set                    as S
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Network.IRC.CTCP            (toCTCP)
import           Network.IRC.Conduit         (Event(..), Message(..),
                                              Source(..))

import           Network.IRC.Client.Internal
import           Network.IRC.Client.Lens

-------------------------------------------------------------------------------
-- Nicks

-- | Update the nick in the instance configuration and also send an
-- update message to the server. This doesn't attempt to resolve nick
-- collisions, that's up to the event handlers.
setNick :: Text -> IRC s ()
setNick :: Text -> IRC s ()
setNick Text
new = do
  TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$
    TVar (InstanceConfig s)
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI (Lens' (InstanceConfig s) Text
-> Text -> InstanceConfig s -> InstanceConfig s
forall s a. Lens' s a -> a -> s -> s
set forall s. Lens' (InstanceConfig s) Text
Lens' (InstanceConfig s) Text
nick Text
new)
  Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ()) -> Message Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Message Text
forall a. NickName a -> Message (NickName a)
Nick Text
new


-------------------------------------------------------------------------------
-- Channels

-- | Update the channel list in the instance configuration and also
-- part the channel.
leaveChannel :: Text -> Maybe Text -> IRC s ()
leaveChannel :: Text -> Maybe Text -> IRC s ()
leaveChannel Text
chan Maybe Text
reason = do
  TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$ TVar (InstanceConfig s) -> Text -> STM ()
forall s. TVar (InstanceConfig s) -> Text -> STM ()
delChan TVar (InstanceConfig s)
tvarI Text
chan
  Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ()) -> Message Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Message Text
forall a. NickName a -> Reason (NickName a) -> Message (NickName a)
Part Text
chan Maybe Text
reason

-- | Remove a channel from the list without sending a part command (be
-- careful not to let the channel list get out of sync with the
-- real-world state if you use it for anything!)
delChan :: TVar (InstanceConfig s) -> Text -> STM ()
delChan :: TVar (InstanceConfig s) -> Text -> STM ()
delChan TVar (InstanceConfig s)
tvarI Text
chan =
  TVar (InstanceConfig s)
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI (Lens' (InstanceConfig s) [Text]
-> ([Text] -> [Text]) -> InstanceConfig s -> InstanceConfig s
forall s a. Lens' s a -> (a -> a) -> s -> s
modify forall s. Lens' (InstanceConfig s) [Text]
Lens' (InstanceConfig s) [Text]
channels ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
chan)))


-------------------------------------------------------------------------------
-- Events

-- | Add an event handler
addHandler :: EventHandler s -> IRC s ()
addHandler :: EventHandler s -> IRC s ()
addHandler EventHandler s
handler = do
  TVar (InstanceConfig s)
tvarI <- Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
-> IRCState s -> TVar (InstanceConfig s)
forall a s. Getting a s a -> s -> a
get Getting
  (TVar (InstanceConfig s)) (IRCState s) (TVar (InstanceConfig s))
forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig (IRCState s -> TVar (InstanceConfig s))
-> IRC s (IRCState s) -> IRC s (TVar (InstanceConfig s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  IO () -> IRC s ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IRC s ()) -> (STM () -> IO ()) -> STM () -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IRC s ()) -> STM () -> IRC s ()
forall a b. (a -> b) -> a -> b
$
    TVar (InstanceConfig s)
-> (InstanceConfig s -> InstanceConfig s) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (InstanceConfig s)
tvarI (Lens' (InstanceConfig s) [EventHandler s]
-> ([EventHandler s] -> [EventHandler s])
-> InstanceConfig s
-> InstanceConfig s
forall s a. Lens' s a -> (a -> a) -> s -> s
modify forall s. Lens' (InstanceConfig s) [EventHandler s]
Lens' (InstanceConfig s) [EventHandler s]
handlers (EventHandler s
handlerEventHandler s -> [EventHandler s] -> [EventHandler s]
forall a. a -> [a] -> [a]
:))

-- | Send a message to the source of an event.
reply :: Event Text -> Text -> IRC s ()
reply :: Event Text -> Text -> IRC s ()
reply = Source Text -> Text -> IRC s ()
forall s. Source Text -> Text -> IRC s ()
replyTo (Source Text -> Text -> IRC s ())
-> (Event Text -> Source Text) -> Event Text -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event Text -> Source Text
forall a. Event a -> Source a
_source

-- | Send a message to the source of an event.
replyTo :: Source Text -> Text -> IRC s ()
replyTo :: Source Text -> Text -> IRC s ()
replyTo (Channel Text
c Text
_) = (Text -> IRC s ()) -> [Text] -> IRC s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ())
-> (Text -> Message Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CTCPByteString Text -> Message Text
forall a.
NickName a
-> Either CTCPByteString (NickName a) -> Message (NickName a)
Privmsg Text
c (Either CTCPByteString Text -> Message Text)
-> (Text -> Either CTCPByteString Text) -> Text -> Message Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CTCPByteString Text
forall a b. b -> Either a b
Right) ([Text] -> IRC s ()) -> (Text -> [Text]) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
replyTo (User Text
n)      = (Text -> IRC s ()) -> [Text] -> IRC s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message Text -> IRC s ()
forall s. Message Text -> IRC s ()
send (Message Text -> IRC s ())
-> (Text -> Message Text) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CTCPByteString Text -> Message Text
forall a.
NickName a
-> Either CTCPByteString (NickName a) -> Message (NickName a)
Privmsg Text
n (Either CTCPByteString Text -> Message Text)
-> (Text -> Either CTCPByteString Text) -> Text -> Message Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CTCPByteString Text
forall a b. b -> Either a b
Right) ([Text] -> IRC s ()) -> (Text -> [Text]) -> Text -> IRC s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
replyTo Source Text
_ = IRC s () -> Text -> IRC s ()
forall a b. a -> b -> a
const (IRC s () -> Text -> IRC s ()) -> IRC s () -> Text -> IRC s ()
forall a b. (a -> b) -> a -> b
$ () -> IRC s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-------------------------------------------------------------------------------
-- CTCPs

-- | Construct a @PRIVMSG@ containing a CTCP
ctcp :: Text -> Text -> [Text] -> Message Text
ctcp :: Text -> Text -> [Text] -> Message Text
ctcp Text
t Text
command [Text]
args = Text -> Either CTCPByteString Text -> Message Text
forall a.
NickName a
-> Either CTCPByteString (NickName a) -> Message (NickName a)
Privmsg Text
t (Either CTCPByteString Text -> Message Text)
-> (CTCPByteString -> Either CTCPByteString Text)
-> CTCPByteString
-> Message Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTCPByteString -> Either CTCPByteString Text
forall a b. a -> Either a b
Left (CTCPByteString -> Message Text) -> CTCPByteString -> Message Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> CTCPByteString
toCTCP Text
command [Text]
args

-- | Construct a @NOTICE@ containing a CTCP
ctcpReply :: Text -> Text -> [Text] -> Message Text
ctcpReply :: Text -> Text -> [Text] -> Message Text
ctcpReply Text
t Text
command [Text]
args = Text -> Either CTCPByteString Text -> Message Text
forall a.
NickName a
-> Either CTCPByteString (NickName a) -> Message (NickName a)
Notice Text
t (Either CTCPByteString Text -> Message Text)
-> (CTCPByteString -> Either CTCPByteString Text)
-> CTCPByteString
-> Message Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTCPByteString -> Either CTCPByteString Text
forall a b. a -> Either a b
Left (CTCPByteString -> Message Text) -> CTCPByteString -> Message Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> CTCPByteString
toCTCP Text
command [Text]
args


-------------------------------------------------------------------------------
-- Connection state

-- | Check if the client is connected.
isConnected :: IRC s Bool
isConnected :: IRC s Bool
isConnected = (ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
==ConnectionState
Connected) (ConnectionState -> Bool) -> IRC s ConnectionState -> IRC s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s ConnectionState
forall s. IRC s ConnectionState
snapConnState

-- | Check if the client is in the process of disconnecting.
isDisconnecting :: IRC s Bool
isDisconnecting :: IRC s Bool
isDisconnecting = (ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
==ConnectionState
Disconnecting) (ConnectionState -> Bool) -> IRC s ConnectionState -> IRC s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s ConnectionState
forall s. IRC s ConnectionState
snapConnState

-- | Check if the client is disconnected
isDisconnected :: IRC s Bool
isDisconnected :: IRC s Bool
isDisconnected = (ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
==ConnectionState
Disconnected) (ConnectionState -> Bool) -> IRC s ConnectionState -> IRC s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IRC s ConnectionState
forall s. IRC s ConnectionState
snapConnState

-- | Snapshot the connection state.
snapConnState :: IRC s ConnectionState
snapConnState :: IRC s ConnectionState
snapConnState = IO ConnectionState -> IRC s ConnectionState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConnectionState -> IRC s ConnectionState)
-> (IRCState s -> IO ConnectionState)
-> IRCState s
-> IRC s ConnectionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM ConnectionState -> IO ConnectionState
forall a. STM a -> IO a
atomically (STM ConnectionState -> IO ConnectionState)
-> (IRCState s -> STM ConnectionState)
-> IRCState s
-> IO ConnectionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCState s -> STM ConnectionState
forall s. IRCState s -> STM ConnectionState
getConnectionState (IRCState s -> IRC s ConnectionState)
-> IRC s (IRCState s) -> IRC s ConnectionState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState


-------------------------------------------------------------------------------
-- Concurrency

-- | Fork a thread which will be thrown a 'Disconnect' exception when
-- the client disconnects.
fork :: IRC s () -> IRC s ThreadId
fork :: IRC s () -> IRC s ThreadId
fork IRC s ()
ma = do
  IRCState s
s <- IRC s (IRCState s)
forall s. IRC s (IRCState s)
getIRCState
  IO ThreadId -> IRC s ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IRC s ThreadId) -> IO ThreadId -> IRC s ThreadId
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
tid <- IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IRC s () -> IRCState s -> IO ()
forall (m :: * -> *) s a. MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction IRC s ()
ma IRCState s
s) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
_ -> do
      ThreadId
tid <- IO ThreadId
myThreadId
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set ThreadId) -> (Set ThreadId -> Set ThreadId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (IRCState s -> TVar (Set ThreadId)
forall s. IRCState s -> TVar (Set ThreadId)
_runningThreads IRCState s
s) (ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
S.delete ThreadId
tid)
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set ThreadId) -> (Set ThreadId -> Set ThreadId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (IRCState s -> TVar (Set ThreadId)
forall s. IRCState s -> TVar (Set ThreadId)
_runningThreads IRCState s
s) (ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
S.insert ThreadId
tid)
    ThreadId -> IO ThreadId
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreadId
tid