diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for hookup + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hookup.cabal b/hookup.cabal new file mode 100644 --- /dev/null +++ b/hookup.cabal @@ -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 diff --git a/src/Hookup.hs b/src/Hookup.hs new file mode 100644 --- /dev/null +++ b/src/Hookup.hs @@ -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 + } diff --git a/src/Hookup/OpenSSL.hsc b/src/Hookup/OpenSSL.hsc new file mode 100644 --- /dev/null +++ b/src/Hookup/OpenSSL.hsc @@ -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")