Hello community, here is the log from the commit of package ghc-irc-conduit for openSUSE:Factory checked in at 2017-02-20 13:16:00 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-irc-conduit (Old) and /work/SRC/openSUSE:Factory/.ghc-irc-conduit.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-irc-conduit" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-irc-conduit/ghc-irc-conduit.changes 2017-02-13 07:48:21.408776627 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-irc-conduit.new/ghc-irc-conduit.changes 2017-02-20 13:16:00.308780469 +0100 @@ -1,0 +2,20 @@ +Sun Jan 8 21:13:38 UTC 2017 - [email protected] + +- Update to version 0.2.2.0 with cabal2obs. + +------------------------------------------------------------------- +Sun Oct 30 16:26:13 UTC 2016 - [email protected] + +- Update to version 0.2.1.1 with cabal2obs. + +------------------------------------------------------------------- +Mon Sep 26 06:49:59 UTC 2016 - [email protected] + +- Update to version 0.2.1.0 with cabal2obs. + +------------------------------------------------------------------- +Thu Sep 15 06:45:09 UTC 2016 - [email protected] + +- Update to version 0.2.0.0 revision 0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- irc-conduit-0.1.2.0.tar.gz New: ---- irc-conduit-0.2.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-irc-conduit.spec ++++++ --- /var/tmp/diff_new_pack.v8LYo7/_old 2017-02-20 13:16:00.776714677 +0100 +++ /var/tmp/diff_new_pack.v8LYo7/_new 2017-02-20 13:16:00.776714677 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-irc-conduit # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,15 +18,14 @@ %global pkg_name irc-conduit Name: ghc-%{pkg_name} -Version: 0.1.2.0 +Version: 0.2.2.0 Release: 0 Summary: Streaming IRC message library using conduits License: MIT -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-async-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-conduit-devel @@ -35,6 +34,7 @@ BuildRequires: ghc-irc-ctcp-devel BuildRequires: ghc-irc-devel BuildRequires: ghc-network-conduit-tls-devel +BuildRequires: ghc-profunctors-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-text-devel BuildRequires: ghc-time-devel @@ -42,7 +42,6 @@ BuildRequires: ghc-transformers-devel BuildRequires: ghc-x509-validation-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description IRC messages consist of an optional identifying prefix, a command name, and a @@ -71,15 +70,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ irc-conduit-0.1.2.0.tar.gz -> irc-conduit-0.2.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal/Conduits.hs new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal/Conduits.hs --- old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal/Conduits.hs 2014-09-05 19:53:38.000000000 +0200 +++ new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal/Conduits.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,55 +0,0 @@ -{-# 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal/Messages.hs new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal/Messages.hs --- old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal/Messages.hs 2014-09-06 19:05:31.000000000 +0200 +++ new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal/Messages.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,190 +0,0 @@ -{-# 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal.hs new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal.hs --- old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Internal.hs 2014-09-05 19:44:30.000000000 +0200 +++ new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Internal.hs 2017-01-03 18:41:45.000000000 +0100 @@ -1,7 +1,255 @@ -module Network.IRC.Conduit.Internal - ( module Network.IRC.Conduit.Internal.Conduits - , module Network.IRC.Conduit.Internal.Messages - ) where +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} -import Network.IRC.Conduit.Internal.Conduits -import Network.IRC.Conduit.Internal.Messages +-- | +-- Module : Network.IRC.Conduit.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <[email protected]> +-- Stability : experimental +-- Portability : BangPatterns, DeriveFunctor, OverloadedStrings, RankNTypes, TupleSections +-- +-- Internal IRC conduit types and utilities. This module is NOT +-- considered to form part of the public interface of this library. +module Network.IRC.Conduit.Internal where + +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Data.ByteString (ByteString, isSuffixOf, singleton, unpack) +import Data.Char (ord) +import Data.Conduit (Conduit, await, yield) +import Data.Maybe (listToMaybe, isJust) +import Data.Monoid ((<>)) +import Data.Profunctor (Choice) +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 + +-- * Internal Lens synonyms + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'. +type Prism' s a = Prism s s a a + + +-- *Conduits + +-- |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 () + +-- *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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Lens.hs new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Lens.hs --- old/irc-conduit-0.1.2.0/Network/IRC/Conduit/Lens.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/irc-conduit-0.2.2.0/Network/IRC/Conduit/Lens.hs 2017-01-03 18:41:45.000000000 +0100 @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <[email protected]> +-- Stability : experimental +-- Portability : CPP +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Conduit.Lens where + +import Data.ByteString (ByteString) +import Data.Profunctor (Choice (right'), Profunctor (dimap)) + +import Network.IRC.CTCP (CTCPByteString) +import Network.IRC.Conduit.Internal + +-- CPP seem to dislike the first ' on the RHS… +#define PRIME() ' + +#define LENS(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Lens' for '_/**/F'. -}; \ + F :: Lens' S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define PRISM(S,C,ARG,TUP,A) \ + {-| PRIME()Prism' for 'C'. -}; \ + {-# INLINE _/**/C #-}; \ + _/**/C :: Prism' S A; \ + _/**/C = dimap (\ s -> case s of C ARG -> Right TUP; _ -> Left s) \ + (either pure $ fmap (\ TUP -> C ARG)) . right' + +-- * Lenses for 'Event' +LENS((Event a),raw,ByteString) +LENS((Event a),source,(Source a)) +LENS((Event a),message,(Message a)) + +-- * Prisms for 'Source' +PRISM((Source a),User,name,name,(NickName a)) +PRISM((Source a),Channel,chan name,(chan,name),(ChannelName a, NickName a)) +PRISM((Source a),Server,name,name,(ServerName a)) + +-- * #Message# Prisms for 'Message' +PRISM((Message a),Privmsg,tar msg,(tar, msg),(Target a, Either CTCPByteString a)) +PRISM((Message a),Notice,tar msg,(tar, msg),(Target a, Either CTCPByteString a)) +PRISM((Message a),Nick,name,name,(NickName a)) +PRISM((Message a),Join,chan,chan,(ChannelName a)) +PRISM((Message a),Part,chan reason,(chan, reason),(ChannelName a, Reason a)) +PRISM((Message a),Quit,reason,reason,(Reason a)) +PRISM((Message a),Mode,tar is flags args,(tar, is, flags, args),(Target a, IsModeSet, [ModeFlag a], [ModeArg a])) +PRISM((Message a),Topic,name topic,(name, topic),(ChannelName a, a)) +PRISM((Message a),Invite,chan name,(chan, name),(ChannelName a, NickName a)) +PRISM((Message a),Kick,chan name reason,(chan, name, reason),(ChannelName a, NickName a, Reason a)) +PRISM((Message a),Ping,ser ver,(ser, ver),(ServerName a, Maybe (ServerName a))) +PRISM((Message a),Pong,ser,ser,(ServerName a)) +PRISM((Message a),Numeric,num args,(num, args),(Int, [NumericArg a])) +PRISM((Message a),RawMsg,msg,msg,a) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/Network/IRC/Conduit.hs new/irc-conduit-0.2.2.0/Network/IRC/Conduit.hs --- old/irc-conduit-0.1.2.0/Network/IRC/Conduit.hs 2014-10-30 02:21:21.000000000 +0100 +++ new/irc-conduit-0.2.2.0/Network/IRC/Conduit.hs 2017-01-02 18:40:06.000000000 +0100 @@ -1,7 +1,15 @@ -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} --- |Conduits for serialising and deserialising IRC messages. +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <[email protected]> +-- Stability : experimental +-- Portability : OverloadedStrings, RankNTypes +-- +-- 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 @@ -36,22 +44,27 @@ -- *Networking , ircClient - , ircTLSClient , ircWithConn + -- ** TLS + , ircTLSClient + , ircTLSClient' + , defaultTLSConfig -- *Utilities , rawMessage , toByteString + + -- *Lenses + , module Network.IRC.Conduit.Lens ) where import Control.Applicative ((*>)) import Control.Concurrent (newMVar, takeMVar, putMVar, threadDelay) import Control.Concurrent.Async (Concurrently(..)) -import Control.Exception (catch) 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 (Conduit, Consumer, Producer, (=$), ($$), (=$=), awaitForever, yield, runConduit) import Data.Conduit.Network (AppData, clientSettings, runTCPClient, appSource, appSink) import Data.Conduit.Network.TLS (TLSClientConfig(..), tlsClientConfig, runTLSClient) import Data.Monoid ((<>)) @@ -61,9 +74,9 @@ import Data.X509.Validation (FailedReason(..)) import Network.Connection (TLSSettings(..)) import Network.IRC.Conduit.Internal -import Network.TLS (ClientParams(..), ClientHooks(..), Supported(..), TLSException, Version(..), defaultParamsClient) +import Network.IRC.Conduit.Lens +import Network.TLS (ClientParams(..), ClientHooks(..), Supported(..), Version(..), defaultParamsClient) import Network.TLS.Extra (ciphersuite_all) -import System.IO.Error (catchIOError) -- *Conduits @@ -133,51 +146,74 @@ -> 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 . mangle $ tlsClientConfig port host - where - -- Override the certificate validation and allowed ciphers. - mangle tlsSettings = tlsSettings - { tlsClientTLSSettings = TLSSettings cpara - { clientHooks = (clientHooks cpara) - { onServerCertificate = validate } - , clientSupported = (clientSupported cpara) - { supportedVersions = [TLS12, TLS11, TLS10] - , supportedCiphers = ciphersuite_all }}} - where - cpara = defaultParamsClient (unpack $ decodeUtf8 host) "" - - -- Make the TLS certificate validation a bit more generous. In - -- particular, allow self-signed certificates. - validate cs vc sid cc = do - -- First validate with the standard function - res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc - -- Then strip out non-issues - return $ filter (`notElem` [UnknownCA, SelfSigned]) res +ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host -- |Run the IRC conduits using a provided connection. +-- +-- Starts the connection and concurrently run the initialiser, event +-- consumer, and message sources. Terminates as soon as one throws an +-- exception. ircWithConn :: ((AppData -> IO ()) -> IO ()) -- ^The initialised connection. -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO () -ircWithConn runner start cons prod = (go `catch` raiseTLS) `catchIOError` ignore +ircWithConn runner start cons prod = runner $ \appdata -> runConcurrently $ + Concurrently start + *> Concurrently (runSource appdata) + *> Concurrently (runSink appdata) + 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) + runSource appdata = do + runConduit $ appSource appdata =$= ircDecoder =$ cons + ioError $ userError "Upstream source closed." + + runSink appdata = prod $$ ircEncoder =$ appSink appdata + +-- **TLS + +-- |Like 'ircClient', but with TLS. The TLS configuration used is +-- 'defaultTLSConfig'. +ircTLSClient :: Int + -> ByteString + -> IO () + -> Consumer (Either ByteString IrcEvent) IO () + -> Producer IO IrcMessage -> IO () +ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host) + +-- |Like 'ircTLSClient', but takes the configuration to use, which +-- includes the host and port. +ircTLSClient' :: TLSClientConfig + -> IO () + -> Consumer (Either ByteString IrcEvent) IO () + -> Producer IO IrcMessage -> IO () +ircTLSClient' cfg = ircWithConn (runTLSClient cfg) + +-- |The default TLS settings for 'ircTLSClient'. +defaultTLSConfig :: Int + -- ^The port number + -> ByteString + -- ^ The hostname + -> TLSClientConfig +defaultTLSConfig port host = (tlsClientConfig port host) + { tlsClientTLSSettings = TLSSettings cpara + { clientHooks = (clientHooks cpara) + { onServerCertificate = validate } + , clientSupported = (clientSupported cpara) + { supportedVersions = [TLS12, TLS11, TLS10] + , supportedCiphers = ciphersuite_all + } + } + } - -- Ignore all exceptions and just halt. - ignore _ = return () + where + cpara = defaultParamsClient (unpack $ decodeUtf8 host) "" - -- Rethrow TLS exceptions as IO exceptions - raiseTLS = const . ioError $ userError "TLS exception" :: TLSException -> IO () + -- Make the TLS certificate validation a bit more generous. In + -- particular, allow self-signed certificates. + validate cs vc sid cc = do + -- First validate with the standard function + res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc + -- Then strip out non-issues + return $ filter (`notElem` [UnknownCA, SelfSigned]) res diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/irc-conduit-0.1.2.0/irc-conduit.cabal new/irc-conduit-0.2.2.0/irc-conduit.cabal --- old/irc-conduit-0.1.2.0/irc-conduit.cabal 2015-08-01 13:05:48.000000000 +0200 +++ new/irc-conduit-0.2.2.0/irc-conduit.cabal 2017-01-03 22:06:05.000000000 +0100 @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.2.0 +version: 0.2.2.0 -- A short (one-line) description of the package. synopsis: Streaming IRC message library using conduits. @@ -67,11 +67,11 @@ library -- Modules exported by the library. exposed-modules: Network.IRC.Conduit - + , Network.IRC.Conduit.Internal + , Network.IRC.Conduit.Lens + -- Modules included in this library but not exported. - other-modules: Network.IRC.Conduit.Internal - , Network.IRC.Conduit.Internal.Conduits - , Network.IRC.Conduit.Internal.Messages + -- other-modules: ghc-options: -Wall @@ -79,21 +79,22 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.5 && <5 - , async >=2.0 - , bytestring >=0.10 - , conduit >=1.2 - , conduit-extra >=1.1 - , connection - , irc >=0.6 - , irc-ctcp >=0.1.1 - , network-conduit-tls >=1.1 - , text >=1.0 - , time >=1.4 - , tls - , transformers >=0.3 - , x509-validation - + build-depends: base >=4.8 && <5 + , async >=2.0 && <2.2 + , bytestring >=0.10 && <0.11 + , conduit >=1.2 && <1.3 + , conduit-extra >=1.1 && <1.2 + , connection >=0.2 && <0.3 + , irc >=0.6 && <0.7 + , irc-ctcp >=0.1.1 && <0.2 + , network-conduit-tls >=1.1 && <1.3 + , profunctors >=5 && <6 + , text >=1.0 && <1.3 + , time >=1.4 && <1.7 + , tls >=1.3 && <1.4 + , transformers >=0.3 && <0.6 + , x509-validation >=1.6 && <1.7 + -- Directories containing source files. -- hs-source-dirs: @@ -107,4 +108,4 @@ source-repository this type: git location: https://github.com/barrucadu/irc-conduit.git - tag: 0.1.2.0 + tag: 0.2.2.0
