From dcef0b65069fb38fd0f6c4382353167f603ebff1 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Thu, 16 Nov 2023 19:06:43 -0500 Subject: Initial commit --- deps/irc-conduit/.github/dependabot.yml | 7 + deps/irc-conduit/.github/workflows/ci.yaml | 31 +++ deps/irc-conduit/.gitignore | 4 + deps/irc-conduit/.stylish-haskell.yaml | 56 +++++ deps/irc-conduit/LICENSE | 20 ++ deps/irc-conduit/Network/IRC/Conduit.hs | 230 ++++++++++++++++++++ deps/irc-conduit/Network/IRC/Conduit/Internal.hs | 257 +++++++++++++++++++++++ deps/irc-conduit/Network/IRC/Conduit/Lens.hs | 157 ++++++++++++++ deps/irc-conduit/README.markdown | 40 ++++ deps/irc-conduit/Setup.hs | 2 + deps/irc-conduit/concourse/pipeline.yml | 121 +++++++++++ deps/irc-conduit/irc-conduit.cabal | 111 ++++++++++ deps/irc-conduit/stack.yaml | 7 + 13 files changed, 1043 insertions(+) create mode 100644 deps/irc-conduit/.github/dependabot.yml create mode 100644 deps/irc-conduit/.github/workflows/ci.yaml create mode 100644 deps/irc-conduit/.gitignore create mode 100644 deps/irc-conduit/.stylish-haskell.yaml create mode 100644 deps/irc-conduit/LICENSE create mode 100644 deps/irc-conduit/Network/IRC/Conduit.hs create mode 100644 deps/irc-conduit/Network/IRC/Conduit/Internal.hs create mode 100644 deps/irc-conduit/Network/IRC/Conduit/Lens.hs create mode 100644 deps/irc-conduit/README.markdown create mode 100644 deps/irc-conduit/Setup.hs create mode 100644 deps/irc-conduit/concourse/pipeline.yml create mode 100644 deps/irc-conduit/irc-conduit.cabal create mode 100644 deps/irc-conduit/stack.yaml (limited to 'deps/irc-conduit') diff --git a/deps/irc-conduit/.github/dependabot.yml b/deps/irc-conduit/.github/dependabot.yml new file mode 100644 index 0000000..da0b496 --- /dev/null +++ b/deps/irc-conduit/.github/dependabot.yml @@ -0,0 +1,7 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: daily + diff --git a/deps/irc-conduit/.github/workflows/ci.yaml b/deps/irc-conduit/.github/workflows/ci.yaml new file mode 100644 index 0000000..9034267 --- /dev/null +++ b/deps/irc-conduit/.github/workflows/ci.yaml @@ -0,0 +1,31 @@ +name: Run tests + +on: pull_request + +jobs: + lint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Setup + run: | + stack --no-terminal install stylish-haskell hlint + - name: Lint + run: | + set -ex + stack --no-terminal exec -- hlint --no-summary . + stack --no-terminal exec -- find . -name '*.hs' -exec stylish-haskell -i {} \; + git diff --exit-code + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Build + run: | + stack --no-terminal build diff --git a/deps/irc-conduit/.gitignore b/deps/irc-conduit/.gitignore new file mode 100644 index 0000000..afaa85d --- /dev/null +++ b/deps/irc-conduit/.gitignore @@ -0,0 +1,4 @@ +.cabal-sandbox +cabal.sandbox.config +dist +.stack-work diff --git a/deps/irc-conduit/.stylish-haskell.yaml b/deps/irc-conduit/.stylish-haskell.yaml new file mode 100644 index 0000000..2d3ca44 --- /dev/null +++ b/deps/irc-conduit/.stylish-haskell.yaml @@ -0,0 +1,56 @@ +# stylish-haskell configuration file +# https://github.com/jaspervdj/stylish-haskell +########################## + +steps: + # Import cleanup + - imports: + # Align the import names and import list throughout the entire + # file. + align: global + + # Import list is aligned with end of import including 'as' and + # 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + list_align: after_alias + + # Put as many import specs on same line as possible. + long_list_align: inline + + # () is right after the module name: + # + # > import Vector.Instances () + empty_list_align: right_after + + # Align import list on lines after the import under the start of + # the module name. + list_padding: module_name + + # There is no space between classes and constructors and the + # list of it's members. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + separate_lists: false + + # Language pragmas + - language_pragmas: + # Vertical-spaced language pragmas, one per line. + style: vertical + + # Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + align: false + + # Remove redundant language pragmas. + remove_redundant: true + + # Remove trailing whitespace + - trailing_whitespace: {} + +# Maximum line length, used by some of the steps above. +columns: 80 + +# Convert newlines to LF ("\n"). +newline: lf diff --git a/deps/irc-conduit/LICENSE b/deps/irc-conduit/LICENSE new file mode 100644 index 0000000..03c030a --- /dev/null +++ b/deps/irc-conduit/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014, Michael Walker + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/deps/irc-conduit/Network/IRC/Conduit.hs b/deps/irc-conduit/Network/IRC/Conduit.hs new file mode 100644 index 0000000..1185749 --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : OverloadedStrings, RankNTypes +-- +-- Conduits for serialising and deserialising IRC messages. +-- +-- The 'Event', 'Message', and 'Source' types are parameterised on the +-- underlying representation, and are functors. Decoding and encoding +-- only work in terms of 'ByteString's, but the generality is provided +-- so that programs using this library can operate in terms of 'Text', +-- or some other more useful representation, with great ease. +module Network.IRC.Conduit + ( -- *Type synonyms + ChannelName + , NickName + , ServerName + , Reason + , IsModeSet + , ModeFlag + , ModeArg + , NumericArg + , Target + , IrcEvent + , IrcSource + , IrcMessage + + -- *Messages + , Event(..) + , Source(..) + , Message(..) + + -- *Conduits + , ircDecoder + , ircLossyDecoder + , ircEncoder + , floodProtector + + -- *Networking + , ircClient + , ircWithConn + -- ** TLS + , ircTLSClient + , ircTLSClient' + , defaultTLSConfig + + -- *Utilities + , rawMessage + , toByteString + + -- *Lenses + , module Network.IRC.Conduit.Lens + ) where + +import Control.Applicative ((*>)) +import Control.Concurrent (newMVar, putMVar, takeMVar, + threadDelay) +import Control.Concurrent.Async (Concurrently(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM, awaitForever, + runConduit, yield, (.|)) +import Data.Conduit.Network (AppData, appSink, appSource, + clientSettings, runTCPClient) +import Data.Conduit.Network.TLS (TLSClientConfig(..), + runTLSClient, tlsClientConfig) +import Data.Monoid ((<>)) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock (NominalDiffTime, addUTCTime, + diffUTCTime, getCurrentTime) +import Data.Void (Void) +import Data.X509.Validation (FailedReason(..)) +import Network.Connection (TLSSettings(..)) +import Network.IRC.Conduit.Internal +import Network.IRC.Conduit.Lens +import Network.TLS (ClientHooks(..), + ClientParams(..), Supported(..), + Version(..), defaultParamsClient) +import Network.TLS.Extra (ciphersuite_strong) + +-- *Conduits + +-- |A conduit which takes as input bytestrings representing encoded +-- IRC messages, and decodes them to events. If decoding fails, the +-- original bytestring is just passed through. +ircDecoder :: Monad m => ConduitM ByteString (Either ByteString IrcEvent) m () +ircDecoder = chunked .| awaitForever (yield . fromByteString) + +-- |Like 'ircDecoder', but discards messages which could not be +-- decoded. +ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m () +ircLossyDecoder = chunked .| awaitForever lossy + where + lossy bs = either (\_ -> return ()) yield $ fromByteString bs + +-- |A conduit which takes as input irc messages, and produces as +-- output the encoded bytestring representation. +ircEncoder :: Monad m => ConduitM IrcMessage ByteString m () +ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString) + +-- |A conduit which rate limits output sent downstream. Awaiting on +-- this conduit will block, even if there is output ready, until the +-- time limit has passed. +floodProtector :: MonadIO m + => NominalDiffTime + -- ^The minimum time between sending adjacent messages. + -> IO (ConduitM a a m ()) +floodProtector delay = do + now <- getCurrentTime + mvar <- newMVar now + + return $ conduit mvar + + where + conduit mvar = awaitForever $ \val -> do + -- Block until the delay has passed + liftIO $ do + lastT <- takeMVar mvar + now <- getCurrentTime + + let next = addUTCTime delay lastT + + when (now < next) $ + threadDelay . ceiling $ 1000000 * diffUTCTime next now + + -- Update the time + now' <- getCurrentTime + putMVar mvar now' + + -- Send the value downstream + yield val + +-- *Networking + +-- |Connect to a network server, without TLS, and concurrently run the +-- producer and consumer. +ircClient :: Int + -- ^The port number + -> ByteString + -- ^The hostname + -> IO () + -- ^Any initialisation work (started concurrently with the + -- producer and consumer) + -> ConduitM (Either ByteString IrcEvent) Void IO () + -- ^The consumer of irc events + -> ConduitM () IrcMessage IO () + -- ^The producer of irc messages + -> IO () +ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host + +-- |Run the IRC conduits using a provided connection. +-- +-- Starts the connection and concurrently run the initialiser, event +-- consumer, and message sources. Terminates as soon as one throws an +-- exception. +ircWithConn :: ((AppData -> IO ()) -> IO ()) + -- ^The initialised connection. + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircWithConn runner start cons prod = runner $ \appdata -> runConcurrently $ + Concurrently start + *> Concurrently (runSource appdata) + *> Concurrently (runSink appdata) + + where + runSource appdata = do + runConduit $ appSource appdata .| ircDecoder .| cons + ioError $ userError "Upstream source closed." + + runSink appdata = + runConduit $ prod .| ircEncoder .| appSink appdata + +-- **TLS + +-- |Like 'ircClient', but with TLS. The TLS configuration used is +-- 'defaultTLSConfig'. +ircTLSClient :: Int + -> ByteString + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host) + +-- |Like 'ircTLSClient', but takes the configuration to use, which +-- includes the host and port. +ircTLSClient' :: TLSClientConfig + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient' cfg = ircWithConn (runTLSClient cfg) + +-- |The default TLS settings for 'ircTLSClient'. +defaultTLSConfig :: Int + -- ^The port number + -> ByteString + -- ^ The hostname + -> TLSClientConfig +defaultTLSConfig port host = (tlsClientConfig port host) + { tlsClientTLSSettings = TLSSettings cpara + { clientHooks = (clientHooks cpara) + { onServerCertificate = validate } + , clientSupported = (clientSupported cpara) + { supportedVersions = [TLS12, TLS11, TLS10] + , supportedCiphers = ciphersuite_strong + } + } + } + + where + cpara = defaultParamsClient (unpack $ decodeUtf8 host) "" + + -- Make the TLS certificate validation a bit more generous. In + -- particular, allow self-signed certificates. + validate cs vc sid cc = do + -- First validate with the standard function + res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc + -- Then strip out non-issues + return $ filter (`notElem` [UnknownCA, SelfSigned]) res diff --git a/deps/irc-conduit/Network/IRC/Conduit/Internal.hs b/deps/irc-conduit/Network/IRC/Conduit/Internal.hs new file mode 100644 index 0000000..3b9eabf --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit/Internal.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Network.IRC.Conduit.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : BangPatterns, DeriveFunctor, OverloadedStrings, RankNTypes, TupleSections +-- +-- Internal IRC conduit types and utilities. This module is NOT +-- considered to form part of the public interface of this library. +module Network.IRC.Conduit.Internal where + +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Data.ByteString (ByteString, isSuffixOf, singleton, + unpack) +import Data.Char (ord) +import Data.Conduit (ConduitM, await, yield) +import Data.Maybe (isJust, listToMaybe) +import Data.Monoid ((<>)) +import Data.Profunctor (Choice) +import Data.String (fromString) +import Network.IRC.CTCP (CTCPByteString, getUnderlyingByteString, + orCTCP) +import Text.Read (readMaybe) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Network.IRC as I + +-- * Internal Lens synonyms + +-- | See @@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @@ 'Prism'. +type Prism' s a = Prism s s a a + + +-- *Conduits + +-- |Split up incoming bytestrings into new lines. +chunked :: Monad m => ConduitM ByteString ByteString m () +chunked = chunked' "" + where + chunked' !leftover = do + -- Wait for a value from upstream + val <- await + + case val of + Just val' -> + let + carriage = fromIntegral $ fromEnum '\r' + newline = fromIntegral $ fromEnum '\n' + + -- Split on '\n's, removing any stray '\r's (line endings + -- are usually '\r\n's, but this isn't certain). + bytes = B.filter (/=carriage) $ leftover <> val' + splitted = B.split newline bytes + + -- If the last chunk ends with a '\n', then we have a + -- complete message at the end, and can yield it + -- immediately. Otherwise, store the partial message to + -- prepend to the next bytestring received. + (toyield, remainder) + | singleton newline `isSuffixOf` bytes = (splitted, "") + | otherwise = init &&& last $ splitted + + in do + -- Yield all complete and nonempty messages, and loop. + mapM_ yield $ filter (not . B.null) toyield + chunked' remainder + + Nothing -> return () + +-- *Type synonyms +type ChannelName a = a +type NickName a = a +type ServerName a = a +type Reason a = Maybe a +type IsModeSet = Bool +type ModeFlag a = a +type ModeArg a = a +type NumericArg a = a + +-- |The target of a message. Will be a nick or channel name. +type Target a = a + +type IrcEvent = Event ByteString +type IrcSource = Source ByteString +type IrcMessage = Message ByteString + +-- *Messages + +-- |A decoded IRC message + source. +data Event a = Event + { _raw :: ByteString + -- ^The message as a bytestring. + , _source :: Source a + -- ^The source of the message (user, channel, or server). + , _message :: Message a + -- ^The decoded message. This will never be a 'RawMsg'. + } + deriving (Eq, Functor, Show) + +-- |The source of an IRC message. +data Source a = User (NickName a) + -- ^The message comes directly from a user. + | Channel (ChannelName a) (NickName a) + -- ^The message comes from a user in a channel. + | Server (ServerName a) + -- ^The message comes directly from the server. + deriving (Eq, Functor, Show) + +-- |A decoded IRC message. +data Message a = Privmsg (Target a) (Either CTCPByteString a) + -- ^A message, either from a user or to a channel the + -- client is in. CTCPs are distinguished by starting + -- and ending with a \\001 (SOH). + | Notice (Target a) (Either CTCPByteString a) + -- ^Like a privmsg, but should not provoke an automatic + -- response. + | Nick (NickName a) + -- ^Someone has updated their nick. + | Join (ChannelName a) + -- ^Someone has joined a channel. + | Part (ChannelName a) (Reason a) + -- ^Someone has left a channel. + | Quit (Reason a) + -- ^Someone has left the network. + | Mode (Target a) IsModeSet [ModeFlag a] [ModeArg a] + -- ^Someone has set some channel modes or user modes. + | Topic (ChannelName a) a + -- ^Someone has set the topic of a channel. + | Invite (ChannelName a) (NickName a) + -- ^The client has been invited to a channel. + | Kick (ChannelName a) (NickName a) (Reason a) + -- ^Someone has been kicked from a channel. + | Ping (ServerName a) (Maybe (ServerName a)) + -- ^The client has received a server ping, and should + -- send a pong asap. + | Pong (ServerName a) + -- ^A pong sent to the named server. + | Numeric Int [NumericArg a] + -- ^One of the many server numeric responses. + | RawMsg a + -- ^Never produced by decoding, but can be used to send + -- arbitrary bytestrings to the IRC server. Naturally, + -- this should only be used when you are confident that + -- the produced bytestring will be a valid IRC message. + deriving (Eq, Functor, Show) + +-- *Decoding messages + +fromByteString :: ByteString -> Either ByteString IrcEvent +fromByteString bs = maybe (Left bs) (Right . uncurry (Event bs)) (attemptDecode bs) + +-- |Attempt to decode a ByteString into a message, returning a Nothing +-- if either the source or the message can't be determined. +attemptDecode :: ByteString -> Maybe (IrcSource, IrcMessage) +attemptDecode bs = I.decode bs >>= decode' + where + decode' msg = case msg of + -- Disambiguate PRIVMSG and NOTICE source by checking the first + -- character of the target + I.Message (Just (I.NickName n _ _)) "PRIVMSG" [t, m] | isChan t -> Just (Channel t n, privmsg t m) + | otherwise -> Just (User n, privmsg t m) + + I.Message (Just (I.NickName n _ _)) "NOTICE" [t, m] | isChan t -> Just (Channel t n, notice t m) + | otherwise -> Just (User n, notice t m) + + I.Message (Just (I.NickName n _ _)) "NICK" [n'] -> Just (User n, Nick n') + I.Message (Just (I.NickName n _ _)) "JOIN" [c] -> Just (Channel c n, Join c) + I.Message (Just (I.NickName n _ _)) "PART" (c:r) -> Just (Channel c n, Part c $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "QUIT" r -> Just (User n, Quit $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "KICK" (c:u:r) -> Just (Channel c n, Kick c u $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "INVITE" [_, c] -> Just (User n, Invite c n) + I.Message (Just (I.NickName n _ _)) "TOPIC" [c, t] -> Just (Channel c n, Topic c t) + + I.Message (Just (I.NickName n _ _)) "MODE" (t:fs:as) | n == t -> (User n,) <$> mode t fs as + | otherwise -> (Channel t n,) <$> mode t fs as + + I.Message (Just (I.Server s)) "PING" (s1:s2) -> Just (Server s, Ping s1 $ listToMaybe s2) + I.Message Nothing "PING" (s1:s2) -> Just (Server s1, Ping s1 $ listToMaybe s2) + + I.Message (Just (I.Server s)) n args | isNumeric n -> (Server s,) <$> numeric n args + + _ -> Nothing + + -- An IRC channel name can start with '#', '&', '+', or '!', all + -- of which have different meanings. However, most servers only + -- support '#'. + isChan t = B.take 1 t `elem` ["#", "&", "+", "!"] + + -- Check if the message looks like a ctcp or not, and produce the appropriate message type. + privmsg t = Privmsg t . (Right `orCTCP` Left) + notice t = Notice t . (Right `orCTCP` Left) + + -- Decode a set of mode changes + mode t fs as = case unpack fs of + (f:fs') | f == fromIntegral (ord '+') -> Just $ Mode t True (map singleton fs') as + | f == fromIntegral (ord '-') -> Just $ Mode t False (map singleton fs') as + _ -> Nothing + + -- Parse the number in a numeric response + isNumeric = isJust . (readMaybe :: String -> Maybe Int) . B8.unpack + numeric n args = flip Numeric args <$> readMaybe (B8.unpack n) + +-- *Encoding messages + +-- |Encode an IRC message into a single bytestring suitable for +-- sending to the server. +toByteString :: IrcMessage -> ByteString +toByteString (Privmsg t (Left ctcpbs)) = mkMessage "PRIVMSG" [t, getUnderlyingByteString ctcpbs] +toByteString (Privmsg t (Right bs)) = mkMessage "PRIVMSG" [t, bs] +toByteString (Notice t (Left ctcpbs)) = mkMessage "NOTICE" [t, getUnderlyingByteString ctcpbs] +toByteString (Notice t (Right bs)) = mkMessage "NOTICE" [t, bs] +toByteString (Nick n) = mkMessage "NICK" [n] +toByteString (Join c) = mkMessage "JOIN" [c] +toByteString (Part c (Just r)) = mkMessage "PART" [c, r] +toByteString (Part c Nothing) = mkMessage "PART" [c] +toByteString (Quit (Just r)) = mkMessage "QUIT" [r] +toByteString (Quit Nothing) = mkMessage "QUIT" [] +toByteString (Mode t True ms as) = mkMessage "MODE" $ t : ("+" <> B.concat ms) : as +toByteString (Mode t False ms as) = mkMessage "MODE" $ t : ("-" <> B.concat ms) : as +toByteString (Invite c n) = mkMessage "INVITE" [c, n] +toByteString (Topic c bs) = mkMessage "TOPIC" [c, bs] +toByteString (Kick c n (Just r)) = mkMessage "KICK" [c, n, r] +toByteString (Kick c n Nothing) = mkMessage "KICK" [c, n] +toByteString (Ping s1 (Just s2)) = mkMessage "PING" [s1, s2] +toByteString (Ping s1 Nothing) = mkMessage "PING" [s1] +toByteString (Pong s) = mkMessage "PONG" [s] +toByteString (Numeric n as) = mkMessage (fromString $ show n) as +toByteString (RawMsg bs) = bs + +mkMessage :: ByteString -> [ByteString] -> ByteString +mkMessage cmd = I.encode . I.Message Nothing cmd + +-- |Construct a raw message. +rawMessage :: ByteString + -- ^The command + -> [ByteString] + -- ^The arguments + -> IrcMessage +rawMessage cmd = RawMsg . mkMessage cmd diff --git a/deps/irc-conduit/Network/IRC/Conduit/Lens.hs b/deps/irc-conduit/Network/IRC/Conduit/Lens.hs new file mode 100644 index 0000000..deb4ae1 --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit/Lens.hs @@ -0,0 +1,157 @@ +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : portable +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Conduit.Lens where + +import Data.ByteString (ByteString) +import Data.Profunctor (Choice(right'), + Profunctor(dimap)) + +import Network.IRC.Conduit.Internal +import Network.IRC.CTCP (CTCPByteString) + +-- * Lenses for 'Event' + +-- | 'Lens' for '_raw'. +raw :: Lens' (Event a) ByteString +{-# INLINE raw #-} +raw afb s = (\b -> s { _raw = b }) <$> afb (_raw s) + +-- | 'Lens' for '_source'. +source :: Lens' (Event a) (Source a) +{-# INLINE source #-} +source afb s = (\b -> s { _source = b }) <$> afb (_source s) + +-- | 'Lens' for '_message'. +message :: Lens' (Event a) (Message a) +{-# INLINE message #-} +message afb s = (\b -> s { _message = b }) <$> afb (_message s) + +-- * Prisms for 'Source' + +-- | 'Prism' for 'User' +_User :: Prism' (Source a) (NickName a) +{-# INLINE _User #-} +_User = dimap + (\s -> case s of User n -> Right n; _ -> Left s) + (either pure $ fmap User) . right' + +-- | 'Prism' for 'Channel' +_Channel :: Prism' (Source a) (ChannelName a, NickName a) +{-# INLINE _Channel #-} +_Channel = dimap + (\s -> case s of Channel c n -> Right (c,n); _ -> Left s) + (either pure $ fmap (uncurry Channel)) . right' + +-- | 'Prism' for 'Server' +_Server :: Prism' (Source a) (ServerName a) +{-# INLINE _Server #-} +_Server = dimap + (\s -> case s of Server n -> Right n; _ -> Left s) + (either pure $ fmap Server) . right' + +-- * Prisms for 'Message' + +-- | 'Prism' for 'Privmsg' +_Privmsg :: Prism' (Message a) (Target a, Either CTCPByteString a) +{-# INLINE _Privmsg #-} +_Privmsg = dimap + (\s -> case s of Privmsg t m -> Right (t,m); _ -> Left s) + (either pure $ fmap (uncurry Privmsg)) . right' + +-- | 'Prism' for 'Notice' +_Notice :: Prism' (Message a) (Target a, Either CTCPByteString a) +{-# INLINE _Notice #-} +_Notice = dimap + (\s -> case s of Notice t m -> Right (t,m); _ -> Left s) + (either pure $ fmap (uncurry Notice)) . right' + +-- | 'Prism' for 'Nick' +_Nick :: Prism' (Message a) (NickName a) +{-# INLINE _Nick #-} +_Nick = dimap + (\s -> case s of Nick n -> Right n; _ -> Left s) + (either pure $ fmap Nick) . right' + +-- | 'Prism' for 'Join' +_Join :: Prism' (Message a) (ChannelName a) +{-# INLINE _Join #-} +_Join = dimap + (\s -> case s of Join c -> Right c; _ -> Left s) + (either pure $ fmap Join) . right' + +-- | 'Prism' for 'Part' +_Part :: Prism' (Message a) (ChannelName a, Reason a) +{-# INLINE _Part #-} +_Part = dimap + (\s -> case s of Part c r -> Right (c,r); _ -> Left s) + (either pure $ fmap (uncurry Part)) . right' + +-- | 'Prism' for 'Quit' +_Quit :: Prism' (Message a) (Reason a) +{-# INLINE _Quit #-} +_Quit = dimap + (\s -> case s of Quit r -> Right r; _ -> Left s) + (either pure $ fmap Quit) . right' + +-- | 'Prism' for 'Mode' +_Mode :: Prism' (Message a) (Target a, IsModeSet, [ModeFlag a], [ModeArg a]) +{-# INLINE _Mode #-} +_Mode = dimap + (\s -> case s of Mode t i f a -> Right (t,i,f,a); _ -> Left s) + (either pure $ fmap (\(t,i,f,a) -> Mode t i f a)) . right' + +-- | 'Prism' for 'Topic' +_Topic :: Prism' (Message a) (ChannelName a, a) +{-# INLINE _Topic #-} +_Topic = dimap + (\s -> case s of Topic c t -> Right (c,t); _ -> Left s) + (either pure $ fmap (uncurry Topic)) . right' + +-- | 'Prism' for 'Invite' +_Invite :: Prism' (Message a) (ChannelName a, NickName a) +{-# INLINE _Invite #-} +_Invite = dimap + (\s -> case s of Invite c n -> Right (c,n); _ -> Left s) + (either pure $ fmap (uncurry Invite)) . right' + +-- | 'Prism' for 'Kick' +_Kick :: Prism' (Message a) (ChannelName a, NickName a, Reason a) +{-# INLINE _Kick #-} +_Kick = dimap + (\s -> case s of Kick c n r -> Right (c,n,r); _ -> Left s) + (either pure $ fmap (\(c,n,r) -> Kick c n r)) . right' + +-- | 'Prism' for 'Ping' +_Ping :: Prism' (Message a) (ServerName a, Maybe (ServerName a)) +{-# INLINE _Ping #-} +_Ping = dimap + (\s -> case s of Ping x y -> Right (x,y); _ -> Left s) + (either pure $ fmap (uncurry Ping)) . right' + +-- | 'Prism' for 'Pong' +_Pong :: Prism' (Message a) (ServerName a) +{-# INLINE _Pong #-} +_Pong = dimap + (\s -> case s of Pong x -> Right x; _ -> Left s) + (either pure $ fmap Pong) . right' + +-- | 'Prism' for 'Numeric' +_Numeric :: Prism' (Message a) (Int, [NumericArg a]) +{-# INLINE _Numeric #-} +_Numeric = dimap + (\s -> case s of Numeric n a -> Right (n,a); _ -> Left s) + (either pure $ fmap (uncurry Numeric)) . right' + +-- | 'Prism' for 'RawMsg' +_RawMsg :: Prism' (Message a) a +{-# INLINE _RawMsg #-} +_RawMsg = dimap + (\s -> case s of RawMsg a -> Right a; _ -> Left s) + (either pure $ fmap RawMsg) . right' diff --git a/deps/irc-conduit/README.markdown b/deps/irc-conduit/README.markdown new file mode 100644 index 0000000..73b61a0 --- /dev/null +++ b/deps/irc-conduit/README.markdown @@ -0,0 +1,40 @@ +**This project is essentially abandonware!** + +I may respond to minor issues, like version bounds which need +changing, but I won't be doing any significant work. + +Offer to take over the package if you want any significant changes. + +[irc-conduit][] +============ + +Streaming IRC message library using conduits. + + - Provides [conduits][conduit] for translating bytestrings into + "events", and "messages" into bytestrings. + + - Provides a sum type for all IRC messages you're likely to want to + deal with in a client. + + - Provides two helper functions for connecting to IRC servers + directly. + + - Manages flood protection when connecting to a server directly. + +Note +---- + +This used to be a part of [yukibot][], so if you want the history from +before this was split out into its own library, check there. + +Contributing +------------ + +Bug reports, pull requests, and comments are very welcome! + +Feel free to contact me on GitHub, through IRC (#haskell on +libera.chat), or email (mike@barrucadu.co.uk). + +[irc-conduit]: http://hackage.haskell.org/package/irc-conduit +[conduit]: https://hackage.haskell.org/package/conduit +[yukibot]: https://github.com/barrucadu/yukibot diff --git a/deps/irc-conduit/Setup.hs b/deps/irc-conduit/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/deps/irc-conduit/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deps/irc-conduit/concourse/pipeline.yml b/deps/irc-conduit/concourse/pipeline.yml new file mode 100644 index 0000000..3298cb2 --- /dev/null +++ b/deps/irc-conduit/concourse/pipeline.yml @@ -0,0 +1,121 @@ +############################################################################### +## Tasks + +x-generic-task: &generic-task + platform: linux + image_resource: + type: docker-image + source: + repository: haskell + inputs: + - name: source-git + +x-task-build-and-test: &task-build-and-test + <<: *generic-task + run: + dir: source-git + path: sh + args: + - -cxe + - | + export LANG=C.UTF-8 + stack="stack --no-terminal" + + if [ -f ../stackage-feed/item ]; then + apt-get update && apt-get install -y jq + resolver="$(jq -r .id < ../stackage-feed/item | cut -d/ -f4)" + $stack init --resolver="$resolver" --force + fi + + $stack setup --install-ghc + $stack build + +############################################################################### +## Pipeline + +resource_types: + - name: feed-resource + type: docker-image + source: + repository: registry.barrucadu.dev/feed-resource + username: registry + password: ((docker-registry-password)) + +resources: + - name: stackage-feed + type: feed-resource + source: + uri: https://www.stackage.org/feed + - name: irc-conduit-git + type: git + source: + uri: https://github.com/barrucadu/irc-conduit.git + - name: irc-conduit-cabal-git + type: git + source: + uri: https://github.com/barrucadu/irc-conduit.git + paths: + - irc-conduit.cabal + +jobs: + - name: update-pipeline + plan: + - get: irc-conduit-git + trigger: true + - set_pipeline: irc-conduit + file: irc-conduit-git/concourse/pipeline.yml + + - name: test-snapshot + plan: + - get: irc-conduit-git + trigger: true + - get: stackage-feed + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-conduit-git + config: + <<: *task-build-and-test + inputs: + - name: stackage-feed + - name: source-git + + - name: test + plan: + - get: irc-conduit-cabal-git + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-conduit-cabal-git + config: + <<: *task-build-and-test + + - name: release + plan: + - get: irc-conduit-cabal-git + trigger: true + passed: + - test + - task: release + input_mapping: + source-git: irc-conduit-cabal-git + config: + <<: *generic-task + params: + HACKAGE_USERNAME: barrucadu + HACKAGE_PASSWORD: ((hackage-password)) + run: + dir: source-git + path: sh + args: + - -cxe + - | + ver=$(grep '^version:' irc-conduit.cabal | sed 's/^version: *//') + + if curl -fs "http://hackage.haskell.org/package/irc-conduit-${ver}" >/dev/null; then + echo "version already exists on hackage" >&2 + exit 0 + fi + + stack --no-terminal setup --install-ghc + echo n | stack --no-terminal upload . diff --git a/deps/irc-conduit/irc-conduit.cabal b/deps/irc-conduit/irc-conduit.cabal new file mode 100644 index 0000000..be71788 --- /dev/null +++ b/deps/irc-conduit/irc-conduit.cabal @@ -0,0 +1,111 @@ +-- Initial irc-conduit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: irc-conduit + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.3.0.6 + +-- A short (one-line) description of the package. +synopsis: Streaming IRC message library using conduits. + +-- A longer description of the package. +description: + IRC messages consist of an optional identifying prefix, a command + name, and a list of arguments. The + package provides a low-level decoding and encoding scheme for + messages in terms of ByteStrings, but using this relies on matching + names of commands as strings, and unpacking this decoded structure + yourself. This package takes it a little further, providing an ADT + for IRC messages and sources, and conduits which attempt to decode + and encode messages appropriately. + . + In addition to providing conduits for automatically handling + streaming messages, there are also helper functions for connecting + to an IRC server and hooking up conduits to the socket. + +-- URL for the project homepage or repository. +homepage: https://github.com/barrucadu/irc-conduit + +-- URL where users should direct bug reports. +bug-reports: https://github.com/barrucadu/irc-conduit/issues + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael Walker + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: mike@barrucadu.co.uk + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Network.IRC.Conduit + , Network.IRC.Conduit.Internal + , Network.IRC.Conduit.Lens + + -- Modules included in this library but not exported. + -- other-modules: + + ghc-options: -Wall + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + , async + , bytestring + , conduit + , conduit-extra + , connection + , irc + , irc-ctcp + , network-conduit-tls + , profunctors + , text + , time + , tls + , transformers + , x509-validation + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/barrucadu/irc-conduit.git + +source-repository this + type: git + location: https://github.com/barrucadu/irc-conduit.git + tag: 0.3.0.6 diff --git a/deps/irc-conduit/stack.yaml b/deps/irc-conduit/stack.yaml new file mode 100644 index 0000000..ca42daf --- /dev/null +++ b/deps/irc-conduit/stack.yaml @@ -0,0 +1,7 @@ +flags: {} +packages: +- '.' +resolver: lts-20.0 +nix: + enable: false + packages: [zlib] -- cgit v1.2.3