irc-conduit (empty) → 0.1.0.0
raw patch · 7 files changed
+519/−0 lines, 7 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, conduit, conduit-extra, irc, irc-ctcp, network-conduit-tls, time, transformers
Files
- LICENSE +13/−0
- Network/IRC/Conduit.hs +154/−0
- Network/IRC/Conduit/Internal.hs +7/−0
- Network/IRC/Conduit/Internal/Conduits.hs +55/−0
- Network/IRC/Conduit/Internal/Messages.hs +190/−0
- Setup.hs +2/−0
- irc-conduit.cabal +98/−0
+ LICENSE view
@@ -0,0 +1,13 @@+ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + Version 2, December 2004 ++ Copyright (C) 2004 Sam Hocevar <sam@hocevar.net> ++ Everyone is permitted to copy and distribute verbatim or modified + copies of this license document, and changing it is allowed as long + as the name is changed. ++ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION ++ 0. You just DO WHAT THE FUCK YOU WANT TO.
+ Network/IRC/Conduit.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- |Conduits for serialising and deserialising IRC messages.+--+-- The 'Event', 'Message', and 'Source' types are parameterised on the+-- underlying representation, and are functors. Decoding and encoding+-- only work in terms of 'ByteString's, but the generality is provided+-- so that programs using this library can operate in terms of 'Text',+-- or some other more useful representation, with great ease.+module Network.IRC.Conduit+ ( -- *Type synonyms+ ChannelName+ , NickName+ , ServerName+ , Reason+ , IsModeSet+ , ModeFlag+ , ModeArg+ , NumericArg+ , Target+ , IrcEvent+ , IrcSource+ , IrcMessage++ -- *Messages+ , Event(..)+ , Source(..)+ , Message(..)++ -- *Conduits+ , ircDecoder+ , ircLossyDecoder+ , ircEncoder+ , floodProtector++ -- *Networking+ , ircClient+ , ircTLSClient+ , ircWithConn++ -- *Utilities+ , rawMessage+ , toByteString+ ) where++import Control.Applicative ((*>))+import Control.Concurrent (newMVar, takeMVar, putMVar, threadDelay)+import Control.Concurrent.Async (Concurrently(..))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Conduit (Conduit, Consumer, Producer, (=$), ($$), (=$=), awaitForever, yield)+import Data.Conduit.Network (AppData, clientSettings, runTCPClient, appSource, appSink)+import Data.Conduit.Network.TLS (tlsClientConfig, runTLSClient)+import Data.Monoid ((<>))+import Data.Time.Clock (NominalDiffTime, getCurrentTime, addUTCTime, diffUTCTime)+import Network.IRC.Conduit.Internal+import System.IO.Error (catchIOError)++-- *Conduits++-- |A conduit which takes as input bytestrings representing encoded+-- IRC messages, and decodes them to events. If decoding fails, the+-- original bytestring is just passed through.+ircDecoder :: Monad m => Conduit ByteString m (Either ByteString IrcEvent)+ircDecoder = chunked =$= awaitForever (yield . fromByteString)++-- |Like 'ircDecoder', but discards messages which could not be+-- decoded.+ircLossyDecoder :: Monad m => Conduit ByteString m IrcEvent+ircLossyDecoder = chunked =$= awaitForever lossy+ where+ lossy bs = either (\_ -> return ()) yield $ fromByteString bs++-- |A conduit which takes as input irc messages, and produces as+-- output the encoded bytestring representation.+ircEncoder :: Monad m => Conduit IrcMessage m ByteString+ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString)++-- |A conduit which rate limits output sent downstream. Awaiting on+-- this conduit will block, even if there is output ready, until the+-- time limit has passed.+floodProtector :: MonadIO m+ => NominalDiffTime+ -- ^The minimum time between sending adjacent messages.+ -> IO (Conduit a m a)+floodProtector delay = do+ now <- getCurrentTime+ mvar <- newMVar now++ return $ conduit mvar++ where+ conduit mvar = awaitForever $ \val -> do+ -- Block until the delay has passed+ liftIO $ do+ lastT <- takeMVar mvar+ now <- getCurrentTime++ let next = addUTCTime delay lastT++ when (next < now) $+ threadDelay . ceiling $ 1000000 * diffUTCTime next now++ -- Update the time+ now' <- getCurrentTime+ putMVar mvar now'++ -- Send the value downstream+ yield val++-- *Networking++-- |Connect to a network server, without TLS, and concurrently run the+-- producer and consumer.+ircClient :: Int+ -- ^The port number+ -> ByteString+ -- ^The hostname+ -> IO ()+ -- ^Any initialisation work (started concurrently with the+ -- producer and consumer)+ -> Consumer (Either ByteString IrcEvent) IO ()+ -- ^The consumer of irc events+ -> Producer IO IrcMessage+ -- ^The producer of irc messages+ -> IO ()+ircClient port host = ircWithConn . runTCPClient $ clientSettings port host++-- |Like 'ircClient', but with TLS.+ircTLSClient :: Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ()+ircTLSClient port host = ircWithConn . runTLSClient $ tlsClientConfig port host++-- |Run the IRC conduits using a provided connection.+ircWithConn :: ((AppData -> IO ()) -> IO ())+ -- ^The initialised connection.+ -> IO ()+ -> Consumer (Either ByteString IrcEvent) IO ()+ -> Producer IO IrcMessage+ -> IO ()+ircWithConn runner start cons prod = go `catchIOError` ignore+ where+ -- Start the connection and concurrently run the initialiser,+ -- event consumer, and message sources: terminating as soon as one+ -- throws an exception.+ go = runner $ \appdata ->+ runConcurrently $+ Concurrently start *>+ Concurrently (appSource appdata =$= exceptionalConduit $$ ircDecoder =$ cons) *>+ Concurrently (prod $$ ircEncoder =$ appSink appdata)++ -- Ignore all exceptions and just halt.+ ignore _ = return ()
+ Network/IRC/Conduit/Internal.hs view
@@ -0,0 +1,7 @@+module Network.IRC.Conduit.Internal+ ( module Network.IRC.Conduit.Internal.Conduits+ , module Network.IRC.Conduit.Internal.Messages+ ) where++import Network.IRC.Conduit.Internal.Conduits+import Network.IRC.Conduit.Internal.Messages
+ Network/IRC/Conduit/Internal/Conduits.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- |Internal helper conduits+module Network.IRC.Conduit.Internal.Conduits where++import Control.Arrow ((&&&))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString, isSuffixOf, singleton)+import Data.Conduit (Conduit, await, yield)+import Data.Monoid ((<>))++import qualified Data.ByteString as B++-- |Split up incoming bytestrings into new lines.+chunked :: Monad m => Conduit ByteString m ByteString+chunked = chunked' ""+ where+ chunked' leftover = do+ -- Wait for a value from upstream+ val <- await++ case val of+ Just val' ->+ let+ carriage = fromIntegral $ fromEnum '\r'+ newline = fromIntegral $ fromEnum '\n'++ -- Split on '\n's, removing any stray '\r's (line endings+ -- are usually '\r\n's, but this isn't certain).+ bytes = B.filter (/=carriage) $ leftover <> val'+ splitted = B.split newline bytes++ -- If the last chunk ends with a '\n', then we have a+ -- complete message at the end, and can yield it+ -- immediately. Otherwise, store the partial message to+ -- prepend to the next bytestring received.+ (toyield, remainder)+ | singleton newline `isSuffixOf` bytes = (splitted, "")+ | otherwise = init &&& last $ splitted++ in do+ -- Yield all complete and nonempty messages, and loop.+ mapM_ yield $ filter (not . B.null) toyield+ chunked' remainder++ Nothing -> return ()++-- |Throw an IO exception when the upstream conduit is closed.+exceptionalConduit :: MonadIO m => Conduit a m a+exceptionalConduit = do+ val <- await+ case val of+ Just x -> yield x >> exceptionalConduit+ Nothing -> liftIO . ioError $ userError "Upstream source closed."
+ Network/IRC/Conduit/Internal/Messages.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- |Internal IRC conduit types and utilities.+module Network.IRC.Conduit.Internal.Messages where++import Control.Applicative ((<$>))+import Data.ByteString (ByteString, singleton, unpack)+import Data.Char (ord)+import Data.Maybe (listToMaybe, isJust)+import Data.Monoid ((<>))+import Data.String (fromString)+import Network.IRC.CTCP (CTCPByteString, getUnderlyingByteString, orCTCP)+import Text.Read (readMaybe)++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Network.IRC as I++-- *Type synonyms+type ChannelName a = a+type NickName a = a+type ServerName a = a+type Reason a = Maybe a+type IsModeSet = Bool+type ModeFlag a = a+type ModeArg a = a+type NumericArg a = a++-- |The target of a message. Will be a nick or channel name.+type Target a = a++type IrcEvent = Event ByteString+type IrcSource = Source ByteString+type IrcMessage = Message ByteString++-- *Messages++-- |A decoded IRC message + source.+data Event a = Event+ { _raw :: ByteString+ -- ^The message as a bytestring.+ , _source :: Source a+ -- ^The source of the message (user, channel, or server).+ , _message :: Message a+ -- ^The decoded message. This will never be a 'RawMsg'.+ }+ deriving (Eq, Functor, Show)++-- |The source of an IRC message.+data Source a = User (NickName a)+ -- ^The message comes directly from a user.+ | Channel (ChannelName a) (NickName a)+ -- ^The message comes from a user in a channel.+ | Server (ServerName a)+ -- ^The message comes directly from the server.+ deriving (Eq, Functor, Show)++-- |A decoded IRC message.+data Message a = Privmsg (Target a) (Either CTCPByteString a)+ -- ^A message, either from a user or to a channel the+ -- client is in. CTCPs are distinguished by starting+ -- and ending with a \\001 (SOH).+ | Notice (Target a) (Either CTCPByteString a)+ -- ^Like a privmsg, but should not provoke an automatic+ -- response.+ | Nick (NickName a)+ -- ^Someone has updated their nick.+ | Join (ChannelName a)+ -- ^Someone has joined a channel.+ | Part (ChannelName a) (Reason a)+ -- ^Someone has left a channel.+ | Quit (Reason a)+ -- ^Someone has left the network.+ | Mode (Target a) IsModeSet [ModeFlag a] [ModeArg a]+ -- ^Someone has set some channel modes or user modes.+ | Topic (ChannelName a) a+ -- ^Someone has set the topic of a channel.+ | Invite (ChannelName a) (NickName a)+ -- ^The client has been invited to a channel.+ | Kick (ChannelName a) (NickName a) (Reason a)+ -- ^Someone has been kicked from a channel.+ | Ping (ServerName a) (Maybe (ServerName a))+ -- ^The client has received a server ping, and should+ -- send a pong asap.+ | Pong (ServerName a)+ -- ^A pong sent to the named server.+ | Numeric Int [NumericArg a]+ -- ^One of the many server numeric responses.+ | RawMsg a+ -- ^Never produced by decoding, but can be used to send+ -- arbitrary bytestrings to the IRC server. Naturally,+ -- this should only be used when you are confident that+ -- the produced bytestring will be a valid IRC message.+ deriving (Eq, Functor, Show)++-- *Decoding messages++fromByteString :: ByteString -> Either ByteString IrcEvent+fromByteString bs = maybe (Left bs) Right $ uncurry (Event bs) <$> attemptDecode bs++-- |Attempt to decode a ByteString into a message, returning a Nothing+-- if either the source or the message can't be determined.+attemptDecode :: ByteString -> Maybe (IrcSource, IrcMessage)+attemptDecode bs = I.decode bs >>= decode'+ where+ decode' msg = case msg of+ -- Disambiguate PRIVMSG and NOTICE source by checking the first+ -- character of the target+ I.Message (Just (I.NickName n _ _)) "PRIVMSG" [t, m] | isChan t -> Just (Channel t n, privmsg t m)+ | otherwise -> Just (User n, privmsg t m)++ I.Message (Just (I.NickName n _ _)) "NOTICE" [t, m] | isChan t -> Just (Channel t n, notice t m)+ | otherwise -> Just (User n, notice t m)++ I.Message (Just (I.NickName n _ _)) "NICK" [n'] -> Just (User n, Nick n')+ I.Message (Just (I.NickName n _ _)) "JOIN" [c] -> Just (Channel c n, Join c)+ I.Message (Just (I.NickName n _ _)) "PART" (c:r) -> Just (Channel c n, Part c $ listToMaybe r)+ I.Message (Just (I.NickName n _ _)) "QUIT" r -> Just (User n, Quit $ listToMaybe r)+ I.Message (Just (I.NickName n _ _)) "KICK" (c:u:r) -> Just (Channel c n, Kick c u $ listToMaybe r)+ I.Message (Just (I.NickName n _ _)) "INVITE" [_, c] -> Just (User n, Invite c n)+ I.Message (Just (I.NickName n _ _)) "TOPIC" [c, t] -> Just (Channel c n, Topic c t)++ I.Message (Just (I.NickName n _ _)) "MODE" (t:fs:as) | n == t -> (User n,) <$> mode t fs as+ | otherwise -> (Channel t n,) <$> mode t fs as++ I.Message (Just (I.Server s)) "PING" (s1:s2) -> Just (Server s, Ping s1 $ listToMaybe s2)+ I.Message Nothing "PING" (s1:s2) -> Just (Server s1, Ping s1 $ listToMaybe s2)++ I.Message (Just (I.Server s)) n args | isNumeric n -> (Server s,) <$> numeric n args++ _ -> Nothing++ -- An IRC channel name can start with '#', '&', '+', or '!', all+ -- of which have different meanings. However, most servers only+ -- support '#'.+ isChan t = B.take 1 t `elem` ["#", "&", "+", "!"]++ -- Check if the message looks like a ctcp or not, and produce the appropriate message type.+ privmsg t = Privmsg t . (Right `orCTCP` Left)+ notice t = Notice t . (Right `orCTCP` Left)++ -- Decode a set of mode changes+ mode t fs as = case unpack fs of+ (f:fs') | f == fromIntegral (ord '+') -> Just $ Mode t True (map singleton fs') as+ | f == fromIntegral (ord '-') -> Just $ Mode t False (map singleton fs') as+ _ -> Nothing++ -- Parse the number in a numeric response+ isNumeric = isJust . (readMaybe :: String -> Maybe Int) . B8.unpack+ numeric n args = flip Numeric args <$> readMaybe (B8.unpack n)++-- *Encoding messages++-- |Encode an IRC message into a single bytestring suitable for+-- sending to the server.+toByteString :: IrcMessage -> ByteString+toByteString (Privmsg t (Left ctcpbs)) = mkMessage "PRIVMSG" [t, getUnderlyingByteString ctcpbs]+toByteString (Privmsg t (Right bs)) = mkMessage "PRIVMSG" [t, bs]+toByteString (Notice t (Left ctcpbs)) = mkMessage "NOTICE" [t, getUnderlyingByteString ctcpbs]+toByteString (Notice t (Right bs)) = mkMessage "NOTICE" [t, bs]+toByteString (Nick n) = mkMessage "NICK" [n]+toByteString (Join c) = mkMessage "JOIN" [c]+toByteString (Part c (Just r)) = mkMessage "PART" [c, r]+toByteString (Part c Nothing) = mkMessage "PART" [c]+toByteString (Quit (Just r)) = mkMessage "QUIT" [r]+toByteString (Quit Nothing) = mkMessage "QUIT" []+toByteString (Mode t True ms as) = mkMessage "MODE" $ t : ("+" <> B.concat ms) : as+toByteString (Mode t False ms as) = mkMessage "MODE" $ t : ("-" <> B.concat ms) : as+toByteString (Invite c n) = mkMessage "INVITE" [c, n]+toByteString (Topic c bs) = mkMessage "TOPIC" [c, bs]+toByteString (Kick c n (Just r)) = mkMessage "KICK" [c, n, r]+toByteString (Kick c n Nothing) = mkMessage "KICK" [c, n]+toByteString (Ping s1 (Just s2)) = mkMessage "PING" [s1, s2]+toByteString (Ping s1 Nothing) = mkMessage "PING" [s1]+toByteString (Pong s) = mkMessage "PONG" [s]+toByteString (Numeric n as) = mkMessage (fromString $ show n) as+toByteString (RawMsg bs) = bs++mkMessage :: ByteString -> [ByteString] -> ByteString+mkMessage cmd = I.encode . I.Message Nothing cmd++-- |Construct a raw message.+rawMessage :: ByteString+ -- ^The command+ -> [ByteString]+ -- ^The arguments+ -> IrcMessage+rawMessage cmd = RawMsg . mkMessage cmd
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ irc-conduit.cabal view
@@ -0,0 +1,98 @@+-- Initial irc-conduit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: irc-conduit++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Streaming IRC message library using conduits.++-- A longer description of the package.+description:+ IRC messages consist of an optional identifying prefix, a command+ name, and a list of arguments. The <http://hackage.haskell.org/package/irc irc>+ package provides a low-level decoding and encoding scheme for+ messages in terms of ByteStrings, but using this relies on matching+ names of commands as strings, and unpacking this decoded structure+ yourself. This package takes it a little further, providing an ADT+ for IRC messages and sources, and conduits which attempt to decode+ and encode messages appropriately.+ .+ In addition to providing conduits for automatically handling+ streaming messages, there are also helper functions for connecting+ to an IRC server and hooking up conduits to the socket.++-- URL for the project homepage or repository.+homepage: https://github.com/barrucadu/irc-conduit++-- URL where users should direct bug reports.+bug-reports: https://github.com/barrucadu/irc-conduit/issues++-- The license under which the package is released.+license: OtherLicense++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Michael Walker++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: mike@barrucadu.co.uk++-- A copyright notice.+-- copyright: ++category: Network++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10+++library+ -- Modules exported by the library.+ exposed-modules: Network.IRC.Conduit+ + -- Modules included in this library but not exported.+ other-modules: Network.IRC.Conduit.Internal+ , Network.IRC.Conduit.Internal.Conduits+ , Network.IRC.Conduit.Internal.Messages++ ghc-options: -Wall+ + -- LANGUAGE extensions used by modules in this package.+ -- other-extensions: + + -- Other library packages from which modules are imported.+ build-depends: base >=4.7 && <5+ , async >=2.0+ , bytestring >=0.10+ , conduit >=1.2+ , conduit-extra >=1.1+ , irc >=0.6+ , irc-ctcp >=0.1.1+ , network-conduit-tls >=1.1+ , time >=1.4+ , transformers >=0.4+ + -- Directories containing source files.+ -- hs-source-dirs: + + -- Base language which the package is written in.+ default-language: Haskell2010+