diff options
Diffstat (limited to 'vendor')
| -rw-r--r-- | vendor/connection/CHANGELOG.md | 7 | ||||
| -rw-r--r-- | vendor/connection/LICENSE | 27 | ||||
| -rw-r--r-- | vendor/connection/Network/Connection.hs | 428 | ||||
| -rw-r--r-- | vendor/connection/Network/Connection/Types.hs | 100 | ||||
| -rw-r--r-- | vendor/connection/README.md | 83 | ||||
| -rw-r--r-- | vendor/connection/Setup.hs | 2 | ||||
| -rw-r--r-- | vendor/connection/connection.cabal | 44 | ||||
| -rw-r--r-- | vendor/irc-client/irc-client.cabal | 16 | ||||
| -rw-r--r-- | vendor/irc-conduit/LICENSE | 20 | ||||
| -rw-r--r-- | vendor/irc-conduit/Network/IRC/Conduit.hs | 230 | ||||
| -rw-r--r-- | vendor/irc-conduit/Network/IRC/Conduit/Internal.hs | 257 | ||||
| -rw-r--r-- | vendor/irc-conduit/Network/IRC/Conduit/Lens.hs | 157 | ||||
| -rw-r--r-- | vendor/irc-conduit/Setup.hs | 2 | ||||
| -rw-r--r-- | vendor/irc-conduit/irc-conduit.cabal | 111 |
14 files changed, 1476 insertions, 8 deletions
diff --git a/vendor/connection/CHANGELOG.md b/vendor/connection/CHANGELOG.md new file mode 100644 index 0000000..727eb09 --- /dev/null +++ b/vendor/connection/CHANGELOG.md @@ -0,0 +1,7 @@ +## Version 0.2.1 (16 April 2014) + +- Fix a difference between TLSSettings and TLSSettingsSimple, + where connection would override the connection hostname and port in + the simple case, but leave the field as is with TLSSettings. + TLSSettings can now be used properly as template, and will be + correctly overriden at the identification level only. diff --git a/vendor/connection/LICENSE b/vendor/connection/LICENSE new file mode 100644 index 0000000..8639f6e --- /dev/null +++ b/vendor/connection/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2012-2019 Vincent Hanquez <vincent@snarc.org> + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/vendor/connection/Network/Connection.hs b/vendor/connection/Network/Connection.hs new file mode 100644 index 0000000..1219ab7 --- /dev/null +++ b/vendor/connection/Network/Connection.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Network.Connection +-- License : BSD-style +-- Maintainer : Vincent Hanquez <vincent@snarc.org> +-- Stability : experimental +-- Portability : portable +-- +-- Simple connection abstraction +-- +module Network.Connection + ( + -- * Type for a connection + Connection + , connectionID + , ConnectionParams(..) + , TLSSettings(..) + , ProxySettings(..) + , SockSettings + + -- * Exceptions + , LineTooLong(..) + , HostNotResolved(..) + , HostCannotConnect(..) + + -- * Library initialization + , initConnectionContext + , ConnectionContext + + -- * Connection operation + , connectFromHandle + , connectFromSocket + , connectTo + , connectionClose + + -- * Sending and receiving data + , connectionGet + , connectionGetExact + , connectionGetChunk + , connectionGetChunk' + , connectionGetLine + , connectionWaitForInput + , connectionPut + + -- * TLS related operation + , connectionSetSecure + , connectionIsSecure + , connectionSessionManager + ) where + +import Control.Concurrent.MVar +import Control.Monad (join) +import qualified Control.Exception as E +import qualified System.IO.Error as E (mkIOError, eofErrorType) + +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS + +import System.X509 (getSystemCertificateStore) + +import Network.Socks5 (defaultSocksConf, socksConnectWithSocket, SocksAddress(..), SocksHostAddress(..)) +import Network.Socket +import qualified Network.Socket.ByteString as N + +import Data.Tuple (swap) +import Data.Default.Class +import Data.Data +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L + +import System.Environment +import System.Timeout +import System.IO +import qualified Data.Map as M + +import Network.Connection.Types + +type Manager = MVar (M.Map TLS.SessionID TLS.SessionData) + +-- | This is the exception raised if we reached the user specified limit for +-- the line in ConnectionGetLine. +data LineTooLong = LineTooLong deriving (Show,Typeable) + +-- | Exception raised when there's no resolution for a specific host +data HostNotResolved = HostNotResolved String deriving (Show,Typeable) + +-- | Exception raised when the connect failed +data HostCannotConnect = HostCannotConnect String [E.IOException] deriving (Show,Typeable) + +instance E.Exception LineTooLong +instance E.Exception HostNotResolved +instance E.Exception HostCannotConnect + +connectionSessionManager :: Manager -> TLS.SessionManager +connectionSessionManager mvar = TLS.noSessionManager + { TLS.sessionResume = \sessionID -> withMVar mvar (return . M.lookup sessionID) + , TLS.sessionEstablish = \sessionID sessionData -> do + modifyMVar_ mvar (return . M.insert sessionID sessionData) + return Nothing + , TLS.sessionInvalidate = \sessionID -> modifyMVar_ mvar (return . M.delete sessionID) +#if MIN_VERSION_tls(1,5,0) + , TLS.sessionResumeOnlyOnce = \sessionID -> + modifyMVar mvar (pure . swap . M.updateLookupWithKey (\_ _ -> Nothing) sessionID) +#endif + } + +-- | Initialize the library with shared parameters between connection. +initConnectionContext :: IO ConnectionContext +initConnectionContext = ConnectionContext <$> getSystemCertificateStore + +-- | Create a final TLS 'ClientParams' according to the destination and the +-- TLSSettings. +makeTLSParams :: ConnectionContext -> ConnectionID -> TLSSettings -> TLS.ClientParams +makeTLSParams cg cid ts@(TLSSettingsSimple {}) = + (TLS.defaultParamsClient (fst cid) portString) + { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } + , TLS.clientShared = def + { TLS.sharedCAStore = globalCertificateStore cg + , TLS.sharedValidationCache = validationCache + -- , TLS.sharedSessionManager = connectionSessionManager + } + } + where validationCache + | settingDisableCertificateValidation ts = + TLS.ValidationCache (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + | otherwise = def + portString = BC.pack $ show $ snd cid +makeTLSParams _ cid (TLSSettings p) = + p { TLS.clientServerIdentification = (fst cid, portString) } + where portString = BC.pack $ show $ snd cid + +withBackend :: (ConnectionBackend -> IO a) -> Connection -> IO a +withBackend f conn = readMVar (connectionBackend conn) >>= f + +connectionNew :: ConnectionID -> ConnectionBackend -> IO Connection +connectionNew cid backend = + Connection <$> newMVar backend + <*> newMVar (Just B.empty) + <*> pure cid + +-- | Use an already established handle to create a connection object. +-- +-- if the TLS Settings is set, it will do the handshake with the server. +-- The SOCKS settings have no impact here, as the handle is already established +connectFromHandle :: ConnectionContext + -> Handle + -> ConnectionParams + -> IO Connection +connectFromHandle cg h p = withSecurity (connectionUseSecure p) + where withSecurity Nothing = connectionNew cid $ ConnectionStream h + withSecurity (Just tlsSettings) = tlsEstablish h (makeTLSParams cg cid tlsSettings) >>= connectionNew cid . ConnectionTLS + cid = (connectionHostname p, connectionPort p) + +-- | Use an already established handle to create a connection object. +-- +-- if the TLS Settings is set, it will do the handshake with the server. +-- The SOCKS settings have no impact here, as the handle is already established +connectFromSocket :: ConnectionContext + -> Socket + -> ConnectionParams + -> IO Connection +connectFromSocket cg sock p = withSecurity (connectionUseSecure p) + where withSecurity Nothing = connectionNew cid $ ConnectionSocket sock + withSecurity (Just tlsSettings) = tlsEstablish sock (makeTLSParams cg cid tlsSettings) >>= connectionNew cid . ConnectionTLS + cid = (connectionHostname p, connectionPort p) + +-- | connect to a destination using the parameter +connectTo :: ConnectionContext -- ^ The global context of this connection. + -> ConnectionParams -- ^ The parameters for this connection (where to connect, and such). + -> IO Connection -- ^ The new established connection on success. +connectTo cg cParams = do + let conFct = doConnect (connectionUseSocks cParams) + (connectionHostname cParams) + (connectionPort cParams) + E.bracketOnError conFct (close . fst) $ \(h, _) -> + connectFromSocket cg h cParams + where + sockConnect sockHost sockPort h p = do + (sockServ, servAddr) <- resolve' sockHost sockPort + let sockConf = defaultSocksConf servAddr + let destAddr = SocksAddress (SocksAddrDomainName $ BC.pack h) p + (dest, _) <- socksConnectWithSocket sockServ sockConf destAddr + case dest of + SocksAddrIPV4 h4 -> return (sockServ, SockAddrInet p h4) + SocksAddrIPV6 h6 -> return (sockServ, SockAddrInet6 p 0 h6 0) + SocksAddrDomainName _ -> error "internal error: socks connect return a resolved address as domain name" + + + doConnect proxy h p = + case proxy of + Nothing -> resolve' h p + Just (OtherProxy proxyHost proxyPort) -> resolve' proxyHost proxyPort + Just (SockSettingsSimple sockHost sockPort) -> + sockConnect sockHost sockPort h p + Just (SockSettingsEnvironment envName) -> do + -- if we can't get the environment variable or that the string cannot be parsed + -- we connect directly. + let name = maybe "SOCKS_SERVER" id envName + evar <- E.try (getEnv name) + case evar of + Left (_ :: E.IOException) -> resolve' h p + Right var -> + case parseSocks var of + Nothing -> resolve' h p + Just (sockHost, sockPort) -> sockConnect sockHost sockPort h p + + -- Try to parse "host:port" or "host" + -- if port is ommited then the default SOCKS port (1080) is assumed + parseSocks :: String -> Maybe (String, PortNumber) + parseSocks s = + case break (== ':') s of + (sHost, "") -> Just (sHost, 1080) + (sHost, ':':portS) -> + case reads portS of + [(sPort,"")] -> Just (sHost, sPort) + _ -> Nothing + _ -> Nothing + + -- Try to resolve the host/port into an address (zero to many of them), then + -- try to connect from the first address to the last, returning the first one that + -- succeed + resolve' :: String -> PortNumber -> IO (Socket, SockAddr) + resolve' host port = do + let hints = defaultHints { addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream } + addrs <- getAddrInfo (Just hints) (Just host) (Just $ show port) + firstSuccessful $ map tryToConnect addrs + where + tryToConnect addr = + E.bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (close) + (\sock -> connect sock (addrAddress addr) >> return (sock, addrAddress addr)) + firstSuccessful = go [] + where + go :: [E.IOException] -> [IO a] -> IO a + go [] [] = E.throwIO $ HostNotResolved host + go l@(_:_) [] = E.throwIO $ HostCannotConnect host l + go acc (act:followingActs) = do + er <- E.try act + case er of + Left err -> go (err:acc) followingActs + Right r -> return r + +-- | Put a block of data in the connection. +connectionPut :: Connection -> ByteString -> IO () +connectionPut connection content = withBackend doWrite connection + where doWrite (ConnectionStream h) = B.hPut h content >> hFlush h + doWrite (ConnectionSocket s) = N.sendAll s content + doWrite (ConnectionTLS ctx) = TLS.sendData ctx $ L.fromChunks [content] + +-- | Get exact count of bytes from a connection. +-- +-- The size argument is the exact amount that must be returned to the user. +-- The call will wait until all data is available. Hence, it behaves like +-- 'B.hGet'. +-- +-- On end of input, 'connectionGetExact' will throw an 'E.isEOFError' +-- exception. +connectionGetExact :: Connection -> Int -> IO ByteString +connectionGetExact conn x = loop B.empty 0 + where loop bs y + | y == x = return bs + | otherwise = do + next <- connectionGet conn (x - y) + loop (B.append bs next) (y + (B.length next)) + +-- | Get some bytes from a connection. +-- +-- The size argument is just the maximum that could be returned to the user. +-- The call will return as soon as there's data, even if there's less +-- than requested. Hence, it behaves like 'B.hGetSome'. +-- +-- On end of input, 'connectionGet' returns 0, but subsequent calls will throw +-- an 'E.isEOFError' exception. +connectionGet :: Connection -> Int -> IO ByteString +connectionGet conn size + | size < 0 = fail "Network.Connection.connectionGet: size < 0" + | size == 0 = return B.empty + | otherwise = connectionGetChunkBase "connectionGet" conn $ B.splitAt size + +-- | Get the next block of data from the connection. +connectionGetChunk :: Connection -> IO ByteString +connectionGetChunk conn = + connectionGetChunkBase "connectionGetChunk" conn $ \s -> (s, B.empty) + +-- | Like 'connectionGetChunk', but return the unused portion to the buffer, +-- where it will be the next chunk read. +connectionGetChunk' :: Connection -> (ByteString -> (a, ByteString)) -> IO a +connectionGetChunk' = connectionGetChunkBase "connectionGetChunk'" + +-- | Wait for input to become available on a connection. +-- +-- As with 'hWaitForInput', the timeout value is given in milliseconds. If the +-- timeout value is less than zero, then 'connectionWaitForInput' waits +-- indefinitely. +-- +-- Unlike 'hWaitForInput', this function does not do any decoding, so it +-- returns true when there is /any/ available input, not just full characters. +connectionWaitForInput :: Connection -> Int -> IO Bool +connectionWaitForInput conn timeout_ms = maybe False (const True) <$> timeout timeout_ns tryGetChunk + where tryGetChunk = connectionGetChunkBase "connectionWaitForInput" conn $ \buf -> ((), buf) + timeout_ns = timeout_ms * 1000 + +connectionGetChunkBase :: String -> Connection -> (ByteString -> (a, ByteString)) -> IO a +connectionGetChunkBase loc conn f = + modifyMVar (connectionBuffer conn) $ \m -> + case m of + Nothing -> throwEOF conn loc + Just buf + | B.null buf -> do + chunk <- withBackend getMoreData conn + if B.null chunk + then closeBuf chunk + else updateBuf chunk + | otherwise -> + updateBuf buf + where + getMoreData (ConnectionTLS tlsctx) = TLS.recvData tlsctx + getMoreData (ConnectionSocket sock) = N.recv sock 1500 + getMoreData (ConnectionStream h) = B.hGetSome h (16 * 1024) + + updateBuf buf = case f buf of (a, !buf') -> return (Just buf', a) + closeBuf buf = case f buf of (a, _buf') -> return (Nothing, a) + +-- | Get the next line, using ASCII LF as the line terminator. +-- +-- This throws an 'isEOFError' exception on end of input, and LineTooLong when +-- the number of bytes gathered is over the limit without a line terminator. +-- +-- The actual line returned can be bigger than the limit specified, provided +-- that the last chunk returned by the underlaying backend contains a LF. +-- In another world only when we need more input and limit is reached that the +-- LineTooLong exception will be raised. +-- +-- An end of file will be considered as a line terminator too, if line is +-- not empty. +connectionGetLine :: Int -- ^ Maximum number of bytes before raising a LineTooLong exception + -> Connection -- ^ Connection + -> IO ByteString -- ^ The received line with the LF trimmed +connectionGetLine limit conn = more (throwEOF conn loc) 0 id + where + loc = "connectionGetLine" + lineTooLong = E.throwIO LineTooLong + + -- Accumulate chunks using a difference list, and concatenate them + -- when an end-of-line indicator is reached. + more eofK !currentSz !dl = + getChunk (\s -> let len = B.length s + in if currentSz + len > limit + then lineTooLong + else more eofK (currentSz + len) (dl . (s:))) + (\s -> done (dl . (s:))) + (done dl) + + done :: ([ByteString] -> [ByteString]) -> IO ByteString + done dl = return $! B.concat $ dl [] + + -- Get another chunk, and call one of the continuations + getChunk :: (ByteString -> IO r) -- moreK: need more input + -> (ByteString -> IO r) -- doneK: end of line (line terminator found) + -> IO r -- eofK: end of file + -> IO r + getChunk moreK doneK eofK = + join $ connectionGetChunkBase loc conn $ \s -> + if B.null s + then (eofK, B.empty) + else case B.break (== 10) s of + (a, b) + | B.null b -> (moreK a, B.empty) + | otherwise -> (doneK a, B.tail b) + +throwEOF :: Connection -> String -> IO a +throwEOF conn loc = + E.throwIO $ E.mkIOError E.eofErrorType loc' Nothing (Just path) + where + loc' = "Network.Connection." ++ loc + path = let (host, port) = connectionID conn + in host ++ ":" ++ show port + +-- | Close a connection. +connectionClose :: Connection -> IO () +connectionClose = withBackend backendClose + where backendClose (ConnectionTLS ctx) = ignoreIOExc (TLS.bye ctx) `E.finally` TLS.contextClose ctx + backendClose (ConnectionSocket sock) = close sock + backendClose (ConnectionStream h) = hClose h + + ignoreIOExc action = action `E.catch` \(_ :: E.IOException) -> return () + +-- | Activate secure layer using the parameters specified. +-- +-- This is typically used to negociate a TLS channel on an already +-- establish channel, e.g. supporting a STARTTLS command. it also +-- flush the received buffer to prevent application confusing +-- received data before and after the setSecure call. +-- +-- If the connection is already using TLS, nothing else happens. +connectionSetSecure :: ConnectionContext + -> Connection + -> TLSSettings + -> IO () +connectionSetSecure cg connection params = + modifyMVar_ (connectionBuffer connection) $ \b -> + modifyMVar (connectionBackend connection) $ \backend -> + case backend of + (ConnectionStream h) -> do ctx <- tlsEstablish h (makeTLSParams cg (connectionID connection) params) + return (ConnectionTLS ctx, Just B.empty) + (ConnectionSocket s) -> do ctx <- tlsEstablish s (makeTLSParams cg (connectionID connection) params) + return (ConnectionTLS ctx, Just B.empty) + (ConnectionTLS _) -> return (backend, b) + +-- | Returns if the connection is establish securely or not. +connectionIsSecure :: Connection -> IO Bool +connectionIsSecure conn = withBackend isSecure conn + where isSecure (ConnectionStream _) = return False + isSecure (ConnectionSocket _) = return False + isSecure (ConnectionTLS _) = return True + +tlsEstablish :: TLS.HasBackend backend => backend -> TLS.ClientParams -> IO TLS.Context +tlsEstablish handle tlsParams = do + ctx <- TLS.contextNew handle tlsParams + TLS.handshake ctx + return ctx diff --git a/vendor/connection/Network/Connection/Types.hs b/vendor/connection/Network/Connection/Types.hs new file mode 100644 index 0000000..f8fc725 --- /dev/null +++ b/vendor/connection/Network/Connection/Types.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Network.Connection.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez <vincent@snarc.org> +-- Stability : experimental +-- Portability : portable +-- +-- connection types +-- +module Network.Connection.Types + where + +import Control.Concurrent.MVar (MVar) + +import Data.Default.Class +import Data.X509.CertificateStore +import Data.ByteString (ByteString) + +import Network.Socket (PortNumber, Socket) +import qualified Network.TLS as TLS + +import System.IO (Handle) + +-- | Simple backend enumeration, either using a raw connection or a tls connection. +data ConnectionBackend = ConnectionStream Handle + | ConnectionSocket Socket + | ConnectionTLS TLS.Context + + +-- | Hostname This could either be a name string (punycode encoded) or an ipv4/ipv6 +type HostName = String + +-- | Connection Parameters to establish a Connection. +-- +-- The strict minimum is an hostname and the port. +-- +-- If you need to establish a TLS connection, you should make sure +-- connectionUseSecure is correctly set. +-- +-- If you need to connect through a SOCKS, you should make sure +-- connectionUseSocks is correctly set. +data ConnectionParams = ConnectionParams + { connectionHostname :: HostName -- ^ host name to connect to. + , connectionPort :: PortNumber -- ^ port number to connect to. + , connectionUseSecure :: Maybe TLSSettings -- ^ optional TLS parameters. + , connectionUseSocks :: Maybe ProxySettings -- ^ optional Proxy/Socks configuration. + } + +-- | Proxy settings for the connection. +-- +-- OtherProxy handles specific application-level proxies like HTTP proxies. +-- +-- The simple SOCKS settings is just the hostname and portnumber of the SOCKS proxy server. +-- +-- That's for now the only settings in the SOCKS package, +-- socks password, or any sort of other authentications is not yet implemented. +data ProxySettings = + SockSettingsSimple HostName PortNumber + | SockSettingsEnvironment (Maybe String) + | OtherProxy HostName PortNumber + +type SockSettings = ProxySettings + +-- | TLS Settings that can be either expressed as simple settings, +-- or as full blown TLS.Params settings. +-- +-- Unless you need access to parameters that are not accessible through the +-- simple settings, you should use TLSSettingsSimple. +data TLSSettings + = TLSSettingsSimple + { settingDisableCertificateValidation :: Bool -- ^ Disable certificate verification completely, + -- this make TLS/SSL vulnerable to a MITM attack. + -- not recommended to use, but for testing. + , settingDisableSession :: Bool -- ^ Disable session management. TLS/SSL connections + -- will always re-established their context. + -- Not Implemented Yet. + , settingUseServerName :: Bool -- ^ Use server name extension. Not Implemented Yet. + } -- ^ Simple TLS settings. recommended to use. + | TLSSettings TLS.ClientParams -- ^ full blown TLS Settings directly using TLS.Params. for power users. + deriving (Show) + +instance Default TLSSettings where + def = TLSSettingsSimple False False False + +type ConnectionID = (HostName, PortNumber) + +-- | This opaque type represent a connection to a destination. +data Connection = Connection + { connectionBackend :: MVar ConnectionBackend + , connectionBuffer :: MVar (Maybe ByteString) -- ^ this is set to 'Nothing' on EOF + , connectionID :: ConnectionID -- ^ return a simple tuple of the port and hostname that we're connected to. + } + +-- | Shared values (certificate store, sessions, ..) between connections +-- +-- At the moment, this is only strictly needed to shared sessions and certificates +-- when using a TLS enabled connection. +data ConnectionContext = ConnectionContext + { globalCertificateStore :: !CertificateStore + } diff --git a/vendor/connection/README.md b/vendor/connection/README.md new file mode 100644 index 0000000..1bc8340 --- /dev/null +++ b/vendor/connection/README.md @@ -0,0 +1,83 @@ +haskell Connection library +========================== + +Simple network library for all your connection need. + +Features: + +- Really simple to use +- SSL/TLS +- SOCKS + +Usage +----- + +Connect to www.example.com on port 4567 (without socks or tls), then send a +byte, receive a single byte, print it, and close the connection: +```haskell +import qualified Data.ByteString as B +import Network.Connection +import Data.Default + +main = do + ctx <- initConnectionContext + con <- connectTo ctx $ ConnectionParams + { connectionHostname = "www.example.com" + , connectionPort = 4567 + , connectionUseSecure = Nothing + , connectionUseSocks = Nothing + } + connectionPut con (B.singleton 0xa) + r <- connectionGet con 1 + putStrLn $ show r + connectionClose con +``` +Using a socks proxy is easy, we just need replacing the connectionSocks +parameter, for example connecting to the same host, but using a socks +proxy at localhost:1080: +```haskell +con <- connectTo ctx $ ConnectionParams + { connectionHostname = "www.example.com" + , connectionPort = 4567 + , connectionUseSecure = Nothing + , connectionUseSocks = Just $ SockSettingsSimple "localhost" 1080 + } +``` +Connecting to a SSL style socket is equally easy, and need to set the UseSecure fields in ConnectionParams: +```haskell +con <- connectTo ctx $ ConnectionParams + { connectionHostname = "www.example.com" + , connectionPort = 4567 + , connectionUseSecure = Just def + , connectionUseSocks = Nothing + } +``` +And finally, you can start TLS in the middle of an insecure connection. This is great for +protocol using STARTTLS (e.g. IMAP, SMTP): + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import Network.Connection +import Data.Default + +main = do + ctx <- initConnectionContext + con <- connectTo ctx $ ConnectionParams + { connectionHostname = "www.example.com" + , connectionPort = 4567 + , connectionUseSecure = Nothing + , connectionUseSocks = Nothing + } + -- talk to the other side with no TLS: says hello and starttls + connectionPut con "HELLO\n" + connectionPut con "STARTTLS\n" + + -- switch to TLS + connectionSetSecure ctx con def + + -- the connection is from now on using TLS, we can send secret for example + connectionPut con "PASSWORD 123\n" + connectionClose con +``` diff --git a/vendor/connection/Setup.hs b/vendor/connection/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/vendor/connection/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/vendor/connection/connection.cabal b/vendor/connection/connection.cabal new file mode 100644 index 0000000..f36f04c --- /dev/null +++ b/vendor/connection/connection.cabal @@ -0,0 +1,44 @@ +Name: connection
+Version: 0.3.1
+x-revision: 2
+Description:
+ Simple network library for all your connection need.
+ .
+ Features: Really simple to use, SSL/TLS, SOCKS.
+ .
+ This library provides a very simple api to create sockets
+ to a destination with the choice of SSL/TLS, and SOCKS.
+License: BSD3
+License-file: LICENSE
+Copyright: Vincent Hanquez <vincent@snarc.org>
+Author: Vincent Hanquez <vincent@snarc.org>
+Maintainer: Vincent Hanquez <vincent@snarc.org>
+Synopsis: Simple and easy network connections API
+Build-Type: Simple
+Category: Network
+stability: experimental
+Cabal-Version: >=1.8
+Homepage: https://github.com/vincenthz/hs-connection
+extra-source-files: README.md
+ CHANGELOG.md
+
+Library
+ Build-Depends: base >= 4.8 && < 5
+ , basement
+ , bytestring
+ , containers
+ , data-default-class
+ , network >= 2.6.3
+ , tls >= 1.4 && < 1.7
+ , socks >= 0.6
+ , crypton-x509 >= 1.5
+ , crypton-x509-store >= 1.5
+ , crypton-x509-system >= 1.5
+ , crypton-x509-validation >= 1.5
+ Exposed-modules: Network.Connection
+ Other-modules: Network.Connection.Types
+ ghc-options: -Wall
+
+source-repository head
+ type: git
+ location: https://github.com/vincenthz/hs-connection
diff --git a/vendor/irc-client/irc-client.cabal b/vendor/irc-client/irc-client.cabal index 490665b..5720fa4 100644 --- a/vendor/irc-client/irc-client.cabal +++ b/vendor/irc-client/irc-client.cabal @@ -87,7 +87,7 @@ library -- Other library packages from which modules are imported. build-depends: base >=4.7 && <5 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , containers >=0.1 && <1 , conduit >=1.2.8 && <1.4 , connection >=0.2 && <0.4 @@ -95,19 +95,19 @@ library , exceptions >=0.6 && <0.11 , irc-conduit >=0.3 && <0.4 , irc-ctcp >=0.1.2 && <0.2 - , mtl >=2.1 && <2.3 + , mtl >=2.1 && <2.4 , network-conduit-tls >=1.1 && <1.4 , old-locale >=1.0 && <1.1 , profunctors >=5 && <6 , stm >=2.4 && <2.6 , stm-chans >=2.0 && <3.1 - , text >=1.1 && <1.3 + , text >=1.1 && <2.2 , time >=1.4 && <2 - , tls >=1.3 && <1.6 - , transformers >=0.3 && <0.6 - , x509 >=1.6 && <1.8 - , x509-store >=1.6 && <1.7 - , x509-validation >=1.6 && <1.7 + , tls >=1.3 && <2.5 + , transformers >=0.3 && <0.7 + , crypton-x509 >=1.6 + , crypton-x509-store >=1.6 + , crypton-x509-validation >=1.6 -- Directories containing source files. -- hs-source-dirs: diff --git a/vendor/irc-conduit/LICENSE b/vendor/irc-conduit/LICENSE new file mode 100644 index 0000000..03c030a --- /dev/null +++ b/vendor/irc-conduit/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014, Michael Walker <mike@barrucadu.co.uk> + +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/vendor/irc-conduit/Network/IRC/Conduit.hs b/vendor/irc-conduit/Network/IRC/Conduit.hs new file mode 100644 index 0000000..1185749 --- /dev/null +++ b/vendor/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 <mike@barrucadu.co.uk> +-- 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/vendor/irc-conduit/Network/IRC/Conduit/Internal.hs b/vendor/irc-conduit/Network/IRC/Conduit/Internal.hs new file mode 100644 index 0000000..3b9eabf --- /dev/null +++ b/vendor/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 <mike@barrucadu.co.uk> +-- 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 @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'. +type Prism' s a = Prism s s a a + + +-- *Conduits + +-- |Split up incoming bytestrings into new lines. +chunked :: Monad m => 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/vendor/irc-conduit/Network/IRC/Conduit/Lens.hs b/vendor/irc-conduit/Network/IRC/Conduit/Lens.hs new file mode 100644 index 0000000..deb4ae1 --- /dev/null +++ b/vendor/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 <mike@barrucadu.co.uk> +-- 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/vendor/irc-conduit/Setup.hs b/vendor/irc-conduit/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/vendor/irc-conduit/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/vendor/irc-conduit/irc-conduit.cabal b/vendor/irc-conduit/irc-conduit.cabal new file mode 100644 index 0000000..54bc352 --- /dev/null +++ b/vendor/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 <http://hackage.haskell.org/package/irc irc> + package provides a low-level decoding and encoding scheme for + messages in terms of ByteStrings, but using this relies on matching + names of commands as strings, and unpacking this decoded structure + yourself. This package takes it a little further, providing an ADT + for IRC messages and sources, and conduits which attempt to decode + and encode messages appropriately. + . + In addition to providing conduits for automatically handling + streaming messages, there are also helper functions for connecting + to an IRC server and hooking up conduits to the socket. + +-- URL for the project homepage or repository. +homepage: https://github.com/barrucadu/irc-conduit + +-- URL where users should direct bug reports. +bug-reports: https://github.com/barrucadu/irc-conduit/issues + +-- The license under which the package is released. +license: 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 >=4.8 && <5 + , async >=2.0 && <2.3 + , bytestring >=0.10 && <0.12 + , conduit >=1.2.8 && <1.4 + , conduit-extra >=1.1 && <1.4 + , connection >=0.2 && <0.4 + , irc >=0.6 && <0.7 + , irc-ctcp >=0.1.1 && <0.2 + , network-conduit-tls >=1.1 && <1.4 + , profunctors >=5 && <6 + , text >=1.0 && <1.3 + , time >=1.4 && <2 + , tls >=1.3 && <1.6 + , transformers >=0.3 && <0.6 + , crypton-x509-validation >=1.6 + + -- 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 |