packages feed

irc-fun-messages 0.3.0.0 → 0.4

raw patch · 29 files changed

+1966/−1943 lines, 29 filesdep ~irc-fun-typesdep ~regex-applicativedep ~text

Dependency ranges changed: irc-fun-types, regex-applicative, text

Files

ChangeLog view
@@ -1,7 +1,7 @@ The changes are recorded by the version control system, Darcs. To see a log quickly from the terminal, run: -  $ darcs changes --repo http://dev.rel4tion.org/fr33domlover/irc-fun-messages+  $ darcs changes --repo http://hub.darcs.net/fr33domlover/irc-fun-messages  There is also a web interface at <http://darcs.rel4tion.org> which, among other things, can display the history log.@@ -9,7 +9,7 @@ To see the log in a local clone, first get a copy of the repository if you haven't yet: -  $ darcs get http://dev.rel4tion.org/fr33domlover/irc-fun-messages+  $ darcs get http://hub.darcs.net/fr33domlover/irc-fun-messages  Then move into the newly created directory and run darcs:
NEWS.md view
@@ -3,6 +3,30 @@   +irc-fun-messages 0.4        2016-09-05+======================================++General, build and documentation changes:++* Change module names+* Build with stack++New APIs, features and enhancements:++* (None)++Bug fixes:++* (None)++Dependency changes:++* Require irc-fun-types >= 0.2+++++ irc-fun-messages 0.3.0.0 -- 2016-01-27 ======================================
irc-fun-messages.cabal view
@@ -1,10 +1,9 @@ name:                irc-fun-messages-version:             0.3.0.0+version:             0.4 synopsis:            Types and functions for working with the IRC protocol. description:   Another IRC library. It doesn't provide a client API though. It just provides-  datatypes, and functions for parsing and serializing IRC commands and-  replies.+  functions for parsing and serializing IRC commands and replies.   .   The package is based on RFC 2812, with modifications and extensions to work   with Freenode.@@ -14,7 +13,7 @@   needed while working on <https://notabug.org/fr33domlover/funbot FunBot>, and   of course patches are welcome. homepage:            http://rel4tion.org/projects/irc-fun-messages/-bug-reports:         http://rel4tion.org/projects/irc-fun-messages/tickets/+bug-reports:         https://notabug.org/fr33domlover/funbot/issues license:             PublicDomain license-file:        COPYING author:              fr33domlover@@ -30,24 +29,24 @@   location:            http://hub.darcs.net/fr33domlover/irc-fun-messages  library-  exposed-modules:     Network.IRC.Fun.Messages-                     , Network.IRC.Fun.Messages.Mask-                     , Network.IRC.Fun.Messages.Modes-                     , Network.IRC.Fun.Messages.Types-  other-modules:       Network.IRC.Fun.Messages.Internal.Parse-                     , Network.IRC.Fun.Messages.Internal.Serialize-                     , Network.IRC.Fun.Messages.Internal.Tokens.Message-                     , Network.IRC.Fun.Messages.Internal.Tokens.Other-                     , Network.IRC.Fun.Messages.Internal.Tokens.Reply-                     , Network.IRC.Fun.Messages.Internal.Tokens.Target-                     , Network.IRC.Fun.Messages.Internal.Tokens.Wildcards-                     , Network.IRC.Fun.Messages.Internal.Types-                     , Network.IRC.Fun.Messages.Internal.Util+  exposed-modules:     Network.Irc.Messages+                     , Network.Irc.Messages.Mask+                     , Network.Irc.Messages.Modes+                     , Network.Irc.Messages.Types+  other-modules:       Network.Irc.Messages.Internal.Parse+                     , Network.Irc.Messages.Internal.Serialize+                     , Network.Irc.Messages.Internal.Tokens.Message+                     , Network.Irc.Messages.Internal.Tokens.Other+                     , Network.Irc.Messages.Internal.Tokens.Reply+                     , Network.Irc.Messages.Internal.Tokens.Target+                     , Network.Irc.Messages.Internal.Tokens.Wildcards+                     , Network.Irc.Messages.Internal.Types+                     , Network.Irc.Messages.Internal.Util   -- other-extensions:       build-depends:       base              >=4.7 && <5-                     , irc-fun-types-                     , regex-applicative >=0.3.1-                     , text              >=1+                     , irc-fun-types     >=0.2+                     , regex-applicative+                     , text   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall
− src/Network/IRC/Fun/Messages.hs 
@@ -1,37 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | This module handles parsing and serializing IRC messages and replies.--- Types and other functionality are provided in the submodules.-module Network.IRC.Fun.Messages-    ( -- * Parsing-      parseMessage-    , messageIsReply-    , messageToReply-    , parse-    , analyzeMessage-    , analyzeReply-    , analyze-      -- * Serializing-    , buildMessage-    , buildReply-    , messageFromReply-    , serializeMessage-    , serializeReply-    )-where--import Network.IRC.Fun.Messages.Internal.Parse-import Network.IRC.Fun.Messages.Internal.Serialize
− src/Network/IRC/Fun/Messages/Internal/Parse.hs 
@@ -1,377 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--{-# LANGUAGE OverloadedStrings #-}--module Network.IRC.Fun.Messages.Internal.Parse-    ( -- * Parsing-      parseMessage-    , messageIsReply-    , messageToReply-    , parse-      -- * Analysis-    , analyzeMessage-    , analyzeReply-    , analyze-    )-where--import Data.Bits (testBit)-import Data.Char (toUpper)-import Data.Monoid ((<>))-import Data.Text (Text, pack, unpack, isSuffixOf, stripPrefix, null, last,-                  init)-import Network.IRC.Fun.Messages.Mask (parseMask)-import Network.IRC.Fun.Messages.Modes (parseUserMode)-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Messages.Internal.Util-import Network.IRC.Fun.Types-import Prelude hiding (null, last, init)-import Text.Regex.Applicative-import Text.Regex.Applicative.Common (decimal)--import qualified Network.IRC.Fun.Messages.Internal.Tokens.Message as T-import qualified Network.IRC.Fun.Messages.Internal.Tokens.Other as T-import qualified Network.IRC.Fun.Messages.Internal.Tokens.Reply as T-import qualified Network.IRC.Fun.Messages.Internal.Tokens.Target as T------------------------------------------------------------------------------------ Parsing------------------------------------------------------------------------------------ | Parse a raw IRC message string into a generic message structure.-parseMessage :: Text -> Maybe GenericMessage-parseMessage t =-    let crlf = "\r\n"-        t' =-            if crlf `isSuffixOf` t-                then t-                else t <> crlf-    in  matcht T.message t'---- | Check is a given message is a server reply, i.e. has a numeric command and--- the sender is a server.-messageIsReply :: GenericMessage -> Bool-messageIsReply msg =-    let prefOk =-            case gmPrefix msg of-                Nothing         -> False-                Just (PrefixServer _) -> True-                Just (PrefixNick {})  -> False-        cmdOk =-            case gmCommand msg of-                NamedCmd _   -> False-                NumericCmd _ -> True-    in  prefOk && cmdOk---- | Try to convert a generic message into a matching reply value. If--- successful, return 'Right' the reply. If the message isn't a reply, return--- 'Left' an error message.-messageToReply :: GenericMessage -> Either Text GenericReply-messageToReply msg =-    case (gmPrefix msg, gmCommand msg, gmParams msg) of-        (Just (PrefixServer s), NumericCmd n, p : ps) ->-            Right GenericReply-                { grSender = s-                , grCode   = n-                , grTarget = NickTarget $ Nickname p-                , grParams = ps-                }-        (Just (PrefixServer _), NumericCmd _, []) ->-            Left "No parameters, must have at least one"-        (Just (PrefixNick {}),  NumericCmd _, _) ->-            Left "Sender prefix is a user, not a server"-        (Nothing,               NumericCmd _, _) ->-            Left "No sender prefix"-        (_,                     NamedCmd _,  _) ->-            Left "Command is not numeric"---- | Parse a raw IRC message string into a generic message structure. If the--- message is detected to be a server reply, a generic reply structure is--- returned.------ This is essentially a combination of 'parseMessage' and 'messageToReply'.-parse :: Text -> Maybe (Either GenericReply GenericMessage)-parse t =-    case parseMessage t of-        Nothing  -> Nothing-        Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg------------------------------------------------------------------------------------ Analysis----------------------------------------------------------------------------------mapLeft :: (a -> c) -> Either a b -> Either c b-mapLeft f (Left x)  = Left $ f x-mapLeft _ (Right x) = Right x--matcht :: Regex a -> Text -> Maybe a-matcht re = match re . unpack--analyzeMessage' :: Maybe Prefix-                -> String-                -> [Parameter]-                -> Either Text Message-analyzeMessage' _prefix cmd params = mapLeft (pack . show) $-    case map toUpper cmd of-    -- Connection registration-        "PASS"     -> req1 params $ \ pass ->-            Right $ PassMessage (Password pass)-        "NICK"     -> req1 params $ \ nick ->-            Right $ NickMessage (Nickname nick)-        "USER"     -> req4 params $ \ user mode _ realname ->-            case matcht decimal mode :: Maybe Int of-                Just m  ->-                    Right $-                    UserMessage-                        (Username user)-                        (testBit m 3)-                        (testBit m 2)-                        (RealName realname)-                Nothing ->-                    Left $-                    InvalidArg-                        (Just 2)-                        (Just "mode")-                        (Just "Should be a number")-        "OPER"     -> req2 params $ \ name pass ->-            Right $ OperMessage (Username name) (Password pass)-        "MODE"     -> min1 params $ \ first rest ->-            case (matcht T.nickname first, matcht T.channel first) of-                (Just nick, _)       ->-                    case rest of-                        [mode] ->-                            case parseUserMode mode of-                                Just (remove, add) ->-                                    Right $ UserModeMessage nick remove add-                                Nothing ->-                                    Left $-                                    InvalidArg (Just 1) (Just "mode") Nothing-                        l     -> Left $ WrongNumArgs (length l) Nothing-                (Nothing, Just _chan) ->-                    Left $ OtherError "Not implemented yet"-                    {-case parseChannelModeParams rest of-                        Just X ->-                        Nothing ->-}-                _                    ->-                    Left $ InvalidArg (Just 1) Nothing Nothing-        "SERVICE"  -> req6 params $ \ nick _ dist _ _ info ->-            case parseMask dist of-                Just m  -> Right $ ServiceMessage (Nickname nick) m info-                Nothing ->-                    Left $-                    InvalidArg (Just 3) (Just "distribution mask") Nothing-        "QUIT"     -> req0m1 params $ \ msg ->-            Right $ QuitMessage (fmap Comment msg)-        "SQUIT"    -> req2 params $ \ server comment ->-            Right $ SQuitMessage (Hostname server) (Comment comment)-    -- Channel operations-        "JOIN"     -> req1m2 params $ \ chans mkeys ->-            case (chans, mkeys) of-                ("0", Nothing) -> Right $ JoinMessage Nothing-                _              ->-                    let mcs = matcht (listOf T.channel) chans-                        mks = maybe (Just []) (matcht $ listOf T.key) mkeys-                    in  case (mcs, mks) of-                            (Nothing, _)       ->-                                Left $-                                InvalidArg (Just 1) (Just "channels") Nothing-                            (Just _,  Nothing) ->-                                Left $-                                InvalidArg (Just 2) (Just "keys") Nothing-                            (Just cs, Just ks) ->-                                Right $ JoinMessage $ Just (cs, ks)-        "PART"     -> req1m2 params $ \ chans msg ->-            case matcht (listOf T.channel) chans of-                Just cs -> Right $ PartMessage cs (fmap Comment msg)-                Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing-        -- "MODE" -> Channel mode handled by MODE above-        "TOPIC"    -> req1m2 params $ \ chan topic ->-            Right $ TopicMessage (Channel chan) (fmap ChannelTopic topic)-        "NAMES"    ->-            case params of-                []              -> Right $ NamesMessage [] Nothing-                [chans]         ->-                    case matcht (listOf T.channel) chans of-                        Just cs -> Right $ NamesMessage cs Nothing-                        Nothing ->-                            Left $-                            InvalidArg (Just 1) (Just "channels") Nothing-                [chans, target] ->-                    case matcht (listOf T.channel) chans of-                        Just cs ->-                            Right $ NamesMessage cs (Just $ Hostname target)-                        Nothing ->-                            Left $-                            InvalidArg (Just 1) (Just "channels") Nothing-                l               ->-                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)-        "LIST"     ->-            case params of-                []              -> Right $ ListMessage [] Nothing-                [chans]         ->-                    case matcht (listOf T.channel) chans of-                        Just cs -> Right $ ListMessage cs Nothing-                        Nothing ->-                            Left $-                            InvalidArg (Just 1) (Just "channels") Nothing-                [chans, target] ->-                    case matcht (listOf T.channel) chans of-                        Just cs ->-                            Right $ ListMessage cs (Just $ Hostname target)-                        Nothing ->-                            Left $-                            InvalidArg (Just 1) (Just "channels") Nothing-                l               ->-                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)-        "INVITE"   -> req2 params $ \ nick chan ->-            case (matcht T.nickname nick, matcht T.channel chan) of-                (Nothing, _)      ->-                    Left $ InvalidArg (Just 1) (Just "nickname") Nothing-                (Just _, Nothing) ->-                    Left $ InvalidArg (Just 2) (Just "channel") Nothing-                (Just n,  Just c) -> Right $ InviteMessage n c-        "KICK"     -> req2m3 params $ \ chans users comment ->-            let mcs = matcht (listOf T.channel) chans-                ucs = matcht (listOf T.user) users-            in  case (mcs, ucs) of-                    (Nothing, _)       ->-                        Left $ InvalidArg (Just 1) (Just "channels") Nothing-                    (Just _,  Nothing) ->-                        Left $ InvalidArg (Just 2) (Just "users") Nothing-                    (Just cs, Just us) ->-                        let lc = length cs-                            lu = length us-                        in  if lc == 1 || lc == lu-                                then Right $-                                     KickMessage cs us (fmap Comment comment)-                                else Left $ OtherError "Invalid list lengths"-    -- Sending messages-        "PRIVMSG"  -> req2 params $ \ target text ->-            case matcht T.msgto target of-                Nothing ->-                    Left $ InvalidArg (Just 1) (Just "target") (Just target)-                Just t ->-                    Right $ case stripPrefix "\1ACTION " text of-                        Just s  ->-                            if not (null s) && last s == '\1'-                                then PrivActionMessage t (MsgContent $ init s)-                                else PrivMsgMessage t (MsgContent text)-                        Nothing -> PrivMsgMessage t (MsgContent text)-        "NOTICE"   -> req2 params $ \ target text ->-            case matcht T.msgto target of-                Nothing ->-                    Left $ InvalidArg (Just 1) (Just "target") (Just target)-                Just t  ->-                    Right $ NoticeMessage t (MsgContent text)-    -- Server queries and commands-        "MOTD"     -> req0m1 params $ \ target ->-            Right $ MotdMessage (fmap Hostname target)-        "LUSERS"   -> Left $ OtherError "Not implemented yet"-        "VERSION"  -> Left $ OtherError "Not implemented yet"-        "STATS"    -> Left $ OtherError "Not implemented yet"-        "LINKS"    -> Left $ OtherError "Not implemented yet"-        "TIME"     -> Left $ OtherError "Not implemented yet"-        "CONNECT"  -> Left $ OtherError "Not implemented yet"-        "TRACE"    -> Left $ OtherError "Not implemented yet"-        "ADMIN"    -> Left $ OtherError "Not implemented yet"-        "INFO"     -> req0m1 params $ \ target ->-            case target of-                Nothing -> Right $ InfoMessage Nothing-                Just t  ->-                    Right $ case matcht T.nickname t of-                        Just n  ->-                            InfoMessage (Just $ NickTarget n)-                        Nothing ->-                            InfoMessage (Just $ ServerTarget $ Hostname t)-    -- Service query and commands-        "SERVLIST" -> Left $ OtherError "Not implemented yet"-        "SQUERY"   -> Left $ OtherError "Not implemented yet"-    -- User based queries-        "WHO"      -> Left $ OtherError "Not implemented yet"-        "WHOIS"    -> Left $ OtherError "Not implemented yet"-        "WHOWAS"   -> Left $ OtherError "Not implemented yet"-    -- Miscellaneous messages-        "KILL"     -> Left $ OtherError "Not implemented yet"-        "PING"     -> req1m2 params $ \ s1 s2 ->-            Right $ PingMessage (Hostname s1) (fmap Hostname s2)-        "PONG"     -> req1m2 params $ \ s1 s2 ->-            Right $ PongMessage (Hostname s1) (fmap Hostname s2)-        "ERROR"    -> Left $ OtherError "Not implemented yet"-    -- Optional features-        "AWAY"     -> req0m1 params $ \ text ->-            Right $ AwayMessage (fmap MsgContent text)-        "REHASH"   -> Left $ OtherError "Not implemented yet"-        "DIE"      -> Left $ OtherError "Not implemented yet"-        "RESTART"  -> Left $ OtherError "Not implemented yet"-        "SUMMON"   -> Left $ OtherError "Not implemented yet"-        "USERS"    -> Left $ OtherError "Not implemented yet"-        "WALLOPS"  -> Left $ OtherError "Not implemented yet"-        "USERHOST" -> Left $ OtherError "Not implemented yet"-        "ISON"     -> Left $ OtherError "Not implemented yet"-        _          -> Left $ OtherError "Unrecognized command"---- | Read a generic message structure into specific message details. Return--- 'Left' an error description if analysis fails. If the message is detected--- to be a reply, return a generic reply structure without analyzing.-analyzeMessage-    :: GenericMessage-    -> Either Text (Either GenericReply SpecificMessage)-analyzeMessage msg =-    if messageIsReply msg-        then fmap Left $ messageToReply msg-        else case gmCommand msg of-            NamedCmd c ->-                fmap (Right . SpecificMessage (gmPrefix msg)) $-                analyzeMessage'-                    (gmPrefix msg)-                    (unpack $ unCmdName c)-                    (gmParams msg)-            _               ->-                Left "Implementation error"--analyzeReply' :: Int -> Target -> [Parameter] -> Either Text Reply-analyzeReply' c _ params =-    case c of-        353 ->-            case params of-                [priv, chan, nicks] ->-                    maybe (Left "Invalid parameters") Right $ do-                        chan' <- matcht T.channel chan-                        priv' <- matcht T.chanpriv priv-                        pnicks <- matcht T.prefnicks nicks-                        return $ NamesReply priv' chan' pnicks-                (_:_:_:_:_) -> Left "Too many parameters"-                _ -> Left "Too few parameters"-        _   -> Left "Not implemented yet"---- | Read a generic reply structure into specific reply details. Return--- 'Left' an error description if analysis fails.-analyzeReply :: GenericReply -> Either Text SpecificReply-analyzeReply gr =-    fmap (SpecificReply (grSender gr) (grTarget gr)) $-    analyzeReply' (unCmdNumber $ grCode gr) (grTarget gr) (grParams gr)---- | Read a generic reply structure into specific message or reply details.--- Return 'Left' an error description if analysis fails.------ This is essentially a combination or 'analyzeMessage' and 'analyzeReply'.-analyze :: GenericMessage-        -> Either Text (Either SpecificReply SpecificMessage)-analyze gm =-    case analyzeMessage gm of-        Left e            -> Left e-        Right (Left rpl)  -> fmap Left $ analyzeReply rpl-        Right (Right msg) -> Right $ Right msg
− src/Network/IRC/Fun/Messages/Internal/Serialize.hs 
@@ -1,308 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--{-# LANGUAGE OverloadedStrings #-}--module Network.IRC.Fun.Messages.Internal.Serialize-    ( -- * Building-      buildMessage-    , buildReply-    , messageFromReply-      -- * Serializing-    , serializeMessage-    , serializeReply-    )-where--import Data.Bits (bit, zeroBits, (.|.))-import Data.Maybe (maybeToList)-import Data.Monoid ((<>))-import Data.Text (Text)-import Network.IRC.Fun.Messages.Mask (serializeMask)-import Network.IRC.Fun.Messages.Internal.Util-import Network.IRC.Fun.Types--import qualified Data.Text as T------------------------------------------------------------------------------------ Building----------------------------------------------------------------------------------showAddr :: Address -> Text-showAddr (IPv4 t) = t-showAddr (IPv6 t) = t--showHost :: Host -> Text-showHost (HostByName hn)   = unHostname hn-showHost (HostByAddr addr) = showAddr addr-showHost (HostCloak t)     = t--showTargetMask :: TargetMask -> Text-showTargetMask (HostMask m)   = '#' `T.cons` serializeMask m-showTargetMask (ServerMask m) = '$' `T.cons` serializeMask m--showTarget :: MessageTarget -> Text-showTarget (ChannelTarget chan) = unChannel chan-showTarget-    (UserTarget-        Nothing-        (Just (UserAddress (Username user) mhost))-        (Just server)-    ) =-    let u = case mhost of-                Nothing   -> user-                Just host -> user <> "%" <> showHost host-    in  u <> "@" <> unHostname server-showTarget-    (UserTarget-        Nothing-        (Just (UserAddress (Username user) (Just host)))-        Nothing-    ) =-    user <> "%" <> showHost host-showTarget-    (UserTarget-        (Just (Nickname nick))-        Nothing-        Nothing-    ) =-    nick-showTarget-    (UserTarget-        (Just (Nickname nick))-        (Just (UserAddress (Username user) (Just host)))-        Nothing-    ) =-    nick <> "!" <> user <> "@" <> showHost host-showTarget (MaskTarget mt) = showTargetMask mt-showTarget _ = "invalid_target"---- Fill command name and parameters from specific message-buildMessage' :: Message -> (Text, [Parameter])-buildMessage' msg =-    case msg of-        PassMessage pass ->-            ("PASS", [unPassword pass])-        NickMessage nn ->-            ("NICK", [unNickname nn])-        UserMessage un i w rn ->-            ( "USER"-            , [ unUsername un-              , showt $ modebit 3 i .|. modebit 2 w-              , "*"-              , unRealName rn-              ]-            )-            where-            modebit n b = if b then bit n else zeroBits :: Int-        OperMessage _un _p ->-            ("????", error "Not implemented")-        UserModeMessage _n _remove _add ->-            ("????", error "Not implemented")-        ServiceMessage _n _m _s ->-            ("????", error "Not implemented")-        QuitMessage reason ->-            ("QUIT", perhaps $ fmap unComment reason)-        SQuitMessage _s _t ->-            ("????", error "Not implemented")-        JoinMessage Nothing ->-            ("JOIN", ["0"])-        JoinMessage (Just (chans, keys)) ->-            ( "JOIN"-            , T.intercalate "," (map unChannel chans) :-              if null keys-                then []-                else [T.intercalate "," $ map unChannelKey keys]-            )-        PartMessage chans reason ->-            ( "PART"-            , T.intercalate "," (map unChannel chans) ?: fmap unComment reason-            )-        ChannelModeMessage _remove _add ->-            ("????", error "Not implemented")-        TopicMessage chan topic ->-            ("TOPIC", unChannel chan ?: fmap unChannelTopic topic)-        NamesMessage chans serv ->-            ( "NAMES"-            , T.intercalate "," (map unChannel chans) ?: fmap unHostname serv-            )-        ListMessage _chans _serv ->-            ("????", error "Not implemented")-        InviteMessage _nn _chan ->-            ("????", error "Not implemented")-        KickMessage _chans _users _s ->-            ("????", error "Not implemented")-        PrivMsgMessage tgt (MsgContent mc) ->-            ("PRIVMSG", [showTarget tgt, mc])-        PrivActionMessage tgt (MsgContent mc) ->-            ("PRIVMSG", [showTarget tgt, "\1ACTION " <> mc <> "\1"])-        NoticeMessage tgt (MsgContent mc) ->-            ("NOTICE", [showTarget tgt, mc])-        MotdMessage _serv ->-            ("????", error "Not implemented")-        LusersMessage _serv ->-            ("????", error "Not implemented")-        VersionMessage _serv ->-            ("????", error "Not implemented")-        StatsMessage _x ->-            ("????", error "Not implemented")-        LinksMessage _x ->-            ("????", error "Not implemented")-        TimeMessage _serv ->-            ("????", error "Not implemented")-        ConnectMessage _serv _portn _sm ->-            ("????", error "Not implemented")-        TraceMessage _t ->-            ("????", error "Not implemented")-        AdminMessage _t ->-            ("????", error "Not implemented")-        InfoMessage _t ->-            ("????", error "Not implemented")-        ServlistMessage _ ->-            ("????", error "Not implemented")-        SQueryMessage _ _ ->-            ("????", error "Not implemented")-        WhoMessage _ ->-            ("????", error "Not implemented")-        WhoisMessage _ _ ->-            ("????", error "Not implemented")-        WhowasMessage _ _ ->-            ("????", error "Not implemented")-        KillMessage _ _ ->-            ("????", error "Not implemented")-        PingMessage s1 s2 ->-            ("PING", unHostname s1 ?: fmap unHostname s2)-        PongMessage s1 s2 ->-            ("PONG", unHostname s1 ?: fmap unHostname s2)-        ErrorMessage _ ->-            ("????", error "Not implemented")-        AwayMessage _ ->-            ("????", error "Not implemented")-        RehashMessage ->-            ("????", error "Not implemented")-        DieMessage ->-            ("????", error "Not implemented")-        RestartMessage ->-            ("????", error "Not implemented")-        SummonMessage _ _ ->-            ("????", error "Not implemented")-        UsersMessage _ ->-            ("????", error "Not implemented")-        WallopsMessage _ ->-            ("????", error "Not implemented")-        UserhostMessage _ ->-            ("????", error "Not implemented")-        IsonMessage _ ->-            ("????", error "Not implemented")-    where-    perhaps = maybeToList-    x ?: my = x : perhaps my---- | Fill a generic message record using a specific message's details.-buildMessage :: SpecificMessage -> GenericMessage-buildMessage (SpecificMessage pref msg) =-    let (cmd, ps) = buildMessage' msg-    in  GenericMessage pref (NamedCmd $ CmdName cmd) ps--channelPrivacyChar :: ChannelPrivacy -> Char-channelPrivacyChar Secret  = '@'-channelPrivacyChar Private = '*'-channelPrivacyChar Public  = '='--privilegeChar :: Privilege -> Maybe Char-privilegeChar Regular  = Nothing-privilegeChar Voice    = Just '+'-privilegeChar Operator = Just '@'---- Fill reply code, target and parameters from specific reply-buildReply' :: Reply -> (Int, [Parameter])-buildReply' reply =-    case reply of-        NamesReply priv chan pns ->-            ( 353-            , [ T.singleton $ channelPrivacyChar priv-              , unChannel chan-              , T.unwords $-                map-                    (\ (p, (Nickname n)) ->-                        maybe n (`T.cons` n) $ privilegeChar p-                    )-                    pns-              ]-            )-        _ -> error "Not implemented"---- | Fill a generic reply record using a specific reply's details.-buildReply :: SpecificReply -> GenericReply-buildReply (SpecificReply sender tgt reply) =-    let (code, ps) = buildReply' reply-    in  GenericReply sender (CmdNumber code) tgt ps---- | Convert a reply, which is a message with a numeric command name, into a--- generic message value.-messageFromReply :: GenericReply -> GenericMessage-messageFromReply reply = GenericMessage-    { gmPrefix  = Just $ PrefixServer $ grSender reply-    , gmCommand = NumericCmd $ grCode reply-    , gmParams  = target' reply : grParams reply-    }-    where-    target' (GenericReply { grTarget = NickTarget n })   = unNickname n-    target' (GenericReply { grTarget = ServerTarget s }) = unHostname s------------------------------------------------------------------------------------ Serializing----------------------------------------------------------------------------------serializePrefix :: Prefix -> Text-serializePrefix (PrefixServer sn)    = unHostname sn-serializePrefix (PrefixNick n mu mh) =-    unNickname n                                 <>-    maybe "" ('!' `T.cons`) (fmap unUsername mu) <>-    maybe "" (('@' `T.cons`) . showHost) mh--serializeCommand :: Command -> Text-serializeCommand (NamedCmd t)   = unCmdName t-serializeCommand (NumericCmd n) = showt $ unCmdNumber n--serializeParams :: [Parameter] -> Text-serializeParams = f . map (\ p -> if T.null p then "(?)" else p)-    where-    f [] = ""-    f l  =-        let (ps, p) = (init l, last l)-        in  T.concat (map (' ' `T.cons`) ps) <> " " <>-            if T.head p == ':' || T.any (== ' ') p-                then ':' `T.cons` p-                else p---- | Write a message into an IRC protocol message formatted string.-serializeMessage :: GenericMessage -> Text-serializeMessage msg = T.concat-    [ maybe-        T.empty-        (\ p -> ':' `T.cons` serializePrefix p `T.snoc` ' ')-        (gmPrefix msg)-    , serializeCommand $ gmCommand msg-    , serializeParams $ gmParams msg-    , "\r\n"-    ]---- | Write a reply into an IRC protocol message formatted string.------ This is essentially a combination of 'messageFromReply' and--- 'serializeMessage'.-serializeReply :: GenericReply -> Text-serializeReply = serializeMessage . messageFromReply
− src/Network/IRC/Fun/Messages/Internal/Tokens/Message.hs 
@@ -1,89 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Tokens.Message-    ( message-    )-where--import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-import Network.IRC.Fun.Messages.Internal.Tokens.Other-import Network.IRC.Fun.Messages.Internal.Tokens.Target-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative------------TOTO-{--- go over errata, make sure everything here is correct-- some regexes, such as matchone and target, seem not to be used in the rules-  here. they're probably intended for later use, e.g. when matching a string-  against a mask. in such case the API should probably import them--}--message :: Regex GenericMessage-message =-    GenericMessage                        <$>-    optional (sym ':' *> prefix <* space) <*>-    command                               <*>-    (fromMaybe [] <$> optional params)    <*-    crlf--prefix :: Regex Prefix-prefix =-    PrefixServer <$> servername-    <|>-    nick         <$>-    nickname     <*>-    optional-        ( (,)                        <$>-          optional (sym '!' *> user) <*-          sym '@'                    <*>-          host-        )-    where-    nick n Nothing       = PrefixNick n Nothing Nothing-    nick n (Just (u, h)) = PrefixNick n u       (Just h)--command :: Regex Command-command =-    let f a b c = NumericCmd $ CmdNumber $ read [a, b, c]-    in  NamedCmd . CmdName . pack <$> some letter-        <|>-        f                         <$> digit <*> digit <*> digit--params :: Regex [Text]-params =-    let f m (Just t) = m ++ [t]-        f m Nothing  = m-    in  f                      <$>-        many (space *> middle) <*>-        optional (space *> sym ':' *> trailing)--middle :: Regex Text-middle = pack <$> ((:) <$> paramchar <*> many (sym ':' <|> paramchar))--trailing :: Regex Text-trailing = pack <$> many (sym ':' <|> sym ' ' <|> paramchar)--paramchar :: Regex Char-paramchar = psym (`notElem` "\0\r\n :")--space :: Regex Char-space = sym ' '--crlf :: Regex String-crlf = string "\r\n"
− src/Network/IRC/Fun/Messages/Internal/Tokens/Other.hs 
@@ -1,62 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Tokens.Other-    ( user-    , key-    , letter-    , digit-    , hexdigit-    , hexdigit'-    , special-    )-where--import Data.Char (isAscii, isDigit)-import Data.Text (pack)-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--user :: Regex Username-user = Username . pack <$> some (psym (`notElem` "\0\r\n @"))--key :: Regex ChannelKey-key =-    ChannelKey . pack <$>-    some (psym $ \ c -> isAscii c && c `notElem` "\0\r\n\f\t\v ")--letter :: Regex Char-letter = psym $ \ c -> 'A' <= c && c <= 'Z'  ||  'a' <= c && c <= 'z'--digit :: Regex Char-digit = psym isDigit--hexdigit :: Regex Char-hexdigit = digit <|> upperhex-    where-    upperhex = psym $ \ c -> 'A' <= c && c <= 'F'---- RFC 2812 assumes IPv6 addresses with uppercase hex digits. In practice, the--- recommendation it to use lowercase, and that's what really happens. So this--- regex accepts both lowercase and uppercase.-hexdigit' :: Regex Char-hexdigit' = digit <|> upperhex <|> lowerhex-    where-    upperhex = psym $ \ c -> 'A' <= c && c <= 'F'-    lowerhex = psym $ \ c -> 'a' <= c && c <= 'f'--special :: Regex Char-special = psym (`elem` "[]\\`_^{|}")
− src/Network/IRC/Fun/Messages/Internal/Tokens/Reply.hs 
@@ -1,43 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Tokens.Reply-    ( chanpriv-    , prefnicks-    )-where--import Data.Maybe (fromMaybe)-import Network.IRC.Fun.Messages.Internal.Tokens.Target-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative------------------------------------------------------------------------------------ 353 RPL_NAMREPLY----------------------------------------------------------------------------------chanpriv :: Regex ChannelPrivacy-chanpriv = Secret <$ sym '@' <|> Private <$ sym '*' <|> Public <$ sym '='--prefnicks :: Regex [(Privilege, Nickname)]-prefnicks = (:) <$> prefnick <*> many (sym ' ' *> prefnick)--prefnick :: Regex (Privilege, Nickname)-prefnick = (,) <$> privilege <*> nickname--privilege :: Regex Privilege-privilege =-    fromMaybe Regular <$> optional (Voice <$ sym '+' <|> Operator <$ sym '@')
− src/Network/IRC/Fun/Messages/Internal/Tokens/Target.hs 
@@ -1,139 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Tokens.Target-    ( target-    , msgtarget-    , msgto-    , channel-    , servername-    , host-    , nickname-    )-where--import Data.Char (isAsciiUpper)-import Data.Text (Text, pack)-import Network.IRC.Fun.Messages.Internal.Tokens.Other-import Network.IRC.Fun.Messages.Internal.Tokens.Wildcards-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--target :: Regex Target-target = NickTarget <$> nickname <|> ServerTarget <$> servername--msgtarget :: Regex [MessageTarget]-msgtarget = (:) <$> msgto <*> many (sym ',' *> msgto)--msgto :: Regex MessageTarget-msgto = ChannelTarget <$> channel-    <|> uhs <$> user-            <*> optional (sym '%' *> host) <* sym '@'-            <*> servername-    <|> uh <$> user <* sym '%'-           <*> host-    <|> MaskTarget <$> targetmask-    <|> nn <$> nickname-    <|> nuh <$> nickname <* sym '!'-            <*> user <* sym '@'-            <*> host-    where-    uhs u h s = UserTarget Nothing  (Just (UserAddress u h))        (Just s)-    uh  u h   = UserTarget Nothing  (Just (UserAddress u (Just h))) Nothing-    nn  n     = UserTarget (Just n) Nothing                      Nothing-    nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing--channel :: Regex Channel-channel =-    Channel . pack . snd <$>-    withMatched-    ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <*-      chanstring                                                 <*-      optional (sym ':' <* chanstring)-    )--servername :: Regex Hostname-servername = hostname--host :: Regex Host-host =-    HostByAddr  <$> hostaddr-    <|>-    HostByName  <$> hostname-    <|>-    HostCloak   <$> hostcloak--hostname :: Regex Hostname-hostname =-    Hostname . pack . snd <$>-    withMatched (shortname <* many (sym '.' <* shortname))--shortname :: Regex String-shortname =-    snd <$> withMatched-        ( (letter <|> digit) <*-          optional (many (letter <|> digit <|> sym '-') <* (letter <|> digit))-        )--hostaddr :: Regex Address-hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr--ip4addr :: Regex Text-ip4addr = pack . snd <$> withMatched (s <* p <* s <* p <* s <* p <* s)-    where-    d = digit-    s = snd <$> withMatched (d  <|>  d <* d  <|>  d <* d <* d)-    p = sym '.'--ip6addr :: Regex Text-ip6addr = pack . snd <$> withMatched (full <|> short <|> v4)-    where-    h = some hexdigit'-    c = sym ':'-    s = h <* many (c <* h)-    full = h <* c <* h <* c <*-           h <* c <* h <* c <*-           h <* c <* h <* c <*-           h <* c <* h-    short = optional s *> string "::" <* optional s-    v4 = string "0:0:0:0:0:" <*-         (string "0" <|> string "FFFF") <*-         sym ':' <*-         ip4addr--hostcloak :: Regex Text-hostcloak =-    pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/"))--nickname :: Regex Nickname-nickname =-    Nickname . pack <$>-    ( (:)                                             <$>-      (letter <|> special)                            <*>-      many (letter <|> digit <|> special <|> sym '-')-    )--targetmask :: Regex TargetMask-targetmask = ServerMask <$> (sym '$' *> mask)-         <|> HostMask   <$> (sym '#' *> mask)--chanstring :: Regex String-chanstring = many $ psym (`notElem` "\0\a\r\n ,:")--channelid :: Regex String-channelid = snd <$> withMatched (c *> c *> c *> c *> c)-    where-    c = psym isAsciiUpper <|> digit
− src/Network/IRC/Fun/Messages/Internal/Tokens/Wildcards.hs 
@@ -1,46 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Tokens.Wildcards-    ( mask-    , matchone-    , matchmany-    )-where--import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--mask :: Regex Mask-mask = Mask <$> many (nowild  <|>  noesc *> wildone  <|>  noesc *> wildmany)--wildone :: Regex MaskPart-wildone = MaskWildOne <$ sym '?'--wildmany :: Regex MaskPart-wildmany = MaskWildMany <$ sym '*'--nowild :: Regex MaskPart-nowild = MaskChar <$> psym (`notElem` "\0*?")--noesc :: Regex Char-noesc = psym (`notElem` "\0\\")--matchone :: Regex Char-matchone = psym (/= '\0')--matchmany :: Regex String-matchmany = many matchone
− src/Network/IRC/Fun/Messages/Internal/Types.hs 
@@ -1,372 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Types-    ( -- * Type Aliases And Newtypes-      Regex-      -- * Reply-    , CommandResponseCode (..)-    , ErrorReplyCode (..)-    , ReservedReplyCode (..)-    , ReservedErrorCode (..)-    )-where--import Text.Regex.Applicative (RE)---- | TODO-type Regex = RE Char------------------------------------------------------------------------------------ Reply------------------------------------------------------------------------------------ | TODO-data CommandResponseCode-    -- | TODO-    = ReplyWelcome-    -- | TODO-    | ReplyYourHost-    -- | TODO-    | ReplyCreated-    -- | TODO-    | ReplyMyInfo-    -- | TODO-    | ReplyBounce-    -- | TODO-    | ReplyUserHost-    -- | TODO-    | ReplyIsOn-    -- | TODO-    | ReplyAway-    -- | TODO-    | ReplyUnAway-    -- | TODO-    | ReplyNoAway-    -- | TODO-    | ReplyWhoIsUser-    -- | TODO-    | ReplyWhoIsServer-    -- | TODO-    | ReplyWhoIsOperator-    -- | TODO-    | ReplyWhoIsIdle-    -- | TODO-    | ReplyEndOfWhoIs-    -- | TODO-    | ReplyWhoIsChannels-    -- | TODO-    | ReplyWhoWasUser-    -- | TODO-    | ReplyEndOfWhoWas-    -- | TODO-    | ReplyListStart-    -- | TODO-    | ReplyList-    -- | TODO-    | ReplyListEnd-    -- | TODO-    | ReplyUniqueOpIs-    -- | TODO-    | ReplyChannelModeIs-    -- | TODO-    | ReplyNoTopic-    -- | TODO-    | ReplyTopic-    -- | TODO-    | ReplyInviting-    -- | TODO-    | ReplySummoning-    -- | TODO-    | ReplyInviteList-    -- | TODO-    | ReplyEndOfInviteList-    -- | TODO-    | ReplyExceptList-    -- | TODO-    | ReplyEndOfExceptList-    -- | TODO-    | ReplyVersion-    -- | TODO-    | ReplyWhoReply-    -- | TODO-    | ReplyEndOfWho-    -- | TODO-    | ReplyNameReply-    -- | TODO-    | ReplyEndOfNames-    -- | TODO-    | ReplyLinks-    -- | TODO-    | ReplyEndOfLinks-    -- | TODO-    | ReplyBanList-    -- | TODO-    | ReplyEndOfBanList-    -- | TODO-    | ReplyInfo-    -- | TODO-    | ReplyEndOfInfo-    -- | TODO-    | ReplyMotdStart-    -- | TODO-    | ReplyMessageOfTheDay-    -- | TODO-    | ReplyEndOfMessageOfTheDay-    -- | TODO-    | ReplyYoureOper-    -- | TODO-    | ReplyRehashing-    -- | TODO-    | ReplyYoureService-    -- | TODO-    | ReplyTime-    -- | TODO-    | ReplyUsersStart-    -- | TODO-    | ReplyUsers-    -- | TODO-    | ReplyEndOfUsers-    -- | TODO-    | ReplyNoUsers-    -- | TODO-    | ReplyTraceLink-    -- | TODO-    | ReplyTraceConnecting-    -- | TODO-    | ReplyTraceHandshake-    -- | TODO-    | ReplyTraceUnknown-    -- | TODO-    | ReplyTraceOperator-    -- | TODO-    | ReplyTraceUser-    -- | TODO-    | ReplyTraceServer-    -- | TODO-    | ReplyTraceService-    -- | TODO-    | ReplyTraceNewType-    -- | TODO-    | ReplyTraceClass-    -- | TODO-    | ReplyTraceReconnect-    -- | TODO-    | ReplyTraceLog-    -- | TODO-    | ReplyTraceEnd-    -- | TODO-    | ReplyStatsLinkInfo-    -- | TODO-    | ReplyStatsCommands-    -- | TODO-    | ReplyEndOfStats-    -- | TODO-    | ReplyStatsUptime-    -- | TODO-    | ReplyStatsOLine-    -- | TODO-    | ReplyUModeIs-    -- | TODO-    | ReplyServList-    -- | TODO-    | ReplyServListEnd-    -- | TODO-    | ReplyLuserClient-    -- | TODO-    | ReplyLuserOp-    -- | TODO-    | ReplyLuserUnknown-    -- | TODO-    | ReplyLuserChannels-    -- | TODO-    | ReplyLuserMe-    -- | TODO-    | ReplyAdminMe-    -- | TODO-    | ReplyAdminLocation1-    -- | TODO-    | ReplyAdminLocation2-    -- | TODO-    | ReplyAdminEmail-    -- | TODO-    | ReplyTryAgain-    -- | TODO-    | ReplyFreenodeISupport-    deriving (Eq, Show)--data ErrorReplyCode-    -- | TODO-    = ErrorNoSuchNick-    -- | TODO-    | ErrorNoSuchServer-    -- | TODO-    | ErrorNoSuchChannel-    -- | TODO-    | ErrorCannotSendToChannel-    -- | TODO-    | ErrorTooManyChannels-    -- | TODO-    | ErrorWasNoSuchNick-    -- | TODO-    | ErrorTooManyTargets-    -- | TODO-    | ErrorNoSuchService-    -- | TODO-    | ErrorNoOrigin-    -- | TODO-    | ErrorNoRecipient-    -- | TODO-    | ErrorNoTextToSend-    -- | TODO-    | ErrorNoTopLevel-    -- | TODO-    | ErrorWildTopLevel-    -- | TODO-    | ErrorBadMask-    -- | TODO-    | ErrorUnknownCommand-    -- | TODO-    | ErrorNoMessageOfTheDay-    -- | TODO-    | ErrorNoAdminInfo-    -- | TODO-    | ErrorFileError-    -- | TODO-    | ErrorNoNicknameGiven-    -- | TODO-    | ErrorErroneousNickname-    -- | TODO-    | ErrorNicknameInUse-    -- | TODO-    | ErrorNickCollision-    -- | TODO-    | ErrorUnavailableResource-    -- | TODO-    | ErrorUserNotInChannel-    -- | TODO-    | ErrorNotOnChannel-    -- | TODO-    | ErrorUserOnChannel-    -- | TODO-    | ErrorNoLogin-    -- | TODO-    | ErrorSummonDisabled-    -- | TODO-    | ErrorUsersDisabled-    -- | TODO-    | ErrorNotRegistered-    -- | TODO-    | ErrorNeedMoreParams-    -- | TODO-    | ErrorAlreadyRegistered-    -- | TODO-    | ErrorNoPermissionForHost-    -- | TODO-    | ErrorPasswordMismatch-    -- | TODO-    | ErrorYoureBannedCreep-    -- | TODO-    | ErrorYouWillBeBanned-    -- | TODO-    | ErrorKeySet-    -- | TODO-    | ErrorChannelIsFull-    -- | TODO-    | ErrorUnknownMode-    -- | TODO-    | ErrorInviteOnlyChannel-    -- | TODO-    | ErrorBannedFromChannel-    -- | TODO-    | ErrorBadChannelKey-    -- | TODO-    | ErrorBadChannelMask-    -- | TODO-    | ErrorNoChannelModes-    -- | TODO-    | ErrorBanListFull-    -- | TODO-    | ErrorNoPrivileges-    -- | TODO-    | ErrorChannelOpPrivilegesNeeded-    -- | TODO-    | ErrorCantKillServer-    -- | TODO-    | ErrorRestricted-    -- | TODO-    | ErrorUniqueOpPrivilegesNeeded-    -- | TODO-    | ErrorNoOperHost-    -- | TODO-    | ErrorUModeUnknownFlag-    -- | TODO-    | ErrorUsersDontMatch-    deriving (Eq, Show)--data ReservedReplyCode-    -- | TODO-    = ReservedReplyServiceInfo-    -- | TODO-    | ReservedReplyEndOfServices-    -- | TODO-    | ReservedReplyService-    -- | TODO-    | ReservedReplyNone-    -- | TODO-    | ReservedReplyWhoIsChannelOp-    -- | TODO-    | ReservedReplyKillDone-    -- | TODO-    | ReservedReplyClosing-    -- | TODO-    | ReservedReplyCloseEnd-    -- | TODO-    | ReservedReplyInfoStart-    -- | TODO-    | ReservedReplyMyPortIs-    -- | TODO-    | ReservedReplyStatsCLine-    -- | TODO-    | ReservedReplyStatsNLine-    -- | TODO-    | ReservedReplyStatsILine-    -- | TODO-    | ReservedReplyStatsKLine-    -- | TODO-    | ReservedReplyStatsQLine-    -- | TODO-    | ReservedReplyStatsYLine-    -- | TODO-    | ReservedReplyStatsVLine-    -- | TODO-    | ReservedReplyStatsLLine-    -- | TODO-    | ReservedReplyStatsHLine-    -- | TODO-    | ReservedReplyStatsSLine-    -- | TODO-    | ReservedReplyStatsPing-    -- | TODO-    | ReservedReplyStatsBLine-    -- | TODO-    | ReservedReplyStatsDLine-    deriving (Eq, Show)---- | TODO-data ReservedErrorCode-    -- | TODO-    = ReservedErrorNoServiceHost-    deriving (Eq, Show)
− src/Network/IRC/Fun/Messages/Internal/Util.hs 
@@ -1,148 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}--module Network.IRC.Fun.Messages.Internal.Util-    ( showt-    , listOf-    , req0-    , req1-    , req2-    , req3-    , req4-    , req5-    , req6-    , req0m1-    , req1m2-    , req2m3-    , req3m4-    , min1-    )-where--import Data.Text (Text, pack)-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--showt :: Int -> Text-showt = pack . show--listOf :: Regex a -> Regex [a]-listOf re = (:) <$> re <*> many (sym ',' *> re)--req0 :: [Parameter]-     -> Either AnalysisError Message-     -> Either AnalysisError Message-req0 [] f = f-req0 l  _ = Left $ WrongNumArgs (length l) (Just $ Exactly 0)--req1 :: [Parameter]-     -> (Parameter -> Either AnalysisError Message)-     -> Either AnalysisError Message-req1 [p1] f = f p1-req1 l    _ = Left $ WrongNumArgs (length l) (Just $ Exactly 1)--req2 :: [Parameter]-     -> (Parameter -> Parameter -> Either AnalysisError Message)-     -> Either AnalysisError Message-req2 [p1, p2] f = f p1 p2-req2 l        _ = Left $ WrongNumArgs (length l) (Just $ Exactly 2)--req3 :: [Parameter]-     -> (Parameter -> Parameter -> Parameter -> Either AnalysisError Message)-     -> Either AnalysisError Message-req3 [p1, p2, p3] f = f p1 p2 p3-req3 l            _ = Left $ WrongNumArgs (length l) (Just $ Exactly 3)--req4 :: [Parameter]-     -> (  Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Either AnalysisError Message-        )-     -> Either AnalysisError Message-req4 [p1, p2, p3, p4] f = f p1 p2 p3 p4-req4 l            _     = Left $ WrongNumArgs (length l) (Just $ Exactly 4)--req5 :: [Parameter]-     -> (  Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Either AnalysisError Message-        )-     -> Either AnalysisError Message-req5 [p1, p2, p3, p4, p5] f = f p1 p2 p3 p4 p5-req5 l                    _ = Left $ WrongNumArgs (length l) (Just $ Exactly 5)--req6 :: [Parameter]-     -> (  Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Parameter-        -> Either AnalysisError Message-        )-     -> Either AnalysisError Message-req6 [p1, p2, p3, p4, p5,p6] f = f p1 p2 p3 p4 p5 p6-req6 l                       _ = Left $-                                 WrongNumArgs (length l) (Just $ Exactly 6)--req0m1 :: [Parameter]-       -> (Maybe Parameter -> Either AnalysisError Message)-       -> Either AnalysisError Message-req0m1 [] f   = f Nothing-req0m1 [p1] f = f $ Just p1-req0m1 l    _ = Left $ WrongNumArgs (length l) (Just $ Between 0 1)--req1m2 :: [Parameter]-       -> (Parameter -> Maybe Parameter -> Either AnalysisError Message)-       -> Either AnalysisError Message-req1m2 [p1]     f = f p1 Nothing-req1m2 [p1, p2] f = f p1 (Just p2)-req1m2 l        _ = Left $ WrongNumArgs (length l) (Just $ Between 1 2)--req2m3 :: [Parameter]-       -> (  Parameter-          -> Parameter-          -> Maybe Parameter-          -> Either AnalysisError Message-          )-       -> Either AnalysisError Message-req2m3 [p1, p2]     f = f p1 p2 Nothing-req2m3 [p1, p2, p3] f = f p1 p2 (Just p3)-req2m3 l            _ = Left $ WrongNumArgs (length l) (Just $ Between 2 3)--req3m4 :: [Parameter]-       -> (  Parameter-          -> Parameter-          -> Parameter-          -> Maybe Parameter-          -> Either AnalysisError Message-          )-       -> Either AnalysisError Message-req3m4 [p1, p2, p3]     f = f p1 p2 p3 Nothing-req3m4 [p1, p2, p3, p4] f = f p1 p2 p3 (Just p4)-req3m4 l                _ = Left $-                            WrongNumArgs (length l) (Just $ Between 3 4)--min1 :: [Parameter]-     -> (Parameter -> [Parameter] -> Either AnalysisError Message)-     -> Either AnalysisError Message-min1 []      _ = Left $ WrongNumArgs 0 (Just $ AtLeast 1)-min1 (p1:ps) f = f p1 ps
− src/Network/IRC/Fun/Messages/Mask.hs 
@@ -1,72 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | This module deals with wildcard based masks, used for selecting users and--- servers.-module Network.IRC.Fun.Messages.Mask-    ( parseMask-    , serializeMask-    , matches-    )-where--import Data.Maybe (isJust)-import Data.Text (Text, cons, unpack)-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--import qualified Network.IRC.Fun.Messages.Internal.Tokens.Wildcards as T--{--TODO-"The mask MUST-    have at least 1 (one) "." in it and no wildcards following the last-        ".".  This requirement exists to prevent people sending messages to-            "#*" or "$*", which would broadcast to all users."--handle this somehow! e.g. a function that tests a mask for validity--}---- | Parse a mask string (e.g. @"*!*@*"@) into a 'Mask' value. Returns--- 'Nothing' if the string isn't a valid mask.-parseMask :: Text -> Maybe Mask-parseMask = match T.mask . unpack----TODO what about escaping and invalid chars? are they handled correctly?---prepend mapped part to given string-serializeMaskPart :: MaskPart -> Text -> Text-serializeMaskPart (MaskChar '?') t = '\\' `cons` '?' `cons` t-serializeMaskPart (MaskChar '*') t = '\\' `cons` '*' `cons` t-serializeMaskPart (MaskChar c) t   = c `cons` t-serializeMaskPart (MaskWildOne) t  = '?' `cons` t-serializeMaskPart (MaskWildMany) t = '*' `cons` t---- | Converts a 'Mask' value into its string representation in IRC messages.-serializeMask :: Mask -> Text-serializeMask (Mask parts) = foldr serializeMaskPart mempty parts---- TODO maybe fold MaskChars into strings? how much faster will it be?-maskToRegex :: Mask -> Regex String-maskToRegex (Mask parts) = snd <$> withMatched (foldr f (pure "") parts)-    where-    f (MaskChar c) regex = sym c *> regex-    f MaskWildOne regex  = T.matchone *> regex-    f MaskWildMany regex = T.matchmany *> regex--matches :: String -> Mask -> Bool-matches s m = isJust $ match (maskToRegex m) s--infix 2 `matches`
− src/Network/IRC/Fun/Messages/Modes.hs 
@@ -1,201 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | This module handles user modes and channel modes.-module Network.IRC.Fun.Messages.Modes-    ( -- * User Modes-      umodeToLetter-    , umodeFromLetter-    , parseUserMode-      -- * Channel Modes-    , cmodeToLetter-    , cmodeFromLetter-    , parseChannelModeParams-    )-where--import Data.Either (isRight)-import Data.Maybe (fromMaybe)-import Data.List (nub, partition)-import Data.Text (Text)-import Data.Tuple (swap)-import Network.IRC.Fun.Messages.Internal.Types-import Network.IRC.Fun.Types-import Text.Regex.Applicative--import qualified Data.Text as T--userModeMap :: [(UserMode, Char)]-userModeMap =-    [ (UModeInvisible,         'i')-    , (UModeCallerID,          'g')-    , (UModeSeeWallops,        'w')-    , (UModeDeaf,              'D')-    , (UModeNoForwarding,      'Q')-    , (UModeBlockUnidentified, 'R')-    , (UModeConnectedViaSSL,   'Z')-    , (UModeAway,              'a')-    , (UModeRestricted,        'r')-    , (UModeOperator,          'o')-    , (UModeLocalOperator,     'O')-    , (UModeSeeNotices,        's')-    ]--umodeToLetter :: UserMode -> Char-umodeToLetter (UModeOther c) = c-umodeToLetter um =-    fromMaybe-        (error "Implementation error: User mode not assigned a letter")-        (lookup um userModeMap)--umodeFromLetter :: Char -> UserMode-umodeFromLetter c = fromMaybe (UModeOther c) (lookup c $ map swap userModeMap)--isAsciiLetter :: Char -> Bool-isAsciiLetter c = 'a' <= c && c <= 'z'  ||  'A' <= c && c <= 'Z'---- 1 to remove, 2 to add-umode :: Regex ([UserMode], [UserMode])-umode = mix <$> many section-    where-    section = (,) <$> (True <$ sym '+' <|> False <$ sym '-')-                  <*> (nub <$> many (psym isAsciiLetter))-    mix l =-        let (add, remove) = partition fst l-            add' = nub $ concatMap snd add-            remove' = nub $ concatMap snd remove-        in  (map umodeFromLetter remove', map umodeFromLetter add')---- the one from the MODE irc message-parseUserMode :: Text -> Maybe ([UserMode], [UserMode])-parseUserMode = match umode . T.unpack----TODO add modes from https://freenode.net/using_the_network.shtml--- freenode it the main target anyway...--- also maybe add a system for server-specific non-standard flags-channelModeMap :: [(ChannelMode, Char, ChannelModeType)]-channelModeMap = --eIbq,k,flj,CFLMPQScgimnprstz -- o and v type B syntax-wise-    [ (CModeCreator,                      'O', ModeTypeMaybeSetting)-    , (CModeOperator,                     'o', ModeTypeSetting)-    , (CModeVoice,                        'v', ModeTypeSetting)-    , (CModeAnonymous,                    'a', ModeTypeFlag)-    , (CModeInviteOnly,                   'i', ModeTypeFlag)-    , (CModeModerated,                    'm', ModeTypeFlag)-    , (CModeNoMessagesFromOutside,        'n', ModeTypeFlag)-    , (CModeQuiet,                        'q', ModeTypeFlag)-    , (CModePrivate,                      'p', ModeTypeFlag)-    , (CModeSecret,                       's', ModeTypeFlag)-    , (CModeServerReop,                   'r', ModeTypeFlag)-    , (CModeTopicSettableByChannelOpOnly, 't', ModeTypeFlag)-    , (CModeKey Nothing,                  'k', ModeTypeFlag)-    , (CModeUserLimit Nothing,            'l', ModeTypeMaybeSetting)-    , (CModeBanMask Nothing,              'b', ModeTypeList)-    , (CModeExceptionMask Nothing,        'e', ModeTypeList)-    , (CModeInvitationMask Nothing,       'I', ModeTypeList)-    ]--freenodeOverride :: [(ChannelMode, Char, ChannelModeType)]-freenodeOverride =-    [ (CModeFreenodeQuiet Nothing,        'q', ModeTypeSetting)-    ]--lookupCLetter-    :: ChannelMode-    -> [(ChannelMode, Char, ChannelModeType)]-    -> Maybe Char-lookupCLetter _ []               = Nothing-lookupCLetter q ((m, l, _t):rest) =-    if q == m-        then Just l-        else lookupCLetter q rest----TODO make the bool=True mean we use the freenode override-cmodeToLetter :: ChannelMode -> Bool -> Char-cmodeToLetter (CModeOther c _) _ = c-cmodeToLetter cm freenode =-    let m =-            if freenode-                then freenodeOverride ++ channelModeMap-                else channelModeMap-    in  fromMaybe-            (error "Implementation error: Channel mode not assigned a letter")-            (lookupCLetter cm m)--lookupCMode-    :: Char-    -> [(ChannelMode, Char, ChannelModeType)]-    -> Maybe ChannelMode-lookupCMode _ []               = Nothing-lookupCMode c ((m, l, _):rest) = if c == l then Just m else lookupCMode c rest----TODO make the bool=True mean we use the freenode override-cmodeFromLetter :: Char -> Bool -> ChannelMode-cmodeFromLetter c freenode =-    let m =-            if freenode-                then freenodeOverride ++ channelModeMap-                else channelModeMap-    in  fromMaybe (CModeOther c []) (lookupCMode c m)---- the one from the MODE irc message--- http://www.irc.org/tech_docs/005.html-{--some rules:--A--B--C--suppose we are setting 'l', then:--l       : does nothing-+l      : does nothing--l      : unsets the mode-l 1000  : sets mode, same as +l 1000-+l 1000 : sets mode--l 1000 : unsets mode, the 1000 is ignored--D---}-parseChannelModeParams :: [Text]-                       -> Bool -- whether to use freenode override-                       -> Maybe-                       ( [ChannelMode] -- list additions and boolean sets-                       , [ChannelMode] -- list removals and boolean unsets-                       , [ChannelMode] -- setting changes (sets and unsets)-                       )-parseChannelModeParams l _freenode =-    let _l' = map f l-        -- Tag params, each is either a mode (e.g. +abc) or an arg (e.g. *!*@*)-        f t =-            case match section $ T.unpack t of-                Just sect -> Right sect-                Nothing   -> Left t-        section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-')-                      <*> (nub <$> many (psym isAsciiLetter))-        -- Collect (sign, modes, [arg]) tuples into a list-        _parts []                           = Just []-        _parts (Left _ : _)                 = Nothing-        _parts (Right (sign, letters) : ss) =-            let (args, next) = break isRight ss-            in  case _parts next of-                    Nothing -> Nothing-                    Just pn -> Just $ (sign, letters, args) : pn-        -- Attach args to their modes by mode type-        --attach (-    in  Nothing
− src/Network/IRC/Fun/Messages/Types.hs 
@@ -1,27 +0,0 @@-{- This file is part of irc-fun-messages.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | Most of the types that were once in this module moved to--- "Network.IRC.Fun.Types" in a separate package. The few types left here may--- move in the future too.-module Network.IRC.Fun.Messages.Types-    ( CommandResponseCode (..)-    , ErrorReplyCode (..)-    , ReservedReplyCode (..)-    , ReservedErrorCode (..)-    )-where--import Network.IRC.Fun.Messages.Internal.Types
+ src/Network/Irc/Messages.hs view
@@ -0,0 +1,37 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | This module handles parsing and serializing IRC messages and replies.+-- Types and other functionality are provided in the submodules.+module Network.Irc.Messages+    ( -- * Parsing+      parseMessage+    , messageIsReply+    , messageToReply+    , parse+    , analyzeMessage+    , analyzeReply+    , analyze+      -- * Serializing+    , buildMessage+    , buildReply+    , messageFromReply+    , serializeMessage+    , serializeReply+    )+where++import Network.Irc.Messages.Internal.Parse+import Network.Irc.Messages.Internal.Serialize
+ src/Network/Irc/Messages/Internal/Parse.hs view
@@ -0,0 +1,377 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Network.Irc.Messages.Internal.Parse+    ( -- * Parsing+      parseMessage+    , messageIsReply+    , messageToReply+    , parse+      -- * Analysis+    , analyzeMessage+    , analyzeReply+    , analyze+    )+where++import Data.Bits (testBit)+import Data.Char (toUpper)+import Data.Monoid ((<>))+import Data.Text (Text, pack, unpack, isSuffixOf, stripPrefix, null, last,+                  init)+import Network.Irc.Messages.Mask (parseMask)+import Network.Irc.Messages.Modes (parseUserMode)+import Network.Irc.Messages.Internal.Types+import Network.Irc.Messages.Internal.Util+import Network.Irc.Types+import Prelude hiding (null, last, init)+import Text.Regex.Applicative+import Text.Regex.Applicative.Common (decimal)++import qualified Network.Irc.Messages.Internal.Tokens.Message as T+import qualified Network.Irc.Messages.Internal.Tokens.Other as T+import qualified Network.Irc.Messages.Internal.Tokens.Reply as T+import qualified Network.Irc.Messages.Internal.Tokens.Target as T++-------------------------------------------------------------------------------+-- Parsing+-------------------------------------------------------------------------------++-- | Parse a raw IRC message string into a generic message structure.+parseMessage :: Text -> Maybe GenericMessage+parseMessage t =+    let crlf = "\r\n"+        t' =+            if crlf `isSuffixOf` t+                then t+                else t <> crlf+    in  matcht T.message t'++-- | Check is a given message is a server reply, i.e. has a numeric command and+-- the sender is a server.+messageIsReply :: GenericMessage -> Bool+messageIsReply msg =+    let prefOk =+            case gmPrefix msg of+                Nothing         -> False+                Just (PrefixServer _) -> True+                Just (PrefixNick {})  -> False+        cmdOk =+            case gmCommand msg of+                NamedCmd _   -> False+                NumericCmd _ -> True+    in  prefOk && cmdOk++-- | Try to convert a generic message into a matching reply value. If+-- successful, return 'Right' the reply. If the message isn't a reply, return+-- 'Left' an error message.+messageToReply :: GenericMessage -> Either Text GenericReply+messageToReply msg =+    case (gmPrefix msg, gmCommand msg, gmParams msg) of+        (Just (PrefixServer s), NumericCmd n, p : ps) ->+            Right GenericReply+                { grSender = s+                , grCode   = n+                , grTarget = NickTarget $ Nickname p+                , grParams = ps+                }+        (Just (PrefixServer _), NumericCmd _, []) ->+            Left "No parameters, must have at least one"+        (Just (PrefixNick {}),  NumericCmd _, _) ->+            Left "Sender prefix is a user, not a server"+        (Nothing,               NumericCmd _, _) ->+            Left "No sender prefix"+        (_,                     NamedCmd _,  _) ->+            Left "Command is not numeric"++-- | Parse a raw IRC message string into a generic message structure. If the+-- message is detected to be a server reply, a generic reply structure is+-- returned.+--+-- This is essentially a combination of 'parseMessage' and 'messageToReply'.+parse :: Text -> Maybe (Either GenericReply GenericMessage)+parse t =+    case parseMessage t of+        Nothing  -> Nothing+        Just msg -> Just $ either (const $ Right msg) Left $ messageToReply msg++-------------------------------------------------------------------------------+-- Analysis+-------------------------------------------------------------------------------++mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f (Left x)  = Left $ f x+mapLeft _ (Right x) = Right x++matcht :: Regex a -> Text -> Maybe a+matcht re = match re . unpack++analyzeMessage' :: Maybe Prefix+                -> String+                -> [Parameter]+                -> Either Text Message+analyzeMessage' _prefix cmd params = mapLeft (pack . show) $+    case map toUpper cmd of+    -- Connection registration+        "PASS"     -> req1 params $ \ pass ->+            Right $ PassMessage (Password pass)+        "NICK"     -> req1 params $ \ nick ->+            Right $ NickMessage (Nickname nick)+        "USER"     -> req4 params $ \ user mode _ realname ->+            case matcht decimal mode :: Maybe Int of+                Just m  ->+                    Right $+                    UserMessage+                        (Username user)+                        (testBit m 3)+                        (testBit m 2)+                        (RealName realname)+                Nothing ->+                    Left $+                    InvalidArg+                        (Just 2)+                        (Just "mode")+                        (Just "Should be a number")+        "OPER"     -> req2 params $ \ name pass ->+            Right $ OperMessage (Username name) (Password pass)+        "MODE"     -> min1 params $ \ first rest ->+            case (matcht T.nickname first, matcht T.channel first) of+                (Just nick, _)       ->+                    case rest of+                        [mode] ->+                            case parseUserMode mode of+                                Just (remove, add) ->+                                    Right $ UserModeMessage nick remove add+                                Nothing ->+                                    Left $+                                    InvalidArg (Just 1) (Just "mode") Nothing+                        l     -> Left $ WrongNumArgs (length l) Nothing+                (Nothing, Just _chan) ->+                    Left $ OtherError "Not implemented yet"+                    {-case parseChannelModeParams rest of+                        Just X ->+                        Nothing ->-}+                _                    ->+                    Left $ InvalidArg (Just 1) Nothing Nothing+        "SERVICE"  -> req6 params $ \ nick _ dist _ _ info ->+            case parseMask dist of+                Just m  -> Right $ ServiceMessage (Nickname nick) m info+                Nothing ->+                    Left $+                    InvalidArg (Just 3) (Just "distribution mask") Nothing+        "QUIT"     -> req0m1 params $ \ msg ->+            Right $ QuitMessage (fmap Comment msg)+        "SQUIT"    -> req2 params $ \ server comment ->+            Right $ SQuitMessage (Hostname server) (Comment comment)+    -- Channel operations+        "JOIN"     -> req1m2 params $ \ chans mkeys ->+            case (chans, mkeys) of+                ("0", Nothing) -> Right $ JoinMessage Nothing+                _              ->+                    let mcs = matcht (listOf T.channel) chans+                        mks = maybe (Just []) (matcht $ listOf T.key) mkeys+                    in  case (mcs, mks) of+                            (Nothing, _)       ->+                                Left $+                                InvalidArg (Just 1) (Just "channels") Nothing+                            (Just _,  Nothing) ->+                                Left $+                                InvalidArg (Just 2) (Just "keys") Nothing+                            (Just cs, Just ks) ->+                                Right $ JoinMessage $ Just (cs, ks)+        "PART"     -> req1m2 params $ \ chans msg ->+            case matcht (listOf T.channel) chans of+                Just cs -> Right $ PartMessage cs (fmap Comment msg)+                Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing+        -- "MODE" -> Channel mode handled by MODE above+        "TOPIC"    -> req1m2 params $ \ chan topic ->+            Right $ TopicMessage (Channel chan) (fmap ChannelTopic topic)+        "NAMES"    ->+            case params of+                []              -> Right $ NamesMessage [] Nothing+                [chans]         ->+                    case matcht (listOf T.channel) chans of+                        Just cs -> Right $ NamesMessage cs Nothing+                        Nothing ->+                            Left $+                            InvalidArg (Just 1) (Just "channels") Nothing+                [chans, target] ->+                    case matcht (listOf T.channel) chans of+                        Just cs ->+                            Right $ NamesMessage cs (Just $ Hostname target)+                        Nothing ->+                            Left $+                            InvalidArg (Just 1) (Just "channels") Nothing+                l               ->+                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)+        "LIST"     ->+            case params of+                []              -> Right $ ListMessage [] Nothing+                [chans]         ->+                    case matcht (listOf T.channel) chans of+                        Just cs -> Right $ ListMessage cs Nothing+                        Nothing ->+                            Left $+                            InvalidArg (Just 1) (Just "channels") Nothing+                [chans, target] ->+                    case matcht (listOf T.channel) chans of+                        Just cs ->+                            Right $ ListMessage cs (Just $ Hostname target)+                        Nothing ->+                            Left $+                            InvalidArg (Just 1) (Just "channels") Nothing+                l               ->+                    Left $ WrongNumArgs (length l) (Just $ Between 0 2)+        "INVITE"   -> req2 params $ \ nick chan ->+            case (matcht T.nickname nick, matcht T.channel chan) of+                (Nothing, _)      ->+                    Left $ InvalidArg (Just 1) (Just "nickname") Nothing+                (Just _, Nothing) ->+                    Left $ InvalidArg (Just 2) (Just "channel") Nothing+                (Just n,  Just c) -> Right $ InviteMessage n c+        "KICK"     -> req2m3 params $ \ chans users comment ->+            let mcs = matcht (listOf T.channel) chans+                ucs = matcht (listOf T.user) users+            in  case (mcs, ucs) of+                    (Nothing, _)       ->+                        Left $ InvalidArg (Just 1) (Just "channels") Nothing+                    (Just _,  Nothing) ->+                        Left $ InvalidArg (Just 2) (Just "users") Nothing+                    (Just cs, Just us) ->+                        let lc = length cs+                            lu = length us+                        in  if lc == 1 || lc == lu+                                then Right $+                                     KickMessage cs us (fmap Comment comment)+                                else Left $ OtherError "Invalid list lengths"+    -- Sending messages+        "PRIVMSG"  -> req2 params $ \ target text ->+            case matcht T.msgto target of+                Nothing ->+                    Left $ InvalidArg (Just 1) (Just "target") (Just target)+                Just t ->+                    Right $ case stripPrefix "\1ACTION " text of+                        Just s  ->+                            if not (null s) && last s == '\1'+                                then PrivActionMessage t (MsgContent $ init s)+                                else PrivMsgMessage t (MsgContent text)+                        Nothing -> PrivMsgMessage t (MsgContent text)+        "NOTICE"   -> req2 params $ \ target text ->+            case matcht T.msgto target of+                Nothing ->+                    Left $ InvalidArg (Just 1) (Just "target") (Just target)+                Just t  ->+                    Right $ NoticeMessage t (MsgContent text)+    -- Server queries and commands+        "MOTD"     -> req0m1 params $ \ target ->+            Right $ MotdMessage (fmap Hostname target)+        "LUSERS"   -> Left $ OtherError "Not implemented yet"+        "VERSION"  -> Left $ OtherError "Not implemented yet"+        "STATS"    -> Left $ OtherError "Not implemented yet"+        "LINKS"    -> Left $ OtherError "Not implemented yet"+        "TIME"     -> Left $ OtherError "Not implemented yet"+        "CONNECT"  -> Left $ OtherError "Not implemented yet"+        "TRACE"    -> Left $ OtherError "Not implemented yet"+        "ADMIN"    -> Left $ OtherError "Not implemented yet"+        "INFO"     -> req0m1 params $ \ target ->+            case target of+                Nothing -> Right $ InfoMessage Nothing+                Just t  ->+                    Right $ case matcht T.nickname t of+                        Just n  ->+                            InfoMessage (Just $ NickTarget n)+                        Nothing ->+                            InfoMessage (Just $ ServerTarget $ Hostname t)+    -- Service query and commands+        "SERVLIST" -> Left $ OtherError "Not implemented yet"+        "SQUERY"   -> Left $ OtherError "Not implemented yet"+    -- User based queries+        "WHO"      -> Left $ OtherError "Not implemented yet"+        "WHOIS"    -> Left $ OtherError "Not implemented yet"+        "WHOWAS"   -> Left $ OtherError "Not implemented yet"+    -- Miscellaneous messages+        "KILL"     -> Left $ OtherError "Not implemented yet"+        "PING"     -> req1m2 params $ \ s1 s2 ->+            Right $ PingMessage (Hostname s1) (fmap Hostname s2)+        "PONG"     -> req1m2 params $ \ s1 s2 ->+            Right $ PongMessage (Hostname s1) (fmap Hostname s2)+        "ERROR"    -> Left $ OtherError "Not implemented yet"+    -- Optional features+        "AWAY"     -> req0m1 params $ \ text ->+            Right $ AwayMessage (fmap MsgContent text)+        "REHASH"   -> Left $ OtherError "Not implemented yet"+        "DIE"      -> Left $ OtherError "Not implemented yet"+        "RESTART"  -> Left $ OtherError "Not implemented yet"+        "SUMMON"   -> Left $ OtherError "Not implemented yet"+        "USERS"    -> Left $ OtherError "Not implemented yet"+        "WALLOPS"  -> Left $ OtherError "Not implemented yet"+        "USERHOST" -> Left $ OtherError "Not implemented yet"+        "ISON"     -> Left $ OtherError "Not implemented yet"+        _          -> Left $ OtherError "Unrecognized command"++-- | Read a generic message structure into specific message details. Return+-- 'Left' an error description if analysis fails. If the message is detected+-- to be a reply, return a generic reply structure without analyzing.+analyzeMessage+    :: GenericMessage+    -> Either Text (Either GenericReply SpecificMessage)+analyzeMessage msg =+    if messageIsReply msg+        then fmap Left $ messageToReply msg+        else case gmCommand msg of+            NamedCmd c ->+                fmap (Right . SpecificMessage (gmPrefix msg)) $+                analyzeMessage'+                    (gmPrefix msg)+                    (unpack $ unCmdName c)+                    (gmParams msg)+            _               ->+                Left "Implementation error"++analyzeReply' :: Int -> Target -> [Parameter] -> Either Text Reply+analyzeReply' c _ params =+    case c of+        353 ->+            case params of+                [priv, chan, nicks] ->+                    maybe (Left "Invalid parameters") Right $ do+                        chan' <- matcht T.channel chan+                        priv' <- matcht T.chanpriv priv+                        pnicks <- matcht T.prefnicks nicks+                        return $ NamesReply priv' chan' pnicks+                (_:_:_:_:_) -> Left "Too many parameters"+                _ -> Left "Too few parameters"+        _   -> Left "Not implemented yet"++-- | Read a generic reply structure into specific reply details. Return+-- 'Left' an error description if analysis fails.+analyzeReply :: GenericReply -> Either Text SpecificReply+analyzeReply gr =+    fmap (SpecificReply (grSender gr) (grTarget gr)) $+    analyzeReply' (unCmdNumber $ grCode gr) (grTarget gr) (grParams gr)++-- | Read a generic reply structure into specific message or reply details.+-- Return 'Left' an error description if analysis fails.+--+-- This is essentially a combination or 'analyzeMessage' and 'analyzeReply'.+analyze :: GenericMessage+        -> Either Text (Either SpecificReply SpecificMessage)+analyze gm =+    case analyzeMessage gm of+        Left e            -> Left e+        Right (Left rpl)  -> fmap Left $ analyzeReply rpl+        Right (Right msg) -> Right $ Right msg
+ src/Network/Irc/Messages/Internal/Serialize.hs view
@@ -0,0 +1,308 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Network.Irc.Messages.Internal.Serialize+    ( -- * Building+      buildMessage+    , buildReply+    , messageFromReply+      -- * Serializing+    , serializeMessage+    , serializeReply+    )+where++import Data.Bits (bit, zeroBits, (.|.))+import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text)+import Network.Irc.Messages.Mask (serializeMask)+import Network.Irc.Messages.Internal.Util+import Network.Irc.Types++import qualified Data.Text as T++-------------------------------------------------------------------------------+-- Building+-------------------------------------------------------------------------------++showAddr :: Address -> Text+showAddr (IPv4 t) = t+showAddr (IPv6 t) = t++showHost :: Host -> Text+showHost (HostByName hn)   = unHostname hn+showHost (HostByAddr addr) = showAddr addr+showHost (HostCloak t)     = t++showTargetMask :: TargetMask -> Text+showTargetMask (HostMask m)   = '#' `T.cons` serializeMask m+showTargetMask (ServerMask m) = '$' `T.cons` serializeMask m++showTarget :: MessageTarget -> Text+showTarget (ChannelTarget chan) = unChannel chan+showTarget+    (UserTarget+        Nothing+        (Just (UserAddress (Username user) mhost))+        (Just server)+    ) =+    let u = case mhost of+                Nothing   -> user+                Just host -> user <> "%" <> showHost host+    in  u <> "@" <> unHostname server+showTarget+    (UserTarget+        Nothing+        (Just (UserAddress (Username user) (Just host)))+        Nothing+    ) =+    user <> "%" <> showHost host+showTarget+    (UserTarget+        (Just (Nickname nick))+        Nothing+        Nothing+    ) =+    nick+showTarget+    (UserTarget+        (Just (Nickname nick))+        (Just (UserAddress (Username user) (Just host)))+        Nothing+    ) =+    nick <> "!" <> user <> "@" <> showHost host+showTarget (MaskTarget mt) = showTargetMask mt+showTarget _ = "invalid_target"++-- Fill command name and parameters from specific message+buildMessage' :: Message -> (Text, [Parameter])+buildMessage' msg =+    case msg of+        PassMessage pass ->+            ("PASS", [unPassword pass])+        NickMessage nn ->+            ("NICK", [unNickname nn])+        UserMessage un i w rn ->+            ( "USER"+            , [ unUsername un+              , showt $ modebit 3 i .|. modebit 2 w+              , "*"+              , unRealName rn+              ]+            )+            where+            modebit n b = if b then bit n else zeroBits :: Int+        OperMessage _un _p ->+            ("????", error "Not implemented")+        UserModeMessage _n _remove _add ->+            ("????", error "Not implemented")+        ServiceMessage _n _m _s ->+            ("????", error "Not implemented")+        QuitMessage reason ->+            ("QUIT", perhaps $ fmap unComment reason)+        SQuitMessage _s _t ->+            ("????", error "Not implemented")+        JoinMessage Nothing ->+            ("JOIN", ["0"])+        JoinMessage (Just (chans, keys)) ->+            ( "JOIN"+            , T.intercalate "," (map unChannel chans) :+              if null keys+                then []+                else [T.intercalate "," $ map unChannelKey keys]+            )+        PartMessage chans reason ->+            ( "PART"+            , T.intercalate "," (map unChannel chans) ?: fmap unComment reason+            )+        ChannelModeMessage _remove _add ->+            ("????", error "Not implemented")+        TopicMessage chan topic ->+            ("TOPIC", unChannel chan ?: fmap unChannelTopic topic)+        NamesMessage chans serv ->+            ( "NAMES"+            , T.intercalate "," (map unChannel chans) ?: fmap unHostname serv+            )+        ListMessage _chans _serv ->+            ("????", error "Not implemented")+        InviteMessage _nn _chan ->+            ("????", error "Not implemented")+        KickMessage _chans _users _s ->+            ("????", error "Not implemented")+        PrivMsgMessage tgt (MsgContent mc) ->+            ("PRIVMSG", [showTarget tgt, mc])+        PrivActionMessage tgt (MsgContent mc) ->+            ("PRIVMSG", [showTarget tgt, "\1ACTION " <> mc <> "\1"])+        NoticeMessage tgt (MsgContent mc) ->+            ("NOTICE", [showTarget tgt, mc])+        MotdMessage _serv ->+            ("????", error "Not implemented")+        LusersMessage _serv ->+            ("????", error "Not implemented")+        VersionMessage _serv ->+            ("????", error "Not implemented")+        StatsMessage _x ->+            ("????", error "Not implemented")+        LinksMessage _x ->+            ("????", error "Not implemented")+        TimeMessage _serv ->+            ("????", error "Not implemented")+        ConnectMessage _serv _portn _sm ->+            ("????", error "Not implemented")+        TraceMessage _t ->+            ("????", error "Not implemented")+        AdminMessage _t ->+            ("????", error "Not implemented")+        InfoMessage _t ->+            ("????", error "Not implemented")+        ServlistMessage _ ->+            ("????", error "Not implemented")+        SQueryMessage _ _ ->+            ("????", error "Not implemented")+        WhoMessage _ ->+            ("????", error "Not implemented")+        WhoisMessage _ _ ->+            ("????", error "Not implemented")+        WhowasMessage _ _ ->+            ("????", error "Not implemented")+        KillMessage _ _ ->+            ("????", error "Not implemented")+        PingMessage s1 s2 ->+            ("PING", unHostname s1 ?: fmap unHostname s2)+        PongMessage s1 s2 ->+            ("PONG", unHostname s1 ?: fmap unHostname s2)+        ErrorMessage _ ->+            ("????", error "Not implemented")+        AwayMessage _ ->+            ("????", error "Not implemented")+        RehashMessage ->+            ("????", error "Not implemented")+        DieMessage ->+            ("????", error "Not implemented")+        RestartMessage ->+            ("????", error "Not implemented")+        SummonMessage _ _ ->+            ("????", error "Not implemented")+        UsersMessage _ ->+            ("????", error "Not implemented")+        WallopsMessage _ ->+            ("????", error "Not implemented")+        UserhostMessage _ ->+            ("????", error "Not implemented")+        IsonMessage _ ->+            ("????", error "Not implemented")+    where+    perhaps = maybeToList+    x ?: my = x : perhaps my++-- | Fill a generic message record using a specific message's details.+buildMessage :: SpecificMessage -> GenericMessage+buildMessage (SpecificMessage pref msg) =+    let (cmd, ps) = buildMessage' msg+    in  GenericMessage pref (NamedCmd $ CmdName cmd) ps++channelPrivacyChar :: ChannelPrivacy -> Char+channelPrivacyChar Secret  = '@'+channelPrivacyChar Private = '*'+channelPrivacyChar Public  = '='++privilegeChar :: Privilege -> Maybe Char+privilegeChar Regular  = Nothing+privilegeChar Voice    = Just '+'+privilegeChar Operator = Just '@'++-- Fill reply code, target and parameters from specific reply+buildReply' :: Reply -> (Int, [Parameter])+buildReply' reply =+    case reply of+        NamesReply priv chan pns ->+            ( 353+            , [ T.singleton $ channelPrivacyChar priv+              , unChannel chan+              , T.unwords $+                map+                    (\ (p, (Nickname n)) ->+                        maybe n (`T.cons` n) $ privilegeChar p+                    )+                    pns+              ]+            )+        _ -> error "Not implemented"++-- | Fill a generic reply record using a specific reply's details.+buildReply :: SpecificReply -> GenericReply+buildReply (SpecificReply sender tgt reply) =+    let (code, ps) = buildReply' reply+    in  GenericReply sender (CmdNumber code) tgt ps++-- | Convert a reply, which is a message with a numeric command name, into a+-- generic message value.+messageFromReply :: GenericReply -> GenericMessage+messageFromReply reply = GenericMessage+    { gmPrefix  = Just $ PrefixServer $ grSender reply+    , gmCommand = NumericCmd $ grCode reply+    , gmParams  = target' reply : grParams reply+    }+    where+    target' (GenericReply { grTarget = NickTarget n })   = unNickname n+    target' (GenericReply { grTarget = ServerTarget s }) = unHostname s++-------------------------------------------------------------------------------+-- Serializing+-------------------------------------------------------------------------------++serializePrefix :: Prefix -> Text+serializePrefix (PrefixServer sn)    = unHostname sn+serializePrefix (PrefixNick n mu mh) =+    unNickname n                                 <>+    maybe "" ('!' `T.cons`) (fmap unUsername mu) <>+    maybe "" (('@' `T.cons`) . showHost) mh++serializeCommand :: Command -> Text+serializeCommand (NamedCmd t)   = unCmdName t+serializeCommand (NumericCmd n) = showt $ unCmdNumber n++serializeParams :: [Parameter] -> Text+serializeParams = f . map (\ p -> if T.null p then "(?)" else p)+    where+    f [] = ""+    f l  =+        let (ps, p) = (init l, last l)+        in  T.concat (map (' ' `T.cons`) ps) <> " " <>+            if T.head p == ':' || T.any (== ' ') p+                then ':' `T.cons` p+                else p++-- | Write a message into an IRC protocol message formatted string.+serializeMessage :: GenericMessage -> Text+serializeMessage msg = T.concat+    [ maybe+        T.empty+        (\ p -> ':' `T.cons` serializePrefix p `T.snoc` ' ')+        (gmPrefix msg)+    , serializeCommand $ gmCommand msg+    , serializeParams $ gmParams msg+    , "\r\n"+    ]++-- | Write a reply into an IRC protocol message formatted string.+--+-- This is essentially a combination of 'messageFromReply' and+-- 'serializeMessage'.+serializeReply :: GenericReply -> Text+serializeReply = serializeMessage . messageFromReply
+ src/Network/Irc/Messages/Internal/Tokens/Message.hs view
@@ -0,0 +1,89 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Tokens.Message+    ( message+    )+where++import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import Network.Irc.Messages.Internal.Tokens.Other+import Network.Irc.Messages.Internal.Tokens.Target+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++----------TOTO+{-+- go over errata, make sure everything here is correct+- some regexes, such as matchone and target, seem not to be used in the rules+  here. they're probably intended for later use, e.g. when matching a string+  against a mask. in such case the API should probably import them+-}++message :: Regex GenericMessage+message =+    GenericMessage                        <$>+    optional (sym ':' *> prefix <* space) <*>+    command                               <*>+    (fromMaybe [] <$> optional params)    <*+    crlf++prefix :: Regex Prefix+prefix =+    PrefixServer <$> servername+    <|>+    nick         <$>+    nickname     <*>+    optional+        ( (,)                        <$>+          optional (sym '!' *> user) <*+          sym '@'                    <*>+          host+        )+    where+    nick n Nothing       = PrefixNick n Nothing Nothing+    nick n (Just (u, h)) = PrefixNick n u       (Just h)++command :: Regex Command+command =+    let f a b c = NumericCmd $ CmdNumber $ read [a, b, c]+    in  NamedCmd . CmdName . pack <$> some letter+        <|>+        f                         <$> digit <*> digit <*> digit++params :: Regex [Text]+params =+    let f m (Just t) = m ++ [t]+        f m Nothing  = m+    in  f                      <$>+        many (space *> middle) <*>+        optional (space *> sym ':' *> trailing)++middle :: Regex Text+middle = pack <$> ((:) <$> paramchar <*> many (sym ':' <|> paramchar))++trailing :: Regex Text+trailing = pack <$> many (sym ':' <|> sym ' ' <|> paramchar)++paramchar :: Regex Char+paramchar = psym (`notElem` "\0\r\n :")++space :: Regex Char+space = sym ' '++crlf :: Regex String+crlf = string "\r\n"
+ src/Network/Irc/Messages/Internal/Tokens/Other.hs view
@@ -0,0 +1,62 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Tokens.Other+    ( user+    , key+    , letter+    , digit+    , hexdigit+    , hexdigit'+    , special+    )+where++import Data.Char (isAscii, isDigit)+import Data.Text (pack)+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++user :: Regex Username+user = Username . pack <$> some (psym (`notElem` "\0\r\n @"))++key :: Regex ChannelKey+key =+    ChannelKey . pack <$>+    some (psym $ \ c -> isAscii c && c `notElem` "\0\r\n\f\t\v ")++letter :: Regex Char+letter = psym $ \ c -> 'A' <= c && c <= 'Z'  ||  'a' <= c && c <= 'z'++digit :: Regex Char+digit = psym isDigit++hexdigit :: Regex Char+hexdigit = digit <|> upperhex+    where+    upperhex = psym $ \ c -> 'A' <= c && c <= 'F'++-- RFC 2812 assumes IPv6 addresses with uppercase hex digits. In practice, the+-- recommendation it to use lowercase, and that's what really happens. So this+-- regex accepts both lowercase and uppercase.+hexdigit' :: Regex Char+hexdigit' = digit <|> upperhex <|> lowerhex+    where+    upperhex = psym $ \ c -> 'A' <= c && c <= 'F'+    lowerhex = psym $ \ c -> 'a' <= c && c <= 'f'++special :: Regex Char+special = psym (`elem` "[]\\`_^{|}")
+ src/Network/Irc/Messages/Internal/Tokens/Reply.hs view
@@ -0,0 +1,43 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Tokens.Reply+    ( chanpriv+    , prefnicks+    )+where++import Data.Maybe (fromMaybe)+import Network.Irc.Messages.Internal.Tokens.Target+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++-------------------------------------------------------------------------------+-- 353 RPL_NAMREPLY+-------------------------------------------------------------------------------++chanpriv :: Regex ChannelPrivacy+chanpriv = Secret <$ sym '@' <|> Private <$ sym '*' <|> Public <$ sym '='++prefnicks :: Regex [(Privilege, Nickname)]+prefnicks = (:) <$> prefnick <*> many (sym ' ' *> prefnick)++prefnick :: Regex (Privilege, Nickname)+prefnick = (,) <$> privilege <*> nickname++privilege :: Regex Privilege+privilege =+    fromMaybe Regular <$> optional (Voice <$ sym '+' <|> Operator <$ sym '@')
+ src/Network/Irc/Messages/Internal/Tokens/Target.hs view
@@ -0,0 +1,139 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Tokens.Target+    ( target+    , msgtarget+    , msgto+    , channel+    , servername+    , host+    , nickname+    )+where++import Data.Char (isAsciiUpper)+import Data.Text (Text, pack)+import Network.Irc.Messages.Internal.Tokens.Other+import Network.Irc.Messages.Internal.Tokens.Wildcards+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++target :: Regex Target+target = NickTarget <$> nickname <|> ServerTarget <$> servername++msgtarget :: Regex [MessageTarget]+msgtarget = (:) <$> msgto <*> many (sym ',' *> msgto)++msgto :: Regex MessageTarget+msgto = ChannelTarget <$> channel+    <|> uhs <$> user+            <*> optional (sym '%' *> host) <* sym '@'+            <*> servername+    <|> uh <$> user <* sym '%'+           <*> host+    <|> MaskTarget <$> targetmask+    <|> nn <$> nickname+    <|> nuh <$> nickname <* sym '!'+            <*> user <* sym '@'+            <*> host+    where+    uhs u h s = UserTarget Nothing  (Just (UserAddress u h))        (Just s)+    uh  u h   = UserTarget Nothing  (Just (UserAddress u (Just h))) Nothing+    nn  n     = UserTarget (Just n) Nothing                      Nothing+    nuh n u h = UserTarget (Just n) (Just (UserAddress u (Just h))) Nothing++channel :: Regex Channel+channel =+    Channel . pack . snd <$>+    withMatched+    ( (sym '#' <|> sym '+' <|> sym '!' <* channelid <|> sym '&') <*+      chanstring                                                 <*+      optional (sym ':' <* chanstring)+    )++servername :: Regex Hostname+servername = hostname++host :: Regex Host+host =+    HostByAddr  <$> hostaddr+    <|>+    HostByName  <$> hostname+    <|>+    HostCloak   <$> hostcloak++hostname :: Regex Hostname+hostname =+    Hostname . pack . snd <$>+    withMatched (shortname <* many (sym '.' <* shortname))++shortname :: Regex String+shortname =+    snd <$> withMatched+        ( (letter <|> digit) <*+          optional (many (letter <|> digit <|> sym '-') <* (letter <|> digit))+        )++hostaddr :: Regex Address+hostaddr = IPv4 <$> ip4addr <|> IPv6 <$> ip6addr++ip4addr :: Regex Text+ip4addr = pack . snd <$> withMatched (s <* p <* s <* p <* s <* p <* s)+    where+    d = digit+    s = snd <$> withMatched (d  <|>  d <* d  <|>  d <* d <* d)+    p = sym '.'++ip6addr :: Regex Text+ip6addr = pack . snd <$> withMatched (full <|> short <|> v4)+    where+    h = some hexdigit'+    c = sym ':'+    s = h <* many (c <* h)+    full = h <* c <* h <* c <*+           h <* c <* h <* c <*+           h <* c <* h <* c <*+           h <* c <* h+    short = optional s *> string "::" <* optional s+    v4 = string "0:0:0:0:0:" <*+         (string "0" <|> string "FFFF") <*+         sym ':' <*+         ip4addr++hostcloak :: Regex Text+hostcloak =+    pack <$> some (letter <|> digit <|> special <|> psym (`elem` ".-/"))++nickname :: Regex Nickname+nickname =+    Nickname . pack <$>+    ( (:)                                             <$>+      (letter <|> special)                            <*>+      many (letter <|> digit <|> special <|> sym '-')+    )++targetmask :: Regex TargetMask+targetmask = ServerMask <$> (sym '$' *> mask)+         <|> HostMask   <$> (sym '#' *> mask)++chanstring :: Regex String+chanstring = many $ psym (`notElem` "\0\a\r\n ,:")++channelid :: Regex String+channelid = snd <$> withMatched (c *> c *> c *> c *> c)+    where+    c = psym isAsciiUpper <|> digit
+ src/Network/Irc/Messages/Internal/Tokens/Wildcards.hs view
@@ -0,0 +1,46 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Tokens.Wildcards+    ( mask+    , matchone+    , matchmany+    )+where++import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++mask :: Regex Mask+mask = Mask <$> many (nowild  <|>  noesc *> wildone  <|>  noesc *> wildmany)++wildone :: Regex MaskPart+wildone = MaskWildOne <$ sym '?'++wildmany :: Regex MaskPart+wildmany = MaskWildMany <$ sym '*'++nowild :: Regex MaskPart+nowild = MaskChar <$> psym (`notElem` "\0*?")++noesc :: Regex Char+noesc = psym (`notElem` "\0\\")++matchone :: Regex Char+matchone = psym (/= '\0')++matchmany :: Regex String+matchmany = many matchone
+ src/Network/Irc/Messages/Internal/Types.hs view
@@ -0,0 +1,372 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Types+    ( -- * Type Aliases And Newtypes+      Regex+      -- * Reply+    , CommandResponseCode (..)+    , ErrorReplyCode (..)+    , ReservedReplyCode (..)+    , ReservedErrorCode (..)+    )+where++import Text.Regex.Applicative (RE)++-- | TODO+type Regex = RE Char++-------------------------------------------------------------------------------+-- Reply+-------------------------------------------------------------------------------++-- | TODO+data CommandResponseCode+    -- | TODO+    = ReplyWelcome+    -- | TODO+    | ReplyYourHost+    -- | TODO+    | ReplyCreated+    -- | TODO+    | ReplyMyInfo+    -- | TODO+    | ReplyBounce+    -- | TODO+    | ReplyUserHost+    -- | TODO+    | ReplyIsOn+    -- | TODO+    | ReplyAway+    -- | TODO+    | ReplyUnAway+    -- | TODO+    | ReplyNoAway+    -- | TODO+    | ReplyWhoIsUser+    -- | TODO+    | ReplyWhoIsServer+    -- | TODO+    | ReplyWhoIsOperator+    -- | TODO+    | ReplyWhoIsIdle+    -- | TODO+    | ReplyEndOfWhoIs+    -- | TODO+    | ReplyWhoIsChannels+    -- | TODO+    | ReplyWhoWasUser+    -- | TODO+    | ReplyEndOfWhoWas+    -- | TODO+    | ReplyListStart+    -- | TODO+    | ReplyList+    -- | TODO+    | ReplyListEnd+    -- | TODO+    | ReplyUniqueOpIs+    -- | TODO+    | ReplyChannelModeIs+    -- | TODO+    | ReplyNoTopic+    -- | TODO+    | ReplyTopic+    -- | TODO+    | ReplyInviting+    -- | TODO+    | ReplySummoning+    -- | TODO+    | ReplyInviteList+    -- | TODO+    | ReplyEndOfInviteList+    -- | TODO+    | ReplyExceptList+    -- | TODO+    | ReplyEndOfExceptList+    -- | TODO+    | ReplyVersion+    -- | TODO+    | ReplyWhoReply+    -- | TODO+    | ReplyEndOfWho+    -- | TODO+    | ReplyNameReply+    -- | TODO+    | ReplyEndOfNames+    -- | TODO+    | ReplyLinks+    -- | TODO+    | ReplyEndOfLinks+    -- | TODO+    | ReplyBanList+    -- | TODO+    | ReplyEndOfBanList+    -- | TODO+    | ReplyInfo+    -- | TODO+    | ReplyEndOfInfo+    -- | TODO+    | ReplyMotdStart+    -- | TODO+    | ReplyMessageOfTheDay+    -- | TODO+    | ReplyEndOfMessageOfTheDay+    -- | TODO+    | ReplyYoureOper+    -- | TODO+    | ReplyRehashing+    -- | TODO+    | ReplyYoureService+    -- | TODO+    | ReplyTime+    -- | TODO+    | ReplyUsersStart+    -- | TODO+    | ReplyUsers+    -- | TODO+    | ReplyEndOfUsers+    -- | TODO+    | ReplyNoUsers+    -- | TODO+    | ReplyTraceLink+    -- | TODO+    | ReplyTraceConnecting+    -- | TODO+    | ReplyTraceHandshake+    -- | TODO+    | ReplyTraceUnknown+    -- | TODO+    | ReplyTraceOperator+    -- | TODO+    | ReplyTraceUser+    -- | TODO+    | ReplyTraceServer+    -- | TODO+    | ReplyTraceService+    -- | TODO+    | ReplyTraceNewType+    -- | TODO+    | ReplyTraceClass+    -- | TODO+    | ReplyTraceReconnect+    -- | TODO+    | ReplyTraceLog+    -- | TODO+    | ReplyTraceEnd+    -- | TODO+    | ReplyStatsLinkInfo+    -- | TODO+    | ReplyStatsCommands+    -- | TODO+    | ReplyEndOfStats+    -- | TODO+    | ReplyStatsUptime+    -- | TODO+    | ReplyStatsOLine+    -- | TODO+    | ReplyUModeIs+    -- | TODO+    | ReplyServList+    -- | TODO+    | ReplyServListEnd+    -- | TODO+    | ReplyLuserClient+    -- | TODO+    | ReplyLuserOp+    -- | TODO+    | ReplyLuserUnknown+    -- | TODO+    | ReplyLuserChannels+    -- | TODO+    | ReplyLuserMe+    -- | TODO+    | ReplyAdminMe+    -- | TODO+    | ReplyAdminLocation1+    -- | TODO+    | ReplyAdminLocation2+    -- | TODO+    | ReplyAdminEmail+    -- | TODO+    | ReplyTryAgain+    -- | TODO+    | ReplyFreenodeISupport+    deriving (Eq, Show)++data ErrorReplyCode+    -- | TODO+    = ErrorNoSuchNick+    -- | TODO+    | ErrorNoSuchServer+    -- | TODO+    | ErrorNoSuchChannel+    -- | TODO+    | ErrorCannotSendToChannel+    -- | TODO+    | ErrorTooManyChannels+    -- | TODO+    | ErrorWasNoSuchNick+    -- | TODO+    | ErrorTooManyTargets+    -- | TODO+    | ErrorNoSuchService+    -- | TODO+    | ErrorNoOrigin+    -- | TODO+    | ErrorNoRecipient+    -- | TODO+    | ErrorNoTextToSend+    -- | TODO+    | ErrorNoTopLevel+    -- | TODO+    | ErrorWildTopLevel+    -- | TODO+    | ErrorBadMask+    -- | TODO+    | ErrorUnknownCommand+    -- | TODO+    | ErrorNoMessageOfTheDay+    -- | TODO+    | ErrorNoAdminInfo+    -- | TODO+    | ErrorFileError+    -- | TODO+    | ErrorNoNicknameGiven+    -- | TODO+    | ErrorErroneousNickname+    -- | TODO+    | ErrorNicknameInUse+    -- | TODO+    | ErrorNickCollision+    -- | TODO+    | ErrorUnavailableResource+    -- | TODO+    | ErrorUserNotInChannel+    -- | TODO+    | ErrorNotOnChannel+    -- | TODO+    | ErrorUserOnChannel+    -- | TODO+    | ErrorNoLogin+    -- | TODO+    | ErrorSummonDisabled+    -- | TODO+    | ErrorUsersDisabled+    -- | TODO+    | ErrorNotRegistered+    -- | TODO+    | ErrorNeedMoreParams+    -- | TODO+    | ErrorAlreadyRegistered+    -- | TODO+    | ErrorNoPermissionForHost+    -- | TODO+    | ErrorPasswordMismatch+    -- | TODO+    | ErrorYoureBannedCreep+    -- | TODO+    | ErrorYouWillBeBanned+    -- | TODO+    | ErrorKeySet+    -- | TODO+    | ErrorChannelIsFull+    -- | TODO+    | ErrorUnknownMode+    -- | TODO+    | ErrorInviteOnlyChannel+    -- | TODO+    | ErrorBannedFromChannel+    -- | TODO+    | ErrorBadChannelKey+    -- | TODO+    | ErrorBadChannelMask+    -- | TODO+    | ErrorNoChannelModes+    -- | TODO+    | ErrorBanListFull+    -- | TODO+    | ErrorNoPrivileges+    -- | TODO+    | ErrorChannelOpPrivilegesNeeded+    -- | TODO+    | ErrorCantKillServer+    -- | TODO+    | ErrorRestricted+    -- | TODO+    | ErrorUniqueOpPrivilegesNeeded+    -- | TODO+    | ErrorNoOperHost+    -- | TODO+    | ErrorUModeUnknownFlag+    -- | TODO+    | ErrorUsersDontMatch+    deriving (Eq, Show)++data ReservedReplyCode+    -- | TODO+    = ReservedReplyServiceInfo+    -- | TODO+    | ReservedReplyEndOfServices+    -- | TODO+    | ReservedReplyService+    -- | TODO+    | ReservedReplyNone+    -- | TODO+    | ReservedReplyWhoIsChannelOp+    -- | TODO+    | ReservedReplyKillDone+    -- | TODO+    | ReservedReplyClosing+    -- | TODO+    | ReservedReplyCloseEnd+    -- | TODO+    | ReservedReplyInfoStart+    -- | TODO+    | ReservedReplyMyPortIs+    -- | TODO+    | ReservedReplyStatsCLine+    -- | TODO+    | ReservedReplyStatsNLine+    -- | TODO+    | ReservedReplyStatsILine+    -- | TODO+    | ReservedReplyStatsKLine+    -- | TODO+    | ReservedReplyStatsQLine+    -- | TODO+    | ReservedReplyStatsYLine+    -- | TODO+    | ReservedReplyStatsVLine+    -- | TODO+    | ReservedReplyStatsLLine+    -- | TODO+    | ReservedReplyStatsHLine+    -- | TODO+    | ReservedReplyStatsSLine+    -- | TODO+    | ReservedReplyStatsPing+    -- | TODO+    | ReservedReplyStatsBLine+    -- | TODO+    | ReservedReplyStatsDLine+    deriving (Eq, Show)++-- | TODO+data ReservedErrorCode+    -- | TODO+    = ReservedErrorNoServiceHost+    deriving (Eq, Show)
+ src/Network/Irc/Messages/Internal/Util.hs view
@@ -0,0 +1,148 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.Irc.Messages.Internal.Util+    ( showt+    , listOf+    , req0+    , req1+    , req2+    , req3+    , req4+    , req5+    , req6+    , req0m1+    , req1m2+    , req2m3+    , req3m4+    , min1+    )+where++import Data.Text (Text, pack)+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++showt :: Int -> Text+showt = pack . show++listOf :: Regex a -> Regex [a]+listOf re = (:) <$> re <*> many (sym ',' *> re)++req0 :: [Parameter]+     -> Either AnalysisError Message+     -> Either AnalysisError Message+req0 [] f = f+req0 l  _ = Left $ WrongNumArgs (length l) (Just $ Exactly 0)++req1 :: [Parameter]+     -> (Parameter -> Either AnalysisError Message)+     -> Either AnalysisError Message+req1 [p1] f = f p1+req1 l    _ = Left $ WrongNumArgs (length l) (Just $ Exactly 1)++req2 :: [Parameter]+     -> (Parameter -> Parameter -> Either AnalysisError Message)+     -> Either AnalysisError Message+req2 [p1, p2] f = f p1 p2+req2 l        _ = Left $ WrongNumArgs (length l) (Just $ Exactly 2)++req3 :: [Parameter]+     -> (Parameter -> Parameter -> Parameter -> Either AnalysisError Message)+     -> Either AnalysisError Message+req3 [p1, p2, p3] f = f p1 p2 p3+req3 l            _ = Left $ WrongNumArgs (length l) (Just $ Exactly 3)++req4 :: [Parameter]+     -> (  Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Either AnalysisError Message+        )+     -> Either AnalysisError Message+req4 [p1, p2, p3, p4] f = f p1 p2 p3 p4+req4 l            _     = Left $ WrongNumArgs (length l) (Just $ Exactly 4)++req5 :: [Parameter]+     -> (  Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Either AnalysisError Message+        )+     -> Either AnalysisError Message+req5 [p1, p2, p3, p4, p5] f = f p1 p2 p3 p4 p5+req5 l                    _ = Left $ WrongNumArgs (length l) (Just $ Exactly 5)++req6 :: [Parameter]+     -> (  Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Parameter+        -> Either AnalysisError Message+        )+     -> Either AnalysisError Message+req6 [p1, p2, p3, p4, p5,p6] f = f p1 p2 p3 p4 p5 p6+req6 l                       _ = Left $+                                 WrongNumArgs (length l) (Just $ Exactly 6)++req0m1 :: [Parameter]+       -> (Maybe Parameter -> Either AnalysisError Message)+       -> Either AnalysisError Message+req0m1 [] f   = f Nothing+req0m1 [p1] f = f $ Just p1+req0m1 l    _ = Left $ WrongNumArgs (length l) (Just $ Between 0 1)++req1m2 :: [Parameter]+       -> (Parameter -> Maybe Parameter -> Either AnalysisError Message)+       -> Either AnalysisError Message+req1m2 [p1]     f = f p1 Nothing+req1m2 [p1, p2] f = f p1 (Just p2)+req1m2 l        _ = Left $ WrongNumArgs (length l) (Just $ Between 1 2)++req2m3 :: [Parameter]+       -> (  Parameter+          -> Parameter+          -> Maybe Parameter+          -> Either AnalysisError Message+          )+       -> Either AnalysisError Message+req2m3 [p1, p2]     f = f p1 p2 Nothing+req2m3 [p1, p2, p3] f = f p1 p2 (Just p3)+req2m3 l            _ = Left $ WrongNumArgs (length l) (Just $ Between 2 3)++req3m4 :: [Parameter]+       -> (  Parameter+          -> Parameter+          -> Parameter+          -> Maybe Parameter+          -> Either AnalysisError Message+          )+       -> Either AnalysisError Message+req3m4 [p1, p2, p3]     f = f p1 p2 p3 Nothing+req3m4 [p1, p2, p3, p4] f = f p1 p2 p3 (Just p4)+req3m4 l                _ = Left $+                            WrongNumArgs (length l) (Just $ Between 3 4)++min1 :: [Parameter]+     -> (Parameter -> [Parameter] -> Either AnalysisError Message)+     -> Either AnalysisError Message+min1 []      _ = Left $ WrongNumArgs 0 (Just $ AtLeast 1)+min1 (p1:ps) f = f p1 ps
+ src/Network/Irc/Messages/Mask.hs view
@@ -0,0 +1,72 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | This module deals with wildcard based masks, used for selecting users and+-- servers.+module Network.Irc.Messages.Mask+    ( parseMask+    , serializeMask+    , matches+    )+where++import Data.Maybe (isJust)+import Data.Text (Text, cons, unpack)+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++import qualified Network.Irc.Messages.Internal.Tokens.Wildcards as T++{-+TODO+"The mask MUST+    have at least 1 (one) "." in it and no wildcards following the last+        ".".  This requirement exists to prevent people sending messages to+            "#*" or "$*", which would broadcast to all users."++handle this somehow! e.g. a function that tests a mask for validity+-}++-- | Parse a mask string (e.g. @"*!*@*"@) into a 'Mask' value. Returns+-- 'Nothing' if the string isn't a valid mask.+parseMask :: Text -> Maybe Mask+parseMask = match T.mask . unpack++--TODO what about escaping and invalid chars? are they handled correctly?+--prepend mapped part to given string+serializeMaskPart :: MaskPart -> Text -> Text+serializeMaskPart (MaskChar '?') t = '\\' `cons` '?' `cons` t+serializeMaskPart (MaskChar '*') t = '\\' `cons` '*' `cons` t+serializeMaskPart (MaskChar c) t   = c `cons` t+serializeMaskPart (MaskWildOne) t  = '?' `cons` t+serializeMaskPart (MaskWildMany) t = '*' `cons` t++-- | Converts a 'Mask' value into its string representation in IRC messages.+serializeMask :: Mask -> Text+serializeMask (Mask parts) = foldr serializeMaskPart mempty parts++-- TODO maybe fold MaskChars into strings? how much faster will it be?+maskToRegex :: Mask -> Regex String+maskToRegex (Mask parts) = snd <$> withMatched (foldr f (pure "") parts)+    where+    f (MaskChar c) regex = sym c *> regex+    f MaskWildOne regex  = T.matchone *> regex+    f MaskWildMany regex = T.matchmany *> regex++matches :: String -> Mask -> Bool+matches s m = isJust $ match (maskToRegex m) s++infix 2 `matches`
+ src/Network/Irc/Messages/Modes.hs view
@@ -0,0 +1,201 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | This module handles user modes and channel modes.+module Network.Irc.Messages.Modes+    ( -- * User Modes+      umodeToLetter+    , umodeFromLetter+    , parseUserMode+      -- * Channel Modes+    , cmodeToLetter+    , cmodeFromLetter+    , parseChannelModeParams+    )+where++import Data.Either (isRight)+import Data.Maybe (fromMaybe)+import Data.List (nub, partition)+import Data.Text (Text)+import Data.Tuple (swap)+import Network.Irc.Messages.Internal.Types+import Network.Irc.Types+import Text.Regex.Applicative++import qualified Data.Text as T++userModeMap :: [(UserMode, Char)]+userModeMap =+    [ (UModeInvisible,         'i')+    , (UModeCallerID,          'g')+    , (UModeSeeWallops,        'w')+    , (UModeDeaf,              'D')+    , (UModeNoForwarding,      'Q')+    , (UModeBlockUnidentified, 'R')+    , (UModeConnectedViaSSL,   'Z')+    , (UModeAway,              'a')+    , (UModeRestricted,        'r')+    , (UModeOperator,          'o')+    , (UModeLocalOperator,     'O')+    , (UModeSeeNotices,        's')+    ]++umodeToLetter :: UserMode -> Char+umodeToLetter (UModeOther c) = c+umodeToLetter um =+    fromMaybe+        (error "Implementation error: User mode not assigned a letter")+        (lookup um userModeMap)++umodeFromLetter :: Char -> UserMode+umodeFromLetter c = fromMaybe (UModeOther c) (lookup c $ map swap userModeMap)++isAsciiLetter :: Char -> Bool+isAsciiLetter c = 'a' <= c && c <= 'z'  ||  'A' <= c && c <= 'Z'++-- 1 to remove, 2 to add+umode :: Regex ([UserMode], [UserMode])+umode = mix <$> many section+    where+    section = (,) <$> (True <$ sym '+' <|> False <$ sym '-')+                  <*> (nub <$> many (psym isAsciiLetter))+    mix l =+        let (add, remove) = partition fst l+            add' = nub $ concatMap snd add+            remove' = nub $ concatMap snd remove+        in  (map umodeFromLetter remove', map umodeFromLetter add')++-- the one from the MODE irc message+parseUserMode :: Text -> Maybe ([UserMode], [UserMode])+parseUserMode = match umode . T.unpack++--TODO add modes from https://freenode.net/using_the_network.shtml+-- freenode it the main target anyway...+-- also maybe add a system for server-specific non-standard flags+channelModeMap :: [(ChannelMode, Char, ChannelModeType)]+channelModeMap = --eIbq,k,flj,CFLMPQScgimnprstz -- o and v type B syntax-wise+    [ (CModeCreator,                      'O', ModeTypeMaybeSetting)+    , (CModeOperator,                     'o', ModeTypeSetting)+    , (CModeVoice,                        'v', ModeTypeSetting)+    , (CModeAnonymous,                    'a', ModeTypeFlag)+    , (CModeInviteOnly,                   'i', ModeTypeFlag)+    , (CModeModerated,                    'm', ModeTypeFlag)+    , (CModeNoMessagesFromOutside,        'n', ModeTypeFlag)+    , (CModeQuiet,                        'q', ModeTypeFlag)+    , (CModePrivate,                      'p', ModeTypeFlag)+    , (CModeSecret,                       's', ModeTypeFlag)+    , (CModeServerReop,                   'r', ModeTypeFlag)+    , (CModeTopicSettableByChannelOpOnly, 't', ModeTypeFlag)+    , (CModeKey Nothing,                  'k', ModeTypeFlag)+    , (CModeUserLimit Nothing,            'l', ModeTypeMaybeSetting)+    , (CModeBanMask Nothing,              'b', ModeTypeList)+    , (CModeExceptionMask Nothing,        'e', ModeTypeList)+    , (CModeInvitationMask Nothing,       'I', ModeTypeList)+    ]++freenodeOverride :: [(ChannelMode, Char, ChannelModeType)]+freenodeOverride =+    [ (CModeFreenodeQuiet Nothing,        'q', ModeTypeSetting)+    ]++lookupCLetter+    :: ChannelMode+    -> [(ChannelMode, Char, ChannelModeType)]+    -> Maybe Char+lookupCLetter _ []               = Nothing+lookupCLetter q ((m, l, _t):rest) =+    if q == m+        then Just l+        else lookupCLetter q rest++--TODO make the bool=True mean we use the freenode override+cmodeToLetter :: ChannelMode -> Bool -> Char+cmodeToLetter (CModeOther c _) _ = c+cmodeToLetter cm freenode =+    let m =+            if freenode+                then freenodeOverride ++ channelModeMap+                else channelModeMap+    in  fromMaybe+            (error "Implementation error: Channel mode not assigned a letter")+            (lookupCLetter cm m)++lookupCMode+    :: Char+    -> [(ChannelMode, Char, ChannelModeType)]+    -> Maybe ChannelMode+lookupCMode _ []               = Nothing+lookupCMode c ((m, l, _):rest) = if c == l then Just m else lookupCMode c rest++--TODO make the bool=True mean we use the freenode override+cmodeFromLetter :: Char -> Bool -> ChannelMode+cmodeFromLetter c freenode =+    let m =+            if freenode+                then freenodeOverride ++ channelModeMap+                else channelModeMap+    in  fromMaybe (CModeOther c []) (lookupCMode c m)++-- the one from the MODE irc message+-- http://www.irc.org/tech_docs/005.html+{-+some rules:++A++B++C++suppose we are setting 'l', then:++l       : does nothing++l      : does nothing+-l      : unsets the mode+l 1000  : sets mode, same as +l 1000++l 1000 : sets mode+-l 1000 : unsets mode, the 1000 is ignored++D++-}+parseChannelModeParams :: [Text]+                       -> Bool -- whether to use freenode override+                       -> Maybe+                       ( [ChannelMode] -- list additions and boolean sets+                       , [ChannelMode] -- list removals and boolean unsets+                       , [ChannelMode] -- setting changes (sets and unsets)+                       )+parseChannelModeParams l _freenode =+    let _l' = map f l+        -- Tag params, each is either a mode (e.g. +abc) or an arg (e.g. *!*@*)+        f t =+            case match section $ T.unpack t of+                Just sect -> Right sect+                Nothing   -> Left t+        section = (,) <$> optional (True <$ sym '+' <|> False <$ sym '-')+                      <*> (nub <$> many (psym isAsciiLetter))+        -- Collect (sign, modes, [arg]) tuples into a list+        _parts []                           = Just []+        _parts (Left _ : _)                 = Nothing+        _parts (Right (sign, letters) : ss) =+            let (args, next) = break isRight ss+            in  case _parts next of+                    Nothing -> Nothing+                    Just pn -> Just $ (sign, letters, args) : pn+        -- Attach args to their modes by mode type+        --attach (+    in  Nothing
+ src/Network/Irc/Messages/Types.hs view
@@ -0,0 +1,27 @@+{- This file is part of irc-fun-messages.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | Most of the types that were once in this module moved to+-- "Network.Irc.Types" in a separate package. The few types left here may+-- move in the future too.+module Network.Irc.Messages.Types+    ( CommandResponseCode (..)+    , ErrorReplyCode (..)+    , ReservedReplyCode (..)+    , ReservedErrorCode (..)+    )+where++import Network.Irc.Messages.Internal.Types