diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012 Vincent Hanquez +Copyright (c) 2012-2019 Vincent Hanquez All rights reserved. diff --git a/Network/Connection.hs b/Network/Connection.hs --- a/Network/Connection.hs +++ b/Network/Connection.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,6 +23,8 @@ -- * Exceptions , LineTooLong(..) + , HostNotResolved(..) + , HostCannotConnect(..) -- * Library initialization , initConnectionContext @@ -29,22 +32,25 @@ -- * 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.Applicative import Control.Concurrent.MVar import Control.Monad (join) import qualified Control.Exception as E @@ -55,9 +61,11 @@ import System.X509 (getSystemCertificateStore) -import Network.Socks5 -import qualified Network as N +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) @@ -65,9 +73,8 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L -import qualified Crypto.Random.AESCtr as RNG - import System.Environment +import System.Timeout import System.IO import qualified Data.Map as M @@ -79,7 +86,15 @@ -- 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.SessionManager @@ -87,6 +102,10 @@ , TLS.sessionEstablish = \sessionID sessionData -> modifyMVar_ mvar (return . M.insert sessionID sessionData) , 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. @@ -98,7 +117,7 @@ makeTLSParams :: ConnectionContext -> ConnectionID -> TLSSettings -> TLS.ClientParams makeTLSParams cg cid ts@(TLSSettingsSimple {}) = (TLS.defaultParamsClient (fst cid) portString) - { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_all } + { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } , TLS.clientShared = def { TLS.sharedCAStore = globalCertificateStore cg , TLS.sharedValidationCache = validationCache @@ -137,46 +156,119 @@ 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 - conFct <- getConFct (connectionUseSocks cParams) - h <- conFct (connectionHostname cParams) (N.PortNumber $ connectionPort cParams) - connectFromHandle cg h cParams + let conFct = doConnect (connectionUseSocks cParams) + (connectionHostname cParams) + (connectionPort cParams) + E.bracketOnError conFct (close . fst) $ \(h, _) -> + connectFromSocket cg h cParams where - getConFct Nothing = return N.connectTo - getConFct (Just (OtherProxy h p)) = return $ \_ _ -> N.connectTo h (N.PortNumber p) - getConFct (Just (SockSettingsSimple h p)) = return $ socksConnectTo h (N.PortNumber p) - getConFct (Just (SockSettingsEnvironment v)) = do - -- if we can't get the environment variable or that the variable cannot be parsed - -- we connect directly. - let name = maybe "SOCKS_SERVER" id v - evar <- E.try (getEnv name) - case evar of - Left (_ :: E.IOException) -> return N.connectTo - Right var -> - case parseSocks var of - Nothing -> return N.connectTo - Just (sHost, sPort) -> return $ socksConnectTo sHost (N.PortNumber $ fromIntegral (sPort :: Int)) + 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" - -- Try to parse "host:port" or "host" - parseSocks s = - case break (== ':') s of - (sHost, "") -> Just (sHost, 1080) - (sHost, ':':portS) -> - case reads portS of - [(sPort,"")] -> Just (sHost, sPort) - _ -> Nothing - _ -> Nothing + 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. @@ -201,6 +293,19 @@ 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 -> @@ -216,6 +321,7 @@ 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) @@ -263,7 +369,7 @@ join $ connectionGetChunkBase loc conn $ \s -> if B.null s then (eofK, B.empty) - else case B.breakByte 10 s of + else case B.break (== 10) s of (a, b) | B.null b -> (moreK a, B.empty) | otherwise -> (doneK a, B.tail b) @@ -279,9 +385,12 @@ -- | Close a connection. connectionClose :: Connection -> IO () connectionClose = withBackend backendClose - where backendClose (ConnectionTLS ctx) = TLS.bye ctx >> TLS.contextClose ctx + 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 @@ -300,17 +409,19 @@ 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 :: Handle -> TLS.ClientParams -> IO TLS.Context +tlsEstablish :: TLS.HasBackend backend => backend -> TLS.ClientParams -> IO TLS.Context tlsEstablish handle tlsParams = do - rng <- RNG.makeSystem - ctx <- TLS.contextNew handle tlsParams rng + ctx <- TLS.contextNew handle tlsParams TLS.handshake ctx return ctx diff --git a/Network/Connection/Types.hs b/Network/Connection/Types.hs --- a/Network/Connection/Types.hs +++ b/Network/Connection/Types.hs @@ -16,15 +16,19 @@ import Data.X509.CertificateStore import Data.ByteString (ByteString) -import Network.BSD (HostName) -import Network.Socket (PortNumber) +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. -- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,68 +14,70 @@ 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: - - 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 +```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: - - con <- connectTo ctx $ ConnectionParams - { connectionHostname = "www.example.com" - , connectionPort = 4567 - , connectionUseSecure = Nothing - , connectionUseSocks = Just $ SockSettingsSimple "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: - - con <- connectTo ctx $ ConnectionParams - { connectionHostname = "www.example.com" - , connectionPort = 4567 - , connectionUseSecure = Just def - , connectionUseSocks = Nothing - } - +```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): - {-# LANGUAGE OverloadedStrings #-} - import qualified Data.ByteString as B - import Data.ByteString.Char8 () - import Network.Connection - import Data.Default +```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" +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 + -- 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 + -- the connection is from now on using TLS, we can send secret for example + connectionPut con "PASSWORD 123\n" + connectionClose con +``` diff --git a/connection.cabal b/connection.cabal --- a/connection.cabal +++ b/connection.cabal @@ -1,5 +1,5 @@ Name: connection -Version: 0.2.3 +Version: 0.3.1 Description: Simple network library for all your connection need. . @@ -17,22 +17,22 @@ Category: Network stability: experimental Cabal-Version: >=1.6 -Homepage: http://github.com/vincenthz/hs-connection +Homepage: https://github.com/vincenthz/hs-connection extra-source-files: README.md CHANGELOG.md Library Build-Depends: base >= 3 && < 5 + , basement , bytestring , containers , data-default-class - , network >= 2.3 - , tls >= 1.2 - , cprng-aes - , socks >= 0.4 - , x509 >= 1.4 - , x509-store >= 1.4 - , x509-system >= 1.4 + , network >= 2.6.3 + , tls >= 1.4 + , socks >= 0.6 + , x509 >= 1.5 + , x509-store >= 1.5 + , x509-system >= 1.5 , x509-validation >= 1.5 Exposed-modules: Network.Connection Other-modules: Network.Connection.Types @@ -40,4 +40,4 @@ source-repository head type: git - location: git://github.com/vincenthz/hs-connection + location: https://github.com/vincenthz/hs-connection