diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -6,7 +6,7 @@ -- > run host port nick = do -- > conn <- connect host port 1 -- > let cfg = defaultIRCConf nick --- > let cfg' = cfg { _handlers = yourCustomEventHandlers : _handlers cfg } +-- > let cfg' = cfg { _eventHandlers = yourCustomEventHandlers : _eventHandlers cfg } -- > start conn cfg' -- -- You shouldn't really need to tweak anything other than the event @@ -18,6 +18,7 @@ , connectWithTLS , start , start' + , startStateful -- * Logging , Origin (..) @@ -67,7 +68,7 @@ -- ^ The port -> NominalDiffTime -- ^ The flood cooldown - -> m ConnectionConfig + -> m (ConnectionConfig s) connect = connect' noopLogger -- | Connect to a server with TLS. @@ -78,7 +79,7 @@ -- ^ The port -> NominalDiffTime -- ^ The flood cooldown - -> m ConnectionConfig + -> m (ConnectionConfig s) connectWithTLS = connectWithTLS' noopLogger -- | Connect to a server without TLS, with the provided logging @@ -92,7 +93,7 @@ -- ^ The port -> NominalDiffTime -- ^ The flood cooldown - -> m ConnectionConfig + -> m (ConnectionConfig s) connect' = connectInternal ircClient defaultDisconnectHandler -- | Connect to a server with TLS, with the provided logging function. @@ -105,7 +106,7 @@ -- ^ The port -> NominalDiffTime -- ^ The flood cooldown - -> m ConnectionConfig + -> m (ConnectionConfig s) connectWithTLS' = connectInternal ircTLSClient defaultDisconnectHandler -- * Starting @@ -113,23 +114,27 @@ -- | Run the event loop for a server, receiving messages and handing -- them off to handlers as appropriate. Messages will be logged to -- stdout. -start :: MonadIO m => ConnectionConfig -> InstanceConfig -> m () -start cconf iconf = newIRCState cconf iconf >>= start' +start :: MonadIO m => ConnectionConfig () -> InstanceConfig () -> m () +start cconf iconf = startStateful cconf iconf () +-- | like 'start' but for clients with state. +startStateful :: MonadIO m => ConnectionConfig s -> InstanceConfig s -> s -> m () +startStateful cconf iconf ustate = newIRCState cconf iconf ustate >>= start' + -- | Like 'start', but use the provided initial state. -start' :: MonadIO m => IRCState -> m () +start' :: MonadIO m => IRCState s -> m () start' = liftIO . runReaderT runner -- * Default configuration -- | Construct a default IRC configuration from a nick -defaultIRCConf :: Text -> InstanceConfig +defaultIRCConf :: Text -> InstanceConfig s defaultIRCConf n = InstanceConfig { _nick = n , _username = n , _realname = n , _channels = [] - , _ctcpVer = "irc-client-0.2.3.0" + , _ctcpVer = "irc-client-0.2.5.0" , _eventHandlers = defaultEventHandlers , _ignore = [] } diff --git a/Network/IRC/Client/Handlers.hs b/Network/IRC/Client/Handlers.hs --- a/Network/IRC/Client/Handlers.hs +++ b/Network/IRC/Client/Handlers.hs @@ -60,7 +60,7 @@ -- -- If you are building a bot, you may want to write an event handler -- to process messages representing commands. -defaultEventHandlers :: [EventHandler] +defaultEventHandlers :: [EventHandler s] defaultEventHandlers = [ EventHandler "Respond to server PING requests" EPing pingHandler , EventHandler "Respond to CTCP PING requests" ECTCP ctcpPingHandler @@ -73,24 +73,24 @@ ] -- | Respond to server @PING@ messages with a @PONG@. -pingHandler :: UnicodeEvent -> IRC () +pingHandler :: UnicodeEvent -> StatefulIRC s () pingHandler ev = case _message ev of Ping s1 s2 -> send . Pong $ fromMaybe s1 s2 _ -> return () -- | Respond to CTCP @PING@ requests with a CTCP @PONG@. -ctcpPingHandler :: UnicodeEvent -> IRC () +ctcpPingHandler :: UnicodeEvent -> StatefulIRC s () ctcpPingHandler = ctcpHandler [("PING", return)] -- | Respond to CTCP @VERSION@ requests with the version string. -ctcpVersionHandler :: UnicodeEvent -> IRC () +ctcpVersionHandler :: UnicodeEvent -> StatefulIRC s () ctcpVersionHandler = ctcpHandler [("VERSION", go)] where go _ = do ver <- _ctcpVer <$> instanceConfig return [ver] -- | Respond to CTCP @TIME@ requests with the system time. -ctcpTimeHandler :: UnicodeEvent -> IRC () +ctcpTimeHandler :: UnicodeEvent -> StatefulIRC s () ctcpTimeHandler = ctcpHandler [("TIME", go)] where go _ = do now <- liftIO getCurrentTime @@ -98,7 +98,7 @@ -- | Update the nick upon welcome (numeric reply 001), as it may not -- be what we requested (eg, in the case of a nick too long). -welcomeNick :: UnicodeEvent -> IRC () +welcomeNick :: UnicodeEvent -> StatefulIRC s () welcomeNick = numHandler [(001, go)] where go (srvNick:_) = do tvarI <- instanceConfigTVar @@ -110,7 +110,7 @@ -- | Mangle the nick if there's a collision (numeric replies 432, 433, -- and 436) when we set it -nickMangler :: UnicodeEvent -> IRC () +nickMangler :: UnicodeEvent -> StatefulIRC s () nickMangler = numHandler [ (432, go fresh) , (433, go mangle) , (436, go mangle) @@ -165,7 +165,7 @@ -- | Upon receiving a channel topic (numeric reply 332), add the -- channel to the list (if not already present). -joinHandler :: UnicodeEvent -> IRC () +joinHandler :: UnicodeEvent -> StatefulIRC s () joinHandler = numHandler [(332, go)] where go (c:_) = do tvarI <- instanceConfigTVar @@ -178,7 +178,7 @@ go _ = return () -- | Update the channel list upon being kicked. -kickHandler :: UnicodeEvent -> IRC () +kickHandler :: UnicodeEvent -> StatefulIRC s () kickHandler ev = do theNick <- _nick <$> instanceConfig tvarI <- instanceConfigTVar @@ -192,13 +192,13 @@ -- | The default disconnect handler: do nothing. You might want to -- override this with one which reconnects. -defaultDisconnectHandler :: IRC () +defaultDisconnectHandler :: StatefulIRC s () defaultDisconnectHandler = return () -- *Utils -- | Match and handle a named CTCP -ctcpHandler :: [(Text, [Text] -> IRC [Text])] -> UnicodeEvent -> IRC () +ctcpHandler :: [(Text, [Text] -> StatefulIRC s [Text])] -> UnicodeEvent -> StatefulIRC s () ctcpHandler hs ev = case (_source ev, _message ev) of (User n, Privmsg _ (Left ctcpbs)) -> let (verb, xs) = first toUpper $ fromCTCP ctcpbs @@ -210,7 +210,7 @@ _ -> return () -- | Match and handle a numeric reply -numHandler :: [(Int, [Text] -> IRC ())] -> UnicodeEvent -> IRC () +numHandler :: [(Int, [Text] -> StatefulIRC s ())] -> UnicodeEvent -> StatefulIRC s () numHandler hs ev = case _message ev of Numeric num xs -> maybe (return ()) ($xs) $ lookup num hs _ -> return () diff --git a/Network/IRC/Client/Internal.hs b/Network/IRC/Client/Internal.hs --- a/Network/IRC/Client/Internal.hs +++ b/Network/IRC/Client/Internal.hs @@ -33,12 +33,12 @@ -- | Connect to a server using the supplied connection function. connectInternal :: MonadIO m => (Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()) - -> IRC () + -> StatefulIRC s () -> (Origin -> ByteString -> IO ()) -> ByteString -> Int -> NominalDiffTime - -> m ConnectionConfig + -> m (ConnectionConfig s) connectInternal f dcHandler logf host port flood = liftIO $ do queueS <- newTBMChanIO 16 @@ -55,7 +55,7 @@ -- * Event loop -- | The event loop. -runner :: IRC () +runner :: StatefulIRC s () runner = do state <- ircState @@ -68,8 +68,7 @@ let initialise = flip runReaderT state $ do sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal] send $ Nick theNick - mapM_ (send . Join) . _channels <$> instanceConfig - return () + instanceConfig >>= mapM_ (send . Join) . _channels -- Run the event loop, and call the disconnect handler if the remote -- end closes the socket. @@ -84,8 +83,8 @@ dchandler <- _disconnect <$> connectionConfig - let source = toProducer $ sourceTBMChan queue $= antiflood $= logConduit (logf FromServer . toByteString) - let sink = forgetful =$= logConduit (logf FromClient . _raw) =$ eventSink state + let source = toProducer $ sourceTBMChan queue $= antiflood $= logConduit (logf FromClient . toByteString) + let sink = forgetful =$= logConduit (logf FromServer . _raw) =$ eventSink state liftIO $ func port server initialise sink source @@ -100,7 +99,7 @@ -- | Block on receiving a message and invoke all matching handlers -- concurrently. -eventSink :: MonadIO m => IRCState -> Consumer IrcEvent m () +eventSink :: MonadIO m => IRCState s -> Consumer IrcEvent m () eventSink ircstate = awaitForever $ \event -> do let event' = decodeUtf8 <$> event ignored <- isIgnored ircstate event' @@ -109,7 +108,7 @@ liftIO $ mapM_ (\h -> forkIO $ runReaderT (h event') ircstate) handlers -- | Check if an event is ignored or not. -isIgnored :: MonadIO m => IRCState -> UnicodeEvent -> m Bool +isIgnored :: MonadIO m => IRCState s -> UnicodeEvent -> m Bool isIgnored ircstate ev = do iconf <- liftIO . atomically . readTVar . _instanceConfig $ ircstate let ignoreList = _ignore iconf @@ -121,7 +120,7 @@ Server _ -> False -- |Get the event handlers for an event. -getHandlersFor :: Event a -> [EventHandler] -> [UnicodeEvent -> IRC ()] +getHandlersFor :: Event a -> [EventHandler s] -> [UnicodeEvent -> StatefulIRC s ()] getHandlersFor e ehs = [_eventFunc eh | eh <- ehs, _matchType eh `elem` [EEverything, eventType e]] -- |A conduit which logs everything which goes through it. @@ -151,7 +150,7 @@ appendFile fp $ unwords [ formatTime defaultTimeLocale "%c" now - , if origin == FromServer then "<---" else "--->" + , if origin == FromServer then "--->" else "<---" , init . tail $ show x ] @@ -163,12 +162,12 @@ -- | Send a message as UTF-8, using TLS if enabled. This blocks if -- messages are sent too rapidly. -send :: UnicodeMessage -> IRC () +send :: UnicodeMessage -> StatefulIRC s () send = sendBS . fmap encodeUtf8 -- | Send a message, using TLS if enabled. This blocks if messages are -- sent too rapidly. -sendBS :: IrcMessage -> IRC () +sendBS :: IrcMessage -> StatefulIRC s () sendBS msg = do queue <- _sendqueue <$> connectionConfig liftIO . atomically $ writeTBMChan queue msg @@ -177,7 +176,7 @@ -- | Disconnect from the server, properly tearing down the TLS session -- (if there is one). -disconnect :: IRC () +disconnect :: StatefulIRC s () disconnect = do queueS <- _sendqueue <$> connectionConfig @@ -190,7 +189,7 @@ disconnectNow -- | Disconnect immediately, without waiting for messages to be sent. -disconnectNow :: IRC () +disconnectNow :: StatefulIRC s () disconnectNow = do queueS <- _sendqueue <$> connectionConfig liftIO . atomically $ closeTBMChan queueS diff --git a/Network/IRC/Client/Types.hs b/Network/IRC/Client/Types.hs --- a/Network/IRC/Client/Types.hs +++ b/Network/IRC/Client/Types.hs @@ -31,64 +31,87 @@ -- *State -- | The IRC monad. -type IRC a = ReaderT IRCState IO a +type IRC a = StatefulIRC () a -data IRCState = IRCState { _connectionConfig :: ConnectionConfig - -- ^Read-only connection configuration - , _instanceConfig :: TVar InstanceConfig - -- ^Mutable instance configuration in STM - } +-- | The IRC monad, with state. +type StatefulIRC s a = ReaderT (IRCState s) IO a +data IRCState s = IRCState { _connectionConfig :: ConnectionConfig s + -- ^Read-only connection configuration + , _userState :: TVar s + -- ^Mutable user state + , _instanceConfig :: TVar (InstanceConfig s) + -- ^Mutable instance configuration in STM + } + -- | Construct a new IRC state -newIRCState :: MonadIO m => ConnectionConfig -> InstanceConfig -> m IRCState -newIRCState cconf iconf = do - tvar <- liftIO . atomically . newTVar $ iconf +newIRCState :: MonadIO m => ConnectionConfig s -> InstanceConfig s -> s -> m (IRCState s) +newIRCState cconf iconf ustate = do + ustvar <- liftIO . atomically . newTVar $ ustate + ictvar <- liftIO . atomically . newTVar $ iconf return IRCState { _connectionConfig = cconf - , _instanceConfig = tvar + , _userState = ustvar + , _instanceConfig = ictvar } --- | Access the entire state. -ircState :: IRC IRCState +-- | Access the client state. +ircState :: StatefulIRC s (IRCState s) ircState = ask -- | Extract the connection configuration from an IRC state -getConnectionConfig :: IRCState -> ConnectionConfig +getConnectionConfig :: IRCState s -> ConnectionConfig s getConnectionConfig = _connectionConfig -- | Extract the instance configuration from an IRC state -getInstanceConfig :: IRCState -> TVar InstanceConfig +getInstanceConfig :: IRCState s -> TVar (InstanceConfig s) getInstanceConfig = _instanceConfig +-- | Extract the user state from an IRC state +getUserState :: IRCState s -> TVar s +getUserState = _userState + -- | Extract the current snapshot of the instance configuration from -- an IRC state -getInstanceConfig' :: MonadIO m => IRCState -> m InstanceConfig +getInstanceConfig' :: MonadIO m => IRCState s -> m (InstanceConfig s) getInstanceConfig' = liftIO . atomically . readTVar . _instanceConfig -- | Access the connection config -connectionConfig :: IRC ConnectionConfig +connectionConfig :: StatefulIRC s (ConnectionConfig s) connectionConfig = _connectionConfig <$> ask -- | Access the instance config TVar -instanceConfigTVar :: IRC (TVar InstanceConfig) +instanceConfigTVar :: StatefulIRC s (TVar (InstanceConfig s)) instanceConfigTVar = _instanceConfig <$> ask -- | Access the instance config as it is right now. -instanceConfig :: IRC InstanceConfig +instanceConfig :: StatefulIRC s (InstanceConfig s) instanceConfig = instanceConfigTVar >>= liftIO . atomically . readTVar -- | Overwrite the instance config, even if it has changed since we -- looked at it. -putInstanceConfig :: InstanceConfig -> IRC () +putInstanceConfig :: InstanceConfig s -> StatefulIRC s () putInstanceConfig iconf = instanceConfigTVar >>= liftIO . atomically . flip writeTVar iconf +-- | Access the user state. +stateTVar :: StatefulIRC s (TVar s) +stateTVar = _userState <$> ask + +-- | Access the user state as it is right now. +state :: StatefulIRC s s +state = stateTVar >>= liftIO . atomically . readTVar + +-- | Set the user state. +putState :: s -> StatefulIRC s () +putState s = stateTVar >>= liftIO . atomically . flip writeTVar s + -- | The origin of a message. data Origin = FromServer | FromClient deriving (Eq, Read, Show) -- | The static state of an IRC server connection. -data ConnectionConfig = ConnectionConfig +data ConnectionConfig s = ConnectionConfig { _func :: Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO () -- ^ Function to connect and start the conduits. , _sendqueue :: TBMChan IrcMessage @@ -99,14 +122,14 @@ -- ^ The server port. , _flood :: NominalDiffTime -- ^ The minimum time between two adjacent messages. - , _disconnect :: IRC () + , _disconnect :: StatefulIRC s () -- ^ Action to run if the remote server closes the connection. , _logfunc :: Origin -> ByteString -> IO () -- ^ Function to log messages sent to and received from the server. } -- | The updateable state of an IRC connection. -data InstanceConfig = InstanceConfig +data InstanceConfig s = InstanceConfig { _nick :: Text -- ^ Client nick , _username :: Text @@ -117,7 +140,7 @@ -- ^ Current channels , _ctcpVer :: Text -- ^ Response to CTCP VERSION - , _eventHandlers :: [EventHandler] + , _eventHandlers :: [EventHandler s] -- ^ The registered event handlers , _ignore :: [(Text, Maybe Text)] -- ^ List of nicks (optionally restricted to channels) to ignore @@ -136,12 +159,12 @@ deriving (Eq, Show) -- | A function which handles an event. -data EventHandler = EventHandler +data EventHandler s = EventHandler { _description :: Text -- ^ A description of the event handler. , _matchType :: EventType -- ^ Which type to be triggered by - , _eventFunc :: UnicodeEvent -> IRC () + , _eventFunc :: UnicodeEvent -> StatefulIRC s () -- ^ The function to call. } diff --git a/Network/IRC/Client/Utils.hs b/Network/IRC/Client/Utils.hs --- a/Network/IRC/Client/Utils.hs +++ b/Network/IRC/Client/Utils.hs @@ -13,7 +13,7 @@ -- | 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 () +setNick :: Text -> StatefulIRC s () setNick new = do tvarI <- instanceConfigTVar @@ -25,7 +25,7 @@ -- | Update the channel list in the instance configuration and also -- part the channel. -leaveChannel :: Text -> Maybe Text -> IRC () +leaveChannel :: Text -> Maybe Text -> StatefulIRC s () leaveChannel chan reason = do tvarI <- instanceConfigTVar liftIO . atomically $ delChan tvarI chan @@ -35,13 +35,13 @@ -- | 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 -> Text -> STM () +delChan :: TVar (InstanceConfig s) -> Text -> STM () delChan tvarI chan = do iconf <- readTVar tvarI writeTVar tvarI iconf { _channels = filter (/=chan) $ _channels iconf } -- | Send a message to the source of an event. -reply :: UnicodeEvent -> Text -> IRC () +reply :: UnicodeEvent -> Text -> StatefulIRC s () reply ev txt = case _source ev of Channel c _ -> mapM_ (send . Privmsg c . Right) $ T.lines txt User n -> mapM_ (send . Privmsg n . Right) $ T.lines txt diff --git a/irc-client.cabal b/irc-client.cabal --- a/irc-client.cabal +++ b/irc-client.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.4.0 +version: 0.2.5.0 -- A short (one-line) description of the package. synopsis: An IRC client library. @@ -77,7 +77,6 @@ -- Compile with -Wall by default ghc-options: -Wall - -fno-warn-unused-do-bind -- LANGUAGE extensions used by modules in this package. -- other-extensions: