hookup (empty) → 0.1.0.0
raw patch · 6 files changed
+404/−0 lines, 6 filesdep +HsOpenSSLdep +HsOpenSSL-x509-systemdep +basesetup-changed
Dependencies added: HsOpenSSL, HsOpenSSL-x509-system, base, bytestring, network, socks, template-haskell
Files
- ChangeLog.md +5/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- hookup.cabal +29/−0
- src/Hookup.hs +298/−0
- src/Hookup/OpenSSL.hsc +57/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for hookup++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2016 Eric Mertens++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hookup.cabal view
@@ -0,0 +1,29 @@+name: hookup+version: 0.1.0.0+synopsis: Abstraction over creating network connections with SOCKS5 and TLS+description: This package provides an abstraction for communicating with line-oriented+ network services while abstracting over the use of SOCKS5 and TLS (via OpenSSL)+homepage: https://github.com/glguy/irc-core+license: ISC+license-file: LICENSE+author: Eric Mertens+maintainer: emertens@gmail.com+copyright: 2016 Eric Mertens+category: Network+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Hookup+ other-modules: Hookup.OpenSSL+ extra-libraries: ssl+ build-depends: base >=4.9 && <4.10,+ socks >=0.5 && <0.6,+ network >=2.6 && <2.7,+ bytestring >=0.10 && <0.11,+ HsOpenSSL >=0.11.2.3 && <0.12,+ HsOpenSSL-x509-system >=0.1 && <0.2,+ template-haskell >=2.11 && <2.12+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Hookup.hs view
@@ -0,0 +1,298 @@+{-|+Module : Hookup+Description : Network connections generalized over TLS and SOCKS+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides a uniform interface to network connections+with optional support for TLS and SOCKS.+-}+module Hookup+ (+ -- * Configuration+ ConnectionParams(..),+ SocksParams(..),+ TlsParams(..),++ -- * Connections+ Connection,+ connect,+ recvLine,+ send,+ close,++ -- * Errors+ ConnectionFailure(..),+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Foldable+import Network (PortID(..))+import Network.Socket (Socket, AddrInfo, PortNumber, HostName)+import qualified Network.Socket as Socket+import qualified Network.Socket.ByteString as SocketB+import Network.Socks5+import OpenSSL.Session (SSL, SSLContext)+import qualified OpenSSL as SSL+import qualified OpenSSL.Session as SSL+import qualified OpenSSL.X509 as SSL+import OpenSSL.X509.SystemStore+import qualified OpenSSL.PEM as PEM++import Hookup.OpenSSL (installVerification)+++-- | Parameters for 'connect'.+data ConnectionParams = ConnectionParams+ { cpHost :: HostName -- ^ Destination host+ , cpPort :: PortNumber -- ^ Destination TCP port+ , cpSocks :: Maybe SocksParams -- ^ Optional SOCKS5 parameters+ , cpTls :: Maybe TlsParams -- ^ Optional TLS parameters+ }+++-- | SOCKS5 connection parameters+data SocksParams = SocksParams+ { spHost :: HostName -- ^ SOCKS server host+ , spPort :: PortNumber -- ^ SOCKS server port+ }+++-- | TLS connection parameters+data TlsParams = TlsParams+ { tpClientCertificate :: Maybe FilePath+ , tpClientPrivateKey :: Maybe FilePath+ , tpServerCertificate :: Maybe FilePath+ , tpCipherSuite :: String+ , tpInsecure :: Bool+ }+++-- | Type for errors that can be thrown by this package.+data ConnectionFailure+ -- | Failure during 'getAddrInfo' resolving remote host+ = HostnameResolutionFailure IOError+ -- | Failure during 'connect' to remote host+ | ConnectionFailure [IOError]+ -- | Failure during 'recvLine'+ | LineTooLong+ -- | Incomplete line during 'recvLine'+ | LineTruncated+ deriving Show++instance Exception ConnectionFailure++------------------------------------------------------------------------+-- Opening sockets+------------------------------------------------------------------------++-- | Open a socket using the given parameters either directly or+-- via a SOCKS server.+openSocket :: ConnectionParams -> IO Socket+openSocket params =+ case cpSocks params of+ Nothing -> openSocket' (cpHost params) (cpPort params)+ Just sp -> openSocks sp (cpHost params) (cpPort params)+++openSocks :: SocksParams -> HostName -> PortNumber -> IO Socket+openSocks sp h p =+ do socksConnectTo'+ (spHost sp) (PortNumber (spPort sp))+ h (PortNumber p)+++openSocket' :: HostName -> PortNumber -> IO Socket+openSocket' h p =+ do let hints = Socket.defaultHints+ { Socket.addrSocketType = Socket.Stream+ , Socket.addrFlags = [Socket.AI_ADDRCONFIG+ ,Socket.AI_NUMERICSERV]+ }+ res <- try (Socket.getAddrInfo (Just hints) (Just h) (Just (show p)))+ case res of+ Right ais -> attemptConnections [] ais+ Left ioe -> throwIO (HostnameResolutionFailure ioe)+++attemptConnections :: [IOError] -> [Socket.AddrInfo] -> IO Socket+attemptConnections exs [] = throwIO (ConnectionFailure exs)+attemptConnections exs (ai:ais) =+ do s <- socket' ai+ res <- try (Socket.connect s (Socket.addrAddress ai))+ case res of+ Left ex -> do Socket.close s+ attemptConnections (ex:exs) ais+ Right{} -> return s+++-- | Open a 'Socket' using the parameters from an 'AddrInfo'+socket' :: AddrInfo -> IO Socket+socket' ai =+ Socket.socket+ (Socket.addrFamily ai)+ (Socket.addrSocketType ai)+ (Socket.addrProtocol ai)+++------------------------------------------------------------------------+-- Generalization of Socket+------------------------------------------------------------------------++data NetworkHandle = SSL SSL | Socket Socket+++openNetworkHandle :: ConnectionParams -> IO NetworkHandle+openNetworkHandle params =+ do s <- openSocket params+ case cpTls params of+ Nothing -> return (Socket s)+ Just tp -> SSL <$> startTls (cpHost params) tp s+++closeNetworkHandle :: NetworkHandle -> IO ()+closeNetworkHandle (SSL s) = SSL.shutdown s SSL.Unidirectional+closeNetworkHandle (Socket s) = Socket.close s++networkSend :: NetworkHandle -> ByteString -> IO ()+networkSend (Socket s) = SocketB.sendAll s+networkSend (SSL s) = SSL.write s++networkRecv :: NetworkHandle -> Int -> IO ByteString+networkRecv (Socket s) = SocketB.recv s+networkRecv (SSL s) = SSL.read s+++------------------------------------------------------------------------+-- Sockets with a receive buffer+------------------------------------------------------------------------++-- | A connection to a network service along with its read buffer+-- used for line-oriented protocols. The connection could be a plain+-- network connection, SOCKS connected, or TLS.+data Connection = Connection (MVar ByteString) NetworkHandle++-- | Open network connection to TCP service specified by+-- the given parameters.+--+-- Throws 'IOError', 'SocksError', 'SSL.ProtocolError', 'ConnectionFailure'+connect :: ConnectionParams -> IO Connection+connect params =+ do h <- openNetworkHandle params+ b <- newMVar B.empty+ return (Connection b h)+++-- | Close network connection.+close :: Connection -> IO ()+close (Connection _ h) = closeNetworkHandle h+++-- | Receive a line from the network connection. Both+-- @"\r\n"@ and @"\n"@ are recognized.+--+-- Throws: 'ConnectionAbruptlyTerminated', 'ConnectionFailure', 'IOError'+recvLine :: Connection -> Int -> IO (Maybe ByteString)+recvLine (Connection buf h) n =+ modifyMVar buf $ \bs ->+ go (B.length bs) bs []+ where+ go bsn bs bss =+ case B.elemIndex 10 bs of+ Just i -> return (B.tail b,+ Just (cleanEnd (B.concat (reverse (a:bss)))))+ where+ (a,b) = B.splitAt i bs+ Nothing ->+ do when (bsn >= n) (throwIO LineTooLong)+ more <- networkRecv h n+ if B.null more+ then if B.null bs then return (B.empty, Nothing)+ else throwIO LineTruncated+ else go (bsn + B.length more) more (bs:bss)+++-- | Remove the trailing @'\r'@ if one is found.+cleanEnd :: ByteString -> ByteString+cleanEnd bs+ | B.null bs || B.last bs /= 13 = bs+ | otherwise = B.init bs+++-- | Send bytes on the network connection. Ensures that the whole message+-- is sent.+--+-- Throws: 'IOError', 'ProtocolError'+send :: Connection -> ByteString -> IO ()+send (Connection _ h) = networkSend h+++------------------------------------------------------------------------+++-- | Initiate a TLS session on the given socket destined for+-- the given hostname. When successful an active TLS connection+-- is returned with certificate verification successful when+-- requested.+startTls ::+ HostName {- ^ server hostname -} ->+ TlsParams {- ^ parameters -} ->+ Socket {- ^ connected socket -} ->+ IO SSL {- ^ connected TLS -}+startTls host tp s = SSL.withOpenSSL $+ do ctx <- SSL.context++ -- configure context+ SSL.contextSetCiphers ctx (tpCipherSuite tp)+ installVerification ctx host+ SSL.contextSetVerificationMode ctx (verificationMode (tpInsecure tp))+ SSL.contextAddOption ctx SSL.SSL_OP_ALL+ SSL.contextRemoveOption ctx SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS++ -- configure certificates+ setupCaCertificates ctx (tpServerCertificate tp)+ traverse_ (setupCertificate ctx) (tpClientCertificate tp)+ traverse_ (setupPrivateKey ctx) (tpClientPrivateKey tp)++ -- add socket to context+ ssl <- SSL.connection ctx s+ SSL.setTlsextHostName ssl host+ SSL.connect ssl++ return ssl+++setupCaCertificates :: SSLContext -> Maybe FilePath -> IO ()+setupCaCertificates ctx mbPath =+ case mbPath of+ Nothing -> contextLoadSystemCerts ctx+ Just path -> SSL.contextSetCAFile ctx path+++setupCertificate :: SSLContext -> FilePath -> IO ()+setupCertificate ctx path+ = SSL.contextSetCertificate ctx+ =<< PEM.readX509 -- EX+ =<< readFile path+++setupPrivateKey :: SSLContext -> FilePath -> IO ()+setupPrivateKey ctx path =+ do str <- readFile path -- EX+ key <- PEM.readPrivateKey str PEM.PwNone -- add password support+ SSL.contextSetPrivateKey ctx key+++verificationMode :: Bool {- ^ insecure -} -> SSL.VerificationMode+verificationMode insecure+ | insecure = SSL.VerifyNone+ | otherwise = SSL.VerifyPeer+ { SSL.vpFailIfNoPeerCert = True+ , SSL.vpClientOnce = True+ , SSL.vpCallback = Nothing+ }
+ src/Hookup/OpenSSL.hsc view
@@ -0,0 +1,57 @@+{-|+Module : Hookup.OpenSSL+Description : Hack into the internals of OpenSSL to add missing functionality+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com+-}++#include "openssl/ssl.h"+#include "openssl/x509_vfy.h"+#include "openssl/x509v3.h"++module Hookup.OpenSSL (installVerification) where++import Control.Monad (unless)+import Foreign.C (CString(..), CSize(..), CUInt(..), CInt(..), withCStringLen)+import Foreign.Ptr (Ptr)+import OpenSSL.Session (SSLContext, SSLContext_, withContext)++------------------------------------------------------------------------+-- Bindings to hostname verification interface+------------------------------------------------------------------------++data X509_VERIFY_PARAM_++-- X509_VERIFY_PARAM *SSL_CTX_get0_param(SSL_CTX *ctx);+foreign import ccall unsafe "SSL_CTX_get0_param"+ sslGet0Param ::+ Ptr SSLContext_ {- ^ ctx -} ->+ IO (Ptr X509_VERIFY_PARAM_)++-- void X509_VERIFY_PARAM_set_hostflags(X509_VERIFY_PARAM *param, unsigned int flags);+foreign import ccall unsafe "X509_VERIFY_PARAM_set_hostflags"+ x509VerifyParamSetHostflags ::+ Ptr X509_VERIFY_PARAM_ {- ^ param -} ->+ CUInt {- ^ flags -} ->+ IO ()++-- int X509_VERIFY_PARAM_set1_host(X509_VERIFY_PARAM *param, const char *name, size_t namelen);+foreign import ccall unsafe "X509_VERIFY_PARAM_set1_host"+ x509VerifyParamSet1Host ::+ Ptr X509_VERIFY_PARAM_ {- ^ param -} ->+ CString {- ^ name -} ->+ CSize {- ^ namelen -} ->+ IO CInt {- ^ 1 success, 0 failure -}++-- | Add hostname checking to the certificate verification step.+-- Partial wildcards matching is disabled.+installVerification :: SSLContext -> String {- ^ hostname -} -> IO ()+installVerification ctx host =+ withContext ctx $ \ctxPtr ->+ withCStringLen host $ \(ptr,len) ->+ do param <- sslGet0Param ctxPtr+ x509VerifyParamSetHostflags param+ (#const X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS)+ success <- x509VerifyParamSet1Host param ptr (fromIntegral len)+ unless (success == 1) (fail "Unable to set verification host")