module Network.Connection
(
Connection
, connectionID
, ConnectionParams(..)
, TLSSettings(..)
, SockSettings(..)
, LineTooLong(..)
, initConnectionContext
, ConnectionContext
, connectFromHandle
, connectTo
, connectionClose
, connectionGet
, connectionGetChunk
, connectionGetChunk'
, connectionGetLine
, connectionPut
, connectionSetSecure
, connectionIsSecure
) where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad (join)
import qualified Control.Exception as E
import qualified System.IO.Error as E
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra as TLS
import System.Certificate.X509 (getSystemCertificateStore)
import Network.Socks5
import qualified Network as N
import Data.Data
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Crypto.Random.AESCtr as RNG
import System.IO
import qualified Data.Map as M
import Network.Connection.Types
type Manager = MVar (M.Map TLS.SessionID TLS.SessionData)
data ConnectionSessionManager = ConnectionSessionManager Manager
data LineTooLong = LineTooLong deriving (Show,Typeable)
instance E.Exception LineTooLong
instance TLS.SessionManager ConnectionSessionManager where
sessionResume (ConnectionSessionManager mvar) sessionID =
withMVar mvar (return . M.lookup sessionID)
sessionEstablish (ConnectionSessionManager mvar) sessionID sessionData =
modifyMVar_ mvar (return . M.insert sessionID sessionData)
sessionInvalidate (ConnectionSessionManager mvar) sessionID =
modifyMVar_ mvar (return . M.delete sessionID)
initConnectionContext :: IO ConnectionContext
initConnectionContext = ConnectionContext <$> getSystemCertificateStore
makeTLSParams :: ConnectionContext -> TLSSettings -> TLS.Params
makeTLSParams cg ts@(TLSSettingsSimple {}) =
TLS.defaultParamsClient
{ TLS.pConnectVersion = TLS.TLS11
, TLS.pAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]
, TLS.pCiphers = TLS.ciphersuite_all
, TLS.pCertificates = []
, TLS.onCertificatesRecv = if settingDisableCertificateValidation ts
then const $ return TLS.CertificateUsageAccept
else TLS.certificateVerifyChain (globalCertificateStore cg)
}
makeTLSParams _ (TLSSettings p) = p
withBackend :: (ConnectionBackend -> IO a) -> Connection -> IO a
withBackend f conn = modifyMVar (connectionBackend conn) (\b -> f b >>= \a -> return (b,a))
connectionNew :: ConnectionParams -> ConnectionBackend -> IO Connection
connectionNew p backend =
Connection <$> newMVar backend
<*> newMVar (Just B.empty)
<*> pure (connectionHostname p, connectionPort p)
connectFromHandle :: ConnectionContext
-> Handle
-> ConnectionParams
-> IO Connection
connectFromHandle cg h p = withSecurity (connectionUseSecure p)
where withSecurity Nothing = connectionNew p $ ConnectionStream h
withSecurity (Just tlsSettings) = tlsEstablish h (makeTLSParams cg tlsSettings) >>= connectionNew p . ConnectionTLS
connectTo :: ConnectionContext
-> ConnectionParams
-> IO Connection
connectTo cg cParams = do
h <- conFct (connectionHostname cParams) (N.PortNumber $ connectionPort cParams)
connectFromHandle cg h cParams
where
conFct = case connectionUseSocks cParams of
Nothing -> N.connectTo
Just (SockSettingsSimple h p) -> socksConnectTo h (N.PortNumber p)
connectionPut :: Connection -> ByteString -> IO ()
connectionPut connection content = withBackend doWrite connection
where doWrite (ConnectionStream h) = B.hPut h content >> hFlush h
doWrite (ConnectionTLS ctx) = TLS.sendData ctx $ L.fromChunks [content]
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
connectionGetChunk :: Connection -> IO ByteString
connectionGetChunk conn =
connectionGetChunkBase "connectionGetChunk" conn $ \s -> (s, B.empty)
connectionGetChunk' :: Connection -> (ByteString -> (a, ByteString)) -> IO a
connectionGetChunk' = connectionGetChunkBase "connectionGetChunk'"
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 (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)
connectionGetLine :: Int
-> Connection
-> IO ByteString
connectionGetLine limit conn = more (throwEOF conn loc) 0 id
where
loc = "connectionGetLine"
lineTooLong = E.throwIO LineTooLong
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 []
getChunk :: (ByteString -> IO r)
-> (ByteString -> IO r)
-> IO r
-> IO r
getChunk moreK doneK eofK =
join $ connectionGetChunkBase loc conn $ \s ->
if B.null s
then (eofK, B.empty)
else case B.breakByte 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
connectionClose :: Connection -> IO ()
connectionClose = withBackend backendClose
where backendClose (ConnectionTLS ctx) = TLS.bye ctx >> TLS.contextClose ctx
backendClose (ConnectionStream h) = hClose h
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 params)
return (ConnectionTLS ctx, Just B.empty)
(ConnectionTLS _) -> return (backend, b)
connectionIsSecure :: Connection -> IO Bool
connectionIsSecure conn = withBackend isSecure conn
where isSecure (ConnectionStream _) = return False
isSecure (ConnectionTLS _) = return True
tlsEstablish :: Handle -> TLS.TLSParams -> IO TLS.Context
tlsEstablish handle tlsParams = do
rng <- RNG.makeSystem
ctx <- TLS.contextNewOnHandle handle tlsParams rng
TLS.handshake ctx
return ctx