├── .appveyor.yml ├── .gitignore ├── .haskell-ci ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── Network ├── Connection.hs └── Connection │ └── Types.hs ├── README.md ├── Setup.hs ├── connection.cabal ├── examples ├── SMTPConnection.hs ├── SimpleConnection.hs ├── SocksConnection.hs ├── StartTLSConnection.hs └── TLSConnection.hs └── stack.yaml /.appveyor.yml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 7d766e19289187f6b8031c4c65c12851bf5051c11e190c820f07fedf212d8b14 ~*~ 2 | 3 | version: "{build}" 4 | clone_folder: C:\project 5 | build: off 6 | cache: 7 | - "C:\\SR -> .appveyor.yml" 8 | 9 | environment: 10 | global: 11 | STACK_ROOT: "C:\\SR" 12 | matrix: 13 | - { BUILD: "ghc-8.6", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-13.5, packages: [ '.' ], extra-deps: [ socks-0.6.0 ], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" } 14 | 15 | matrix: 16 | fast_finish: true 17 | 18 | install: 19 | - set PATH=C:\Program Files\Git\mingw64\bin;%PATH% 20 | - curl -ostack.zip -L %STACKURL% 21 | - 7z x stack.zip stack.exe 22 | - refreshenv 23 | test_script: 24 | - echo %STACKCFG% > stack.yaml 25 | - stack setup > nul 26 | - echo "" | %STACKCMD% 27 | 28 | 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.o 3 | *.hi 4 | *.tix 5 | *.mix 6 | .stack-work/ 7 | -------------------------------------------------------------------------------- /.haskell-ci: -------------------------------------------------------------------------------- 1 | # compiler supported and their equivalent LTS 2 | #compiler: ghc-7.8 lts-2.22 3 | #compiler: ghc-7.10 lts-6.35 4 | #compiler: ghc-8.0 lts-9.21 5 | compiler: ghc-8.2 lts-11.22 6 | compiler: ghc-8.4 lts-12.14 7 | compiler: ghc-8.6 lts-13.5 8 | 9 | # gitdep: name location commit 10 | 11 | # options 12 | # option: alias x=y z=v 13 | 14 | # builds 15 | # recognized simple options: nohaddock allow-newer allowed-failure 16 | # recognized keys: tests=no benchs=no 17 | # kvs options: flag=pkg:flagname extradep=package-version gitdep=name 18 | build: ghc-8.6 os=linux,osx,windows extradep=socks-0.6.0 19 | build: ghc-8.4 extradep=socks-0.6.0 20 | build: ghc-8.2 extradep=socks-0.6.0 21 | #build: ghc-8.0 22 | 23 | # packages 24 | package: '.' 25 | 26 | # extra builds 27 | hlint: allowed-failure 28 | weeder: allowed-failure 29 | coverall: false 30 | 31 | # travis extra 32 | # travis-apt-addon: packagename 33 | # travis-tests: post-script 34 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 7d766e19289187f6b8031c4c65c12851bf5051c11e190c820f07fedf212d8b14 ~*~ 2 | 3 | # Use new container infrastructure to enable caching 4 | sudo: false 5 | 6 | # Caching so the next build will be fast too. 7 | cache: 8 | directories: 9 | - $HOME/.ghc 10 | - $HOME/.stack 11 | - $HOME/.local 12 | 13 | matrix: 14 | include: 15 | - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 16 | - { env: BUILD=stack RESOLVER=ghc-8.6, compiler: ghc-8.6, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx } 17 | - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 18 | - { env: BUILD=stack RESOLVER=ghc-8.2, compiler: ghc-8.2, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 19 | - { env: BUILD=hlint, compiler: hlint, language: generic } 20 | - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 21 | allow_failures: 22 | - { env: BUILD=hlint, compiler: hlint, language: generic } 23 | - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } } 24 | 25 | install: 26 | - export PATH=$HOME/.local/bin::$HOME/.cabal/bin:$PATH 27 | - mkdir -p ~/.local/bin 28 | - | 29 | case "$BUILD" in 30 | stack|weeder) 31 | if [ `uname` = "Darwin" ] 32 | then 33 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 34 | else 35 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 36 | fi 37 | ;; 38 | cabal) 39 | ;; 40 | esac 41 | 42 | script: 43 | - | 44 | set -ex 45 | if [ "x${RUNTEST}" = "xfalse" ]; then exit 0; fi 46 | case "$BUILD" in 47 | stack) 48 | # create the build stack.yaml 49 | case "$RESOLVER" in 50 | ghc-8.6) 51 | echo "{ resolver: lts-13.5, packages: [ '.' ], extra-deps: [ socks-0.6.0 ], flags: {} }" > stack.yaml 52 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 53 | ;; 54 | ghc-8.4) 55 | echo "{ resolver: lts-12.14, packages: [ '.' ], extra-deps: [ socks-0.6.0 ], flags: {} }" > stack.yaml 56 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 57 | ;; 58 | ghc-8.2) 59 | echo "{ resolver: lts-11.22, packages: [ '.' ], extra-deps: [ socks-0.6.0 ], flags: {} }" > stack.yaml 60 | stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps 61 | ;; 62 | esac 63 | ;; 64 | hlint) 65 | curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s . --cpp-define=__GLASGOW_HASKELL__=800 --cpp-define=x86_64_HOST_ARCH=1 --cpp-define=mingw32_HOST_OS=1 66 | ;; 67 | weeder) 68 | stack --no-terminal build --install-ghc 69 | curl -sL https://raw.github.com/ndmitchell/weeder/master/misc/travis.sh | sh -s . 70 | ;; 71 | esac 72 | set +ex 73 | 74 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## Version 0.2.1 (16 April 2014) 2 | 3 | - Fix a difference between TLSSettings and TLSSettingsSimple, 4 | where connection would override the connection hostname and port in 5 | the simple case, but leave the field as is with TLSSettings. 6 | TLSSettings can now be used properly as template, and will be 7 | correctly overriden at the identification level only. 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2019 Vincent Hanquez 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /Network/Connection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | -- | 6 | -- Module : Network.Connection 7 | -- License : BSD-style 8 | -- Maintainer : Vincent Hanquez 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Simple connection abstraction 13 | -- 14 | module Network.Connection 15 | ( 16 | -- * Type for a connection 17 | Connection 18 | , connectionID 19 | , ConnectionParams(..) 20 | , TLSSettings(..) 21 | , ProxySettings(..) 22 | , SockSettings 23 | 24 | -- * Exceptions 25 | , LineTooLong(..) 26 | , HostNotResolved(..) 27 | , HostCannotConnect(..) 28 | 29 | -- * Library initialization 30 | , initConnectionContext 31 | , ConnectionContext 32 | 33 | -- * Connection operation 34 | , connectFromHandle 35 | , connectFromSocket 36 | , connectTo 37 | , connectionClose 38 | 39 | -- * Sending and receiving data 40 | , connectionGet 41 | , connectionGetExact 42 | , connectionGetChunk 43 | , connectionGetChunk' 44 | , connectionGetLine 45 | , connectionWaitForInput 46 | , connectionPut 47 | 48 | -- * TLS related operations 49 | , connectionSetSecure 50 | , connectionIsSecure 51 | , connectionSessionManager 52 | ) where 53 | 54 | import Control.Concurrent.MVar 55 | import Control.Monad (join) 56 | import qualified Control.Exception as E 57 | import qualified System.IO.Error as E (mkIOError, eofErrorType) 58 | 59 | import qualified Network.TLS as TLS 60 | import qualified Network.TLS.Extra as TLS 61 | 62 | import System.X509 (getSystemCertificateStore) 63 | 64 | import Network.Socks5 (defaultSocksConf, socksConnectWithSocket, SocksAddress(..), SocksHostAddress(..)) 65 | import Network.Socket 66 | import qualified Network.Socket.ByteString as N 67 | 68 | import Data.Tuple (swap) 69 | import Data.Default.Class 70 | import Data.Data 71 | import Data.ByteString (ByteString) 72 | import qualified Data.ByteString as B 73 | import qualified Data.ByteString.Char8 as BC 74 | import qualified Data.ByteString.Lazy as L 75 | 76 | import System.Environment 77 | import System.Timeout 78 | import System.IO 79 | import qualified Data.Map as M 80 | 81 | import Network.Connection.Types 82 | 83 | type Manager = MVar (M.Map TLS.SessionID TLS.SessionData) 84 | 85 | -- | This is the exception raised if we reached the user specified limit for 86 | -- the line in ConnectionGetLine. 87 | data LineTooLong = LineTooLong deriving (Show,Typeable) 88 | 89 | -- | Exception raised when there's no resolution for a specific host 90 | data HostNotResolved = HostNotResolved String deriving (Show,Typeable) 91 | 92 | -- | Exception raised when the connect failed 93 | data HostCannotConnect = HostCannotConnect String [E.IOException] deriving (Show,Typeable) 94 | 95 | instance E.Exception LineTooLong 96 | instance E.Exception HostNotResolved 97 | instance E.Exception HostCannotConnect 98 | 99 | connectionSessionManager :: Manager -> TLS.SessionManager 100 | connectionSessionManager mvar = TLS.SessionManager 101 | { TLS.sessionResume = \sessionID -> withMVar mvar (return . M.lookup sessionID) 102 | , TLS.sessionEstablish = \sessionID sessionData -> 103 | modifyMVar_ mvar (return . M.insert sessionID sessionData) 104 | , TLS.sessionInvalidate = \sessionID -> modifyMVar_ mvar (return . M.delete sessionID) 105 | #if MIN_VERSION_tls(1,5,0) 106 | , TLS.sessionResumeOnlyOnce = \sessionID -> 107 | modifyMVar mvar (pure . swap . M.updateLookupWithKey (\_ _ -> Nothing) sessionID) 108 | #endif 109 | } 110 | 111 | -- | Initialize the library with shared parameters between connection. 112 | initConnectionContext :: IO ConnectionContext 113 | initConnectionContext = ConnectionContext <$> getSystemCertificateStore 114 | 115 | -- | Create a final TLS 'ClientParams' according to the destination and the 116 | -- TLSSettings. 117 | makeTLSParams :: ConnectionContext -> ConnectionID -> TLSSettings -> TLS.ClientParams 118 | makeTLSParams cg cid ts@(TLSSettingsSimple {}) = 119 | (TLS.defaultParamsClient (fst cid) portString) 120 | { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } 121 | , TLS.clientShared = def 122 | { TLS.sharedCAStore = globalCertificateStore cg 123 | , TLS.sharedValidationCache = validationCache 124 | -- , TLS.sharedSessionManager = connectionSessionManager 125 | } 126 | } 127 | where validationCache 128 | | settingDisableCertificateValidation ts = 129 | TLS.ValidationCache (\_ _ _ -> return TLS.ValidationCachePass) 130 | (\_ _ _ -> return ()) 131 | | otherwise = def 132 | portString = BC.pack $ show $ snd cid 133 | makeTLSParams _ cid (TLSSettings p) = 134 | p { TLS.clientServerIdentification = (fst cid, portString) } 135 | where portString = BC.pack $ show $ snd cid 136 | 137 | withBackend :: (ConnectionBackend -> IO a) -> Connection -> IO a 138 | withBackend f conn = readMVar (connectionBackend conn) >>= f 139 | 140 | connectionNew :: ConnectionID -> ConnectionBackend -> IO Connection 141 | connectionNew cid backend = 142 | Connection <$> newMVar backend 143 | <*> newMVar (Just B.empty) 144 | <*> pure cid 145 | 146 | -- | Use an already established handle to create a connection object. 147 | -- 148 | -- if the TLS Settings is set, it will do the handshake with the server. 149 | -- The SOCKS settings have no impact here, as the handle is already established 150 | connectFromHandle :: ConnectionContext 151 | -> Handle 152 | -> ConnectionParams 153 | -> IO Connection 154 | connectFromHandle cg h p = withSecurity (connectionUseSecure p) 155 | where withSecurity Nothing = connectionNew cid $ ConnectionStream h 156 | withSecurity (Just tlsSettings) = tlsEstablish h (makeTLSParams cg cid tlsSettings) >>= connectionNew cid . ConnectionTLS 157 | cid = (connectionHostname p, connectionPort p) 158 | 159 | -- | Use an already established handle to create a connection object. 160 | -- 161 | -- if the TLS Settings is set, it will do the handshake with the server. 162 | -- The SOCKS settings have no impact here, as the handle is already established 163 | connectFromSocket :: ConnectionContext 164 | -> Socket 165 | -> ConnectionParams 166 | -> IO Connection 167 | connectFromSocket cg sock p = withSecurity (connectionUseSecure p) 168 | where withSecurity Nothing = connectionNew cid $ ConnectionSocket sock 169 | withSecurity (Just tlsSettings) = tlsEstablish sock (makeTLSParams cg cid tlsSettings) >>= connectionNew cid . ConnectionTLS 170 | cid = (connectionHostname p, connectionPort p) 171 | 172 | -- | Connect to a destination using the parameter 173 | connectTo :: ConnectionContext -- ^ The global context of this connection. 174 | -> ConnectionParams -- ^ The parameters for this connection (where to connect, and such). 175 | -> IO Connection -- ^ The new established connection on success. 176 | connectTo cg cParams = do 177 | let conFct = doConnect (connectionUseSocks cParams) 178 | (connectionHostname cParams) 179 | (connectionPort cParams) 180 | E.bracketOnError conFct (close . fst) $ \(h, _) -> 181 | connectFromSocket cg h cParams 182 | where 183 | sockConnect sockHost sockPort h p = do 184 | (sockServ, servAddr) <- resolve' sockHost sockPort 185 | let sockConf = defaultSocksConf servAddr 186 | let destAddr = SocksAddress (SocksAddrDomainName $ BC.pack h) p 187 | (dest, _) <- socksConnectWithSocket sockServ sockConf destAddr 188 | case dest of 189 | SocksAddrIPV4 h4 -> return (sockServ, SockAddrInet p h4) 190 | SocksAddrIPV6 h6 -> return (sockServ, SockAddrInet6 p 0 h6 0) 191 | SocksAddrDomainName _ -> error "internal error: socks connect return a resolved address as domain name" 192 | 193 | 194 | doConnect proxy h p = 195 | case proxy of 196 | Nothing -> resolve' h p 197 | Just (OtherProxy proxyHost proxyPort) -> resolve' proxyHost proxyPort 198 | Just (SockSettingsSimple sockHost sockPort) -> 199 | sockConnect sockHost sockPort h p 200 | Just (SockSettingsEnvironment envName) -> do 201 | -- if we can't get the environment variable or that the string cannot be parsed 202 | -- we connect directly. 203 | let name = maybe "SOCKS_SERVER" id envName 204 | evar <- E.try (getEnv name) 205 | case evar of 206 | Left (_ :: E.IOException) -> resolve' h p 207 | Right var -> 208 | case parseSocks var of 209 | Nothing -> resolve' h p 210 | Just (sockHost, sockPort) -> sockConnect sockHost sockPort h p 211 | 212 | -- Try to parse "host:port" or "host" 213 | -- if port is omitted then the default SOCKS port (1080) is assumed 214 | parseSocks :: String -> Maybe (String, PortNumber) 215 | parseSocks s = 216 | case break (== ':') s of 217 | (sHost, "") -> Just (sHost, 1080) 218 | (sHost, ':':portS) -> 219 | case reads portS of 220 | [(sPort,"")] -> Just (sHost, sPort) 221 | _ -> Nothing 222 | _ -> Nothing 223 | 224 | -- Try to resolve the host/port to an address (zero to many of them), then 225 | -- try to connect from the first address to the last, returning the first one that 226 | -- succeeds 227 | resolve' :: String -> PortNumber -> IO (Socket, SockAddr) 228 | resolve' host port = do 229 | let hints = defaultHints { addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream } 230 | addrs <- getAddrInfo (Just hints) (Just host) (Just $ show port) 231 | firstSuccessful $ map tryToConnect addrs 232 | where 233 | tryToConnect addr = 234 | E.bracketOnError 235 | (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) 236 | (close) 237 | (\sock -> connect sock (addrAddress addr) >> return (sock, addrAddress addr)) 238 | firstSuccessful = go [] 239 | where 240 | go :: [E.IOException] -> [IO a] -> IO a 241 | go [] [] = E.throwIO $ HostNotResolved host 242 | go l@(_:_) [] = E.throwIO $ HostCannotConnect host l 243 | go acc (act:followingActs) = do 244 | er <- E.try act 245 | case er of 246 | Left err -> go (err:acc) followingActs 247 | Right r -> return r 248 | 249 | -- | Put a block of data in the connection. 250 | connectionPut :: Connection -> ByteString -> IO () 251 | connectionPut connection content = withBackend doWrite connection 252 | where doWrite (ConnectionStream h) = B.hPut h content >> hFlush h 253 | doWrite (ConnectionSocket s) = N.sendAll s content 254 | doWrite (ConnectionTLS ctx) = TLS.sendData ctx $ L.fromChunks [content] 255 | 256 | -- | Get exact count of bytes from a connection. 257 | -- 258 | -- The size argument is the exact amount that must be returned to the user. 259 | -- The call will wait until all data is available. Hence, it behaves like 260 | -- 'B.hGet'. 261 | -- 262 | -- On end of input, 'connectionGetExact' will throw an 'E.isEOFError' 263 | -- exception. 264 | connectionGetExact :: Connection -> Int -> IO ByteString 265 | connectionGetExact conn x = loop B.empty 0 266 | where loop bs y 267 | | y == x = return bs 268 | | otherwise = do 269 | next <- connectionGet conn (x - y) 270 | loop (B.append bs next) (y + (B.length next)) 271 | 272 | -- | Get some bytes from a connection. 273 | -- 274 | -- The size argument is just the maximum that could be returned to the user. 275 | -- The call will return as soon as there's data, even if there's less 276 | -- than requested. Hence, it behaves like 'B.hGetSome'. 277 | -- 278 | -- On end of input, 'connectionGet' returns 0, but subsequent calls will throw 279 | -- an 'E.isEOFError' exception. 280 | connectionGet :: Connection -> Int -> IO ByteString 281 | connectionGet conn size 282 | | size < 0 = fail "Network.Connection.connectionGet: size < 0" 283 | | size == 0 = return B.empty 284 | | otherwise = connectionGetChunkBase "connectionGet" conn $ B.splitAt size 285 | 286 | -- | Get the next block of data from the connection. 287 | connectionGetChunk :: Connection -> IO ByteString 288 | connectionGetChunk conn = 289 | connectionGetChunkBase "connectionGetChunk" conn $ \s -> (s, B.empty) 290 | 291 | -- | Like 'connectionGetChunk', but return the unused portion to the buffer, 292 | -- where it will be the next chunk read. 293 | connectionGetChunk' :: Connection -> (ByteString -> (a, ByteString)) -> IO a 294 | connectionGetChunk' = connectionGetChunkBase "connectionGetChunk'" 295 | 296 | -- | Wait for input to become available on a connection. 297 | -- 298 | -- As with 'hWaitForInput', the timeout value is given in milliseconds. If the 299 | -- timeout value is less than zero, then 'connectionWaitForInput' waits 300 | -- indefinitely. 301 | -- 302 | -- Unlike 'hWaitForInput', this function does not do any decoding, so it 303 | -- returns true when there is /any/ available input, not just full characters. 304 | connectionWaitForInput :: Connection -> Int -> IO Bool 305 | connectionWaitForInput conn timeout_ms = maybe False (const True) <$> timeout timeout_ns tryGetChunk 306 | where tryGetChunk = connectionGetChunkBase "connectionWaitForInput" conn $ \buf -> ((), buf) 307 | timeout_ns = timeout_ms * 1000 308 | 309 | connectionGetChunkBase :: String -> Connection -> (ByteString -> (a, ByteString)) -> IO a 310 | connectionGetChunkBase loc conn f = 311 | modifyMVar (connectionBuffer conn) $ \m -> 312 | case m of 313 | Nothing -> throwEOF conn loc 314 | Just buf 315 | | B.null buf -> do 316 | chunk <- withBackend getMoreData conn 317 | if B.null chunk 318 | then closeBuf chunk 319 | else updateBuf chunk 320 | | otherwise -> 321 | updateBuf buf 322 | where 323 | getMoreData (ConnectionTLS tlsctx) = TLS.recvData tlsctx 324 | getMoreData (ConnectionSocket sock) = N.recv sock 1500 325 | getMoreData (ConnectionStream h) = B.hGetSome h (16 * 1024) 326 | 327 | updateBuf buf = case f buf of (a, !buf') -> return (Just buf', a) 328 | closeBuf buf = case f buf of (a, _buf') -> return (Nothing, a) 329 | 330 | -- | Get the next line, using ASCII LF as the line terminator. 331 | -- 332 | -- This throws an 'isEOFError' exception on end of input, and LineTooLong when 333 | -- the number of bytes gathered is over the limit without a line terminator. 334 | -- 335 | -- The actual line returned can be bigger than the limit specified, provided 336 | -- that the last chunk returned by the underlaying backend contains a LF. 337 | -- Put another way: Only when we need more input and limit is reached that the 338 | -- LineTooLong exception will be raised. 339 | -- 340 | -- An end of file will be considered as a line terminator too, if the line is 341 | -- not empty. 342 | connectionGetLine :: Int -- ^ Maximum number of bytes before raising a LineTooLong exception 343 | -> Connection -- ^ Connection 344 | -> IO ByteString -- ^ The received line with the LF trimmed 345 | connectionGetLine limit conn = more (throwEOF conn loc) 0 id 346 | where 347 | loc = "connectionGetLine" 348 | lineTooLong = E.throwIO LineTooLong 349 | 350 | -- Accumulate chunks using a difference list and concatenate them 351 | -- when an end-of-line indicator is reached. 352 | more eofK !currentSz !dl = 353 | getChunk (\s -> let len = B.length s 354 | in if currentSz + len > limit 355 | then lineTooLong 356 | else more eofK (currentSz + len) (dl . (s:))) 357 | (\s -> done (dl . (s:))) 358 | (done dl) 359 | 360 | done :: ([ByteString] -> [ByteString]) -> IO ByteString 361 | done dl = return $! B.concat $ dl [] 362 | 363 | -- Get another chunk and call one of the continuations 364 | getChunk :: (ByteString -> IO r) -- moreK: need more input 365 | -> (ByteString -> IO r) -- doneK: end of line (line terminator found) 366 | -> IO r -- eofK: end of file 367 | -> IO r 368 | getChunk moreK doneK eofK = 369 | join $ connectionGetChunkBase loc conn $ \s -> 370 | if B.null s 371 | then (eofK, B.empty) 372 | else case B.break (== 10) s of 373 | (a, b) 374 | | B.null b -> (moreK a, B.empty) 375 | | otherwise -> (doneK a, B.tail b) 376 | 377 | throwEOF :: Connection -> String -> IO a 378 | throwEOF conn loc = 379 | E.throwIO $ E.mkIOError E.eofErrorType loc' Nothing (Just path) 380 | where 381 | loc' = "Network.Connection." ++ loc 382 | path = let (host, port) = connectionID conn 383 | in host ++ ":" ++ show port 384 | 385 | -- | Close a connection. 386 | connectionClose :: Connection -> IO () 387 | connectionClose = withBackend backendClose 388 | where backendClose (ConnectionTLS ctx) = ignoreIOExc (TLS.bye ctx) `E.finally` TLS.contextClose ctx 389 | backendClose (ConnectionSocket sock) = close sock 390 | backendClose (ConnectionStream h) = hClose h 391 | 392 | ignoreIOExc action = action `E.catch` \(_ :: E.IOException) -> return () 393 | 394 | -- | Activate secure layer using the parameters specified. 395 | -- 396 | -- This is typically used to negotiate a TLS channel on an already 397 | -- established channel, e.g., supporting a STARTTLS command. It also 398 | -- flushes the received buffer to prevent application confusing 399 | -- received data before and after the setSecure call. 400 | -- 401 | -- If the connection is already using TLS, nothing else happens. 402 | connectionSetSecure :: ConnectionContext 403 | -> Connection 404 | -> TLSSettings 405 | -> IO () 406 | connectionSetSecure cg connection params = 407 | modifyMVar_ (connectionBuffer connection) $ \b -> 408 | modifyMVar (connectionBackend connection) $ \backend -> 409 | case backend of 410 | (ConnectionStream h) -> do ctx <- tlsEstablish h (makeTLSParams cg (connectionID connection) params) 411 | return (ConnectionTLS ctx, Just B.empty) 412 | (ConnectionSocket s) -> do ctx <- tlsEstablish s (makeTLSParams cg (connectionID connection) params) 413 | return (ConnectionTLS ctx, Just B.empty) 414 | (ConnectionTLS _) -> return (backend, b) 415 | 416 | -- | Returns if the connection is establish securely or not. 417 | connectionIsSecure :: Connection -> IO Bool 418 | connectionIsSecure conn = withBackend isSecure conn 419 | where isSecure (ConnectionStream _) = return False 420 | isSecure (ConnectionSocket _) = return False 421 | isSecure (ConnectionTLS _) = return True 422 | 423 | tlsEstablish :: TLS.HasBackend backend => backend -> TLS.ClientParams -> IO TLS.Context 424 | tlsEstablish handle tlsParams = do 425 | ctx <- TLS.contextNew handle tlsParams 426 | TLS.handshake ctx 427 | return ctx 428 | -------------------------------------------------------------------------------- /Network/Connection/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Network.Connection.Types 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- connection types 9 | -- 10 | module Network.Connection.Types 11 | where 12 | 13 | import Control.Concurrent.MVar (MVar) 14 | 15 | import Data.Default.Class 16 | import Data.X509.CertificateStore 17 | import Data.ByteString (ByteString) 18 | 19 | import Network.Socket (PortNumber, Socket) 20 | import qualified Network.TLS as TLS 21 | 22 | import System.IO (Handle) 23 | 24 | -- | Simple backend enumeration, either using a raw connection or a tls connection. 25 | data ConnectionBackend = ConnectionStream Handle 26 | | ConnectionSocket Socket 27 | | ConnectionTLS TLS.Context 28 | 29 | 30 | -- | Hostname This could either be a name string (punycode encoded) or an ipv4/ipv6 31 | type HostName = String 32 | 33 | -- | Connection Parameters to establish a Connection. 34 | -- 35 | -- The strict minimum is an hostname and the port. 36 | -- 37 | -- If you need to establish a TLS connection, you should make sure 38 | -- connectionUseSecure is correctly set. 39 | -- 40 | -- If you need to connect through a SOCKS, you should make sure 41 | -- connectionUseSocks is correctly set. 42 | data ConnectionParams = ConnectionParams 43 | { connectionHostname :: HostName -- ^ host name to connect to. 44 | , connectionPort :: PortNumber -- ^ port number to connect to. 45 | , connectionUseSecure :: Maybe TLSSettings -- ^ optional TLS parameters. 46 | , connectionUseSocks :: Maybe ProxySettings -- ^ optional Proxy/Socks configuration. 47 | } 48 | 49 | -- | Proxy settings for the connection. 50 | -- 51 | -- OtherProxy handles specific application-level proxies like HTTP proxies. 52 | -- 53 | -- The simple SOCKS settings is just the hostname and portnumber of the SOCKS proxy server. 54 | -- 55 | -- That's for now the only settings in the SOCKS package, 56 | -- socks password, or any sort of other authentications is not yet implemented. 57 | data ProxySettings = 58 | SockSettingsSimple HostName PortNumber 59 | | SockSettingsEnvironment (Maybe String) 60 | | OtherProxy HostName PortNumber 61 | 62 | type SockSettings = ProxySettings 63 | 64 | -- | TLS Settings that can be either expressed as simple settings, 65 | -- or as full blown TLS.Params settings. 66 | -- 67 | -- Unless you need access to parameters that are not accessible through the 68 | -- simple settings, you should use TLSSettingsSimple. 69 | data TLSSettings 70 | = TLSSettingsSimple 71 | { settingDisableCertificateValidation :: Bool -- ^ Disable certificate verification completely, 72 | -- this make TLS/SSL vulnerable to a MITM attack. 73 | -- not recommended to use, but for testing. 74 | , settingDisableSession :: Bool -- ^ Disable session management. TLS/SSL connections 75 | -- will always re-established their context. 76 | -- Not Implemented Yet. 77 | , settingUseServerName :: Bool -- ^ Use server name extension. Not Implemented Yet. 78 | } -- ^ Simple TLS settings. recommended to use. 79 | | TLSSettings TLS.ClientParams -- ^ full blown TLS Settings directly using TLS.Params. for power users. 80 | deriving (Show) 81 | 82 | instance Default TLSSettings where 83 | def = TLSSettingsSimple False False False 84 | 85 | type ConnectionID = (HostName, PortNumber) 86 | 87 | -- | This opaque type represent a connection to a destination. 88 | data Connection = Connection 89 | { connectionBackend :: MVar ConnectionBackend 90 | , connectionBuffer :: MVar (Maybe ByteString) -- ^ this is set to 'Nothing' on EOF 91 | , connectionID :: ConnectionID -- ^ return a simple tuple of the port and hostname that we're connected to. 92 | } 93 | 94 | -- | Shared values (certificate store, sessions, ..) between connections 95 | -- 96 | -- At the moment, this is only strictly needed to shared sessions and certificates 97 | -- when using a TLS enabled connection. 98 | data ConnectionContext = ConnectionContext 99 | { globalCertificateStore :: !CertificateStore 100 | } 101 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | haskell Connection library 2 | ========================== 3 | 4 | Simple network library for all your connection need. 5 | 6 | Features: 7 | 8 | - Really simple to use 9 | - SSL/TLS 10 | - SOCKS 11 | 12 | Usage 13 | ----- 14 | 15 | Connect to www.example.com on port 4567 (without socks or tls), then send a 16 | byte, receive a single byte, print it, and close the connection: 17 | ```haskell 18 | import qualified Data.ByteString as B 19 | import Network.Connection 20 | import Data.Default 21 | 22 | main = do 23 | ctx <- initConnectionContext 24 | con <- connectTo ctx $ ConnectionParams 25 | { connectionHostname = "www.example.com" 26 | , connectionPort = 4567 27 | , connectionUseSecure = Nothing 28 | , connectionUseSocks = Nothing 29 | } 30 | connectionPut con (B.singleton 0xa) 31 | r <- connectionGet con 1 32 | putStrLn $ show r 33 | connectionClose con 34 | ``` 35 | Using a socks proxy is easy, we just need replacing the connectionSocks 36 | parameter, for example connecting to the same host, but using a socks 37 | proxy at localhost:1080: 38 | ```haskell 39 | con <- connectTo ctx $ ConnectionParams 40 | { connectionHostname = "www.example.com" 41 | , connectionPort = 4567 42 | , connectionUseSecure = Nothing 43 | , connectionUseSocks = Just $ SockSettingsSimple "localhost" 1080 44 | } 45 | ``` 46 | Connecting to a SSL style socket is equally easy, and need to set the UseSecure fields in ConnectionParams: 47 | ```haskell 48 | con <- connectTo ctx $ ConnectionParams 49 | { connectionHostname = "www.example.com" 50 | , connectionPort = 4567 51 | , connectionUseSecure = Just def 52 | , connectionUseSocks = Nothing 53 | } 54 | ``` 55 | And finally, you can start TLS in the middle of an insecure connection. This is great for 56 | protocol using STARTTLS (e.g. IMAP, SMTP): 57 | 58 | ```haskell 59 | {-# LANGUAGE OverloadedStrings #-} 60 | import qualified Data.ByteString as B 61 | import Data.ByteString.Char8 () 62 | import Network.Connection 63 | import Data.Default 64 | 65 | main = do 66 | ctx <- initConnectionContext 67 | con <- connectTo ctx $ ConnectionParams 68 | { connectionHostname = "www.example.com" 69 | , connectionPort = 4567 70 | , connectionUseSecure = Nothing 71 | , connectionUseSocks = Nothing 72 | } 73 | -- talk to the other side with no TLS: says hello and starttls 74 | connectionPut con "HELLO\n" 75 | connectionPut con "STARTTLS\n" 76 | 77 | -- switch to TLS 78 | connectionSetSecure ctx con def 79 | 80 | -- the connection is from now on using TLS, we can send secret for example 81 | connectionPut con "PASSWORD 123\n" 82 | connectionClose con 83 | ``` 84 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /connection.cabal: -------------------------------------------------------------------------------- 1 | Name: connection 2 | Version: 0.3.1 3 | Description: 4 | Simple network library for all your connection need. 5 | . 6 | Features: Really simple to use, SSL/TLS, SOCKS. 7 | . 8 | This library provides a very simple api to create sockets 9 | to a destination with the choice of SSL/TLS, and SOCKS. 10 | License: BSD3 11 | License-file: LICENSE 12 | Copyright: Vincent Hanquez 13 | Author: Vincent Hanquez 14 | Maintainer: Vincent Hanquez 15 | Synopsis: Simple and easy network connections API 16 | Build-Type: Simple 17 | Category: Network 18 | stability: experimental 19 | Cabal-Version: >=1.8 20 | Homepage: https://github.com/vincenthz/hs-connection 21 | extra-source-files: README.md 22 | CHANGELOG.md 23 | 24 | Library 25 | Build-Depends: base >= 3 && < 5 26 | , basement 27 | , bytestring 28 | , containers 29 | , data-default-class 30 | , network >= 2.6.3 31 | , tls >= 1.4 32 | , socks >= 0.6 33 | , x509 >= 1.5 34 | , x509-store >= 1.5 35 | , x509-system >= 1.5 36 | , x509-validation >= 1.5 37 | Exposed-modules: Network.Connection 38 | Other-modules: Network.Connection.Types 39 | ghc-options: -Wall 40 | 41 | source-repository head 42 | type: git 43 | location: https://github.com/vincenthz/hs-connection 44 | -------------------------------------------------------------------------------- /examples/SMTPConnection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import qualified Data.ByteString as B 3 | import Data.ByteString.Char8 () 4 | import Network.Connection 5 | import Data.Default 6 | 7 | readHeader con = do 8 | l <- connectionGetLine 1024 con 9 | putStrLn $ show l 10 | if B.isPrefixOf "250 " l 11 | then return () 12 | else readHeader con 13 | 14 | main = do 15 | ctx <- initConnectionContext 16 | con <- connectTo ctx $ ConnectionParams 17 | { connectionHostname = "my.smtp.server" 18 | , connectionPort = 25 19 | , connectionUseSecure = Nothing 20 | , connectionUseSocks = Nothing 21 | } 22 | 23 | -- | read the server banner 24 | connectionGetLine 1024 con >>= putStrLn . show 25 | -- | say ehlo to the smtp server 26 | connectionPut con "EHLO\n" 27 | -- | wait for a reply and print 28 | readHeader con 29 | -- | Tell the server to start a TLS context. 30 | connectionPut con "STARTTLS\n" 31 | -- | wait for a reply and print 32 | connectionGetLine 1024 con >>= putStrLn . show 33 | 34 | -- | negociate the TLS context 35 | connectionSetSecure ctx con def 36 | 37 | ------- connection is secure now 38 | connectionPut con "QUIT\n" 39 | connectionClose con 40 | -------------------------------------------------------------------------------- /examples/SimpleConnection.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.ByteString as B 2 | import Network.Connection 3 | 4 | main = do 5 | ctx <- initConnectionContext 6 | con <- connectTo ctx $ ConnectionParams 7 | { connectionHostname = "www.example.com" 8 | , connectionPort = 4567 9 | , connectionUseSecure = Nothing 10 | , connectionUseSocks = Nothing 11 | } 12 | connectionPut con (B.singleton 0xa) 13 | r <- connectionGet con 1024 14 | putStrLn $ show r 15 | connectionClose con 16 | -------------------------------------------------------------------------------- /examples/SocksConnection.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.ByteString as B 2 | import Network.Connection 3 | 4 | main = do 5 | ctx <- initConnectionContext 6 | con <- connectTo ctx $ ConnectionParams 7 | { connectionHostname = "www.example.com" 8 | , connectionPort = 4567 9 | , connectionUseSecure = Nothing 10 | , connectionUseSocks = Just $ SockSettingsSimple "localhost" 1080 11 | } 12 | connectionPut con (B.singleton 0xa) 13 | r <- connectionGet con 1024 14 | putStrLn $ show r 15 | connectionClose con 16 | -------------------------------------------------------------------------------- /examples/StartTLSConnection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import qualified Data.ByteString as B 3 | import Data.ByteString.Char8 () 4 | import Network.Connection 5 | import Data.Default 6 | 7 | main = do 8 | ctx <- initConnectionContext 9 | con <- connectTo ctx $ ConnectionParams 10 | { connectionHostname = "www.example.com" 11 | , connectionPort = 4567 12 | , connectionUseSecure = Nothing 13 | , connectionUseSocks = Nothing 14 | } 15 | -- talk to the other side, says hello and starttls 16 | connectionPut con "HELLO\n" 17 | connectionPut con "STARTTLS\n" 18 | 19 | -- switch to TLS 20 | connectionSetSecure ctx con def 21 | 22 | -- the connection is now on using TLS, we can send secret for examplek 23 | connectionPut con "PASSWORD 123\n" 24 | connectionClose con 25 | -------------------------------------------------------------------------------- /examples/TLSConnection.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.ByteString as B 2 | import Network.Connection 3 | import Data.Default 4 | 5 | main = do 6 | ctx <- initConnectionContext 7 | con <- connectTo ctx $ ConnectionParams 8 | { connectionHostname = "www.example.com" 9 | , connectionPort = 4567 10 | , connectionUseSecure = Just def 11 | , connectionUseSocks = Nothing 12 | } 13 | connectionPut con (B.singleton 0xa) 14 | r <- connectionGet con 1024 15 | putStrLn $ show r 16 | connectionClose con 17 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 5b46febf8255f003fa330959b4cd1bd4dc6c02bb3d7aef7303a711835dad117c ~*~ 2 | { resolver: lts-13.17, packages: [ '.' ], extra-deps: [ network-3.0.1.1, socks-0.6.0 ], flags: {} } 3 | 4 | --------------------------------------------------------------------------------