# 1 "hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs"
# 1 "<command-line>"
# 12 "<command-line>"
# 1 "/usr/include/stdc-predef.h" 1 3 4
# 17 "/usr/include/stdc-predef.h" 3 4
# 12 "<command-line>" 2
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 12 "<command-line>" 2
# 1 "hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs"
module SecondTransfer.MainLoop.OpenSSL_TLS(
tlsServeWithALPN
,tlsServeWithALPNAndFinishOnRequest
,TLSLayerGenericProblem(..)
,FinishRequest(..)
) where
import Control.Monad
import Control.Concurrent.MVar
import Control.Exception
import qualified Control.Exception as E
import Data.Foldable (foldMap)
import Data.Typeable
import Data.Monoid ()
import Foreign
import Foreign.C
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Char8 (pack)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Unsafe as BU
import System.Log.Logger
import SecondTransfer.MainLoop.PushPullType
# 1 "macros/Logging.cpphs" 1
# 35 "hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.cpphs" 2
data TLSLayerGenericProblem = TLSLayerGenericProblem String
deriving (Show, Typeable)
instance Exception TLSLayerGenericProblem where
toException = toException . IOProblem
fromException x = do
IOProblem a <- fromException x
cast a
data InterruptibleEither a b =
Left_I a
|Right_I b
|Interrupted
data FinishRequest = FinishRequest
data Connection_t
data Wired_t
type Connection_Ptr = Ptr Connection_t
type Wired_Ptr = Ptr Wired_t
foreign import ccall "make_connection" makeConnection ::
CString
-> CString
-> CString
-> CInt
-> Ptr CChar
-> CInt
-> IO Connection_Ptr
allOk :: CInt
allOk = 0
badHappened :: CInt
badHappened = 1
timeoutReached :: CInt
timeoutReached = 3
foreign import ccall "wait_for_connection" waitForConnection :: Connection_Ptr -> CInt -> Ptr Wired_Ptr -> IO CInt
foreign import ccall "send_data" sendData :: Wired_Ptr -> Ptr CChar -> CInt -> IO CInt
foreign import ccall "recv_data" recvData :: Wired_Ptr -> Ptr CChar -> CInt -> Ptr CInt -> IO CInt
foreign import ccall "get_selected_protocol" getSelectedProtocol :: Wired_Ptr -> IO CInt
foreign import ccall "dispose_wired_session" disposeWiredSession :: Wired_Ptr -> IO ()
foreign import ccall "close_connection" closeConnection :: Connection_Ptr -> IO ()
useBufferSize :: Int
useBufferSize = 4096
type Protocols = [B.ByteString]
protocolsToWire :: Protocols -> B.ByteString
protocolsToWire protocols =
LB.toStrict . BB.toLazyByteString $
foldMap (\ protocol
-> (BB.lazyByteString . LB.fromChunks)
[ B.singleton $ fromIntegral $ B.length protocol,
protocol
]
) protocols
tlsServeWithALPN :: FilePath
-> FilePath
-> String
-> [(String, Attendant)]
-> Int
-> IO ()
tlsServeWithALPN certificate_filename key_filename interface_name attendants interface_port = do
let protocols_bs = protocolsToWire $ fmap (\ (s,_) -> pack s) attendants
(return ())
withCString certificate_filename $ \ c_certfn -> withCString key_filename $ \ c_keyfn -> withCString interface_name $ \ c_iname -> do
connection_ptr <- BU.unsafeUseAsCStringLen protocols_bs $ \ (pchar, len) ->
makeConnection
c_certfn
c_keyfn
c_iname
(fromIntegral interface_port)
pchar
(fromIntegral len)
if connection_ptr == nullPtr
then do
(return ())
throwIO $ TLSLayerGenericProblem "Could not create listening end"
else do
(return ())
return ()
forever $ do
either_wired_ptr <- alloca $ \ wired_ptr_ptr ->
let
tryOnce = do
result_code <- waitForConnection connection_ptr defaultWaitTime wired_ptr_ptr
let
r = case result_code of
re | re == allOk -> do
p <- peek wired_ptr_ptr
(return ())
return $ Right p
| re == timeoutReached -> tryOnce
| re == badHappened -> return $ Left ("A wait for connection failed" :: String)
r
in tryOnce
case either_wired_ptr of
Left msg -> do
(return ())
return ()
Right wired_ptr -> do
already_closed_mvar <- newMVar False
let
pushAction datum = BU.unsafeUseAsCStringLen (LB.toStrict datum) $ \ (pchar, len) -> do
result <- sendData wired_ptr pchar (fromIntegral len)
case result of
r | r == allOk -> return ()
| r == badHappened -> throwIO $ TLSLayerGenericProblem "Could not send data"
pullAction = do
allocaBytes useBufferSize $ \ pcharbuffer ->
alloca $ \ data_recvd_ptr -> do
result <- recvData wired_ptr pcharbuffer (fromIntegral useBufferSize) data_recvd_ptr
(return ())
recvd_bytes <- case result of
r | r == allOk -> peek data_recvd_ptr
| r == badHappened -> throwIO $ TLSLayerGenericProblem "Could not receive data"
B.packCStringLen (pcharbuffer, fromIntegral recvd_bytes)
closeAction = do
b <- readMVar already_closed_mvar
if not b
then do
modifyMVar_ already_closed_mvar (\ _ -> return True)
disposeWiredSession wired_ptr
else
return ()
use_protocol <- getSelectedProtocol wired_ptr
(return ())
let
maybe_session_attendant = case fromIntegral use_protocol of
n | (use_protocol >= 0) -> Just $ snd $ attendants !! n
| otherwise -> Just . snd . head $ attendants
case maybe_session_attendant of
Just session_attendant ->
E.catch
(session_attendant pushAction pullAction closeAction)
((\ e -> do
(return ())
throwIO e
)::TLSLayerGenericProblem -> IO () )
Nothing ->
return ()
tlsServeWithALPNAndFinishOnRequest :: FilePath
-> FilePath
-> String
-> [(String, Attendant)]
-> Int
-> MVar FinishRequest
-> IO ()
tlsServeWithALPNAndFinishOnRequest certificate_filename key_filename interface_name attendants interface_port finish_request = do
let protocols_bs = protocolsToWire $ fmap (\ (s,_) -> pack s) attendants
withCString certificate_filename $ \ c_certfn -> withCString key_filename $ \ c_keyfn -> withCString interface_name $ \ c_iname -> do
connection_ptr <- BU.unsafeUseAsCStringLen protocols_bs $ \ (pchar, len) ->
makeConnection
c_certfn
c_keyfn
c_iname
(fromIntegral interface_port)
pchar
(fromIntegral len)
let
recursion = do
either_wired_ptr <- alloca $ \ wired_ptr_ptr ->
let
tryOnce = do
result_code <- waitForConnection connection_ptr smallWaitTime wired_ptr_ptr
let
r = case result_code of
re | re == allOk -> do
p <- peek wired_ptr_ptr
return $ Right_I p
| re == timeoutReached -> do
got_finish_request <- tryTakeMVar finish_request
case got_finish_request of
Nothing ->
tryOnce
Just _ ->
return Interrupted
| re == badHappened -> return $ Left_I "A wait for connection failed"
r
in tryOnce
case either_wired_ptr of
Left_I msg -> do
errorM "OpenSSL" $ ".. wait for connection failed. " ++ msg
recursion
Right_I wired_ptr -> do
already_closed_mvar <- newMVar False
let
pushAction datum = BU.unsafeUseAsCStringLen (LB.toStrict datum) $ \ (pchar, len) -> do
result <- sendData wired_ptr pchar (fromIntegral len)
case result of
r | r == allOk -> return ()
| r == badHappened -> throwIO $ TLSLayerGenericProblem "Could not send data"
pullAction = do
allocaBytes useBufferSize $ \ pcharbuffer ->
alloca $ \ data_recvd_ptr -> do
result <- recvData wired_ptr pcharbuffer (fromIntegral useBufferSize) data_recvd_ptr
recvd_bytes <- case result of
r | r == allOk -> peek data_recvd_ptr
| r == badHappened -> throwIO $ TLSLayerGenericProblem "Could not receive data"
B.packCStringLen (pcharbuffer, fromIntegral recvd_bytes)
closeAction = do
b <- readMVar already_closed_mvar
if not b
then do
modifyMVar_ already_closed_mvar (\ _ -> return True)
disposeWiredSession wired_ptr
else
return ()
use_protocol <- getSelectedProtocol wired_ptr
infoM "OpenSSL" $ ".. Using protocol: " ++ (show use_protocol)
let
maybe_session_attendant = case fromIntegral use_protocol of
n | (use_protocol >= 0) -> Just $ snd $ attendants !! n
| otherwise -> Just . snd . head $ attendants
case maybe_session_attendant of
Just session_attendant ->
session_attendant pushAction pullAction closeAction
Nothing ->
return ()
recursion
Interrupted -> do
infoM "OpenSSL" "Connection closed"
closeConnection connection_ptr
recursion
defaultWaitTime :: CInt
defaultWaitTime = 200000
smallWaitTime :: CInt
smallWaitTime = 50000