diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ + DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + Version 2, December 2004 + + Copyright (C) 2004 Sam Hocevar + + 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. diff --git a/Network/IRC/Conduit.hs b/Network/IRC/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Conduit.hs @@ -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 () diff --git a/Network/IRC/Conduit/Internal.hs b/Network/IRC/Conduit/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Conduit/Internal.hs @@ -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 diff --git a/Network/IRC/Conduit/Internal/Conduits.hs b/Network/IRC/Conduit/Internal/Conduits.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Conduit/Internal/Conduits.hs @@ -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." diff --git a/Network/IRC/Conduit/Internal/Messages.hs b/Network/IRC/Conduit/Internal/Messages.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Conduit/Internal/Messages.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/irc-conduit.cabal b/irc-conduit.cabal new file mode 100644 --- /dev/null +++ b/irc-conduit.cabal @@ -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 + 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 +