{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
module Happstack.Server.Internal.TimeoutSocketTLS where
import Control.Exception (SomeException, catch)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.Internal as L
import qualified Data.ByteString as S
import qualified Happstack.Server.Internal.TimeoutManager as TM
import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
import Network.Socket (Socket, close)
import Network.Socket.SendFile (ByteCount, Offset)
import OpenSSL.Session (SSL)
import qualified OpenSSL.Session as SSL
import Prelude hiding (catch)
import System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile)
import System.IO.Unsafe (unsafeInterleaveIO)
sPutLazyTickle :: TM.Handle -> SSL -> L.ByteString -> IO ()
sPutLazyTickle :: Handle -> SSL -> ByteString -> IO ()
sPutLazyTickle Handle
thandle SSL
ssl ByteString
cs =
do (ByteString -> IO () -> IO ()) -> IO () -> ByteString -> IO ()
forall a. (ByteString -> a -> a) -> a -> ByteString -> a
L.foldrChunks (\ByteString
c IO ()
rest -> SSL -> ByteString -> IO ()
SSL.write SSL
ssl ByteString
c IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
TM.tickle Handle
thandle IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rest) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString
cs
{-# INLINE sPutLazyTickle #-}
sPutTickle :: TM.Handle -> SSL -> B.ByteString -> IO ()
sPutTickle :: Handle -> SSL -> ByteString -> IO ()
sPutTickle Handle
thandle SSL
ssl ByteString
cs =
do SSL -> ByteString -> IO ()
SSL.write SSL
ssl ByteString
cs
Handle -> IO ()
TM.tickle Handle
thandle
{-# INLINE sPutTickle #-}
sGet :: TM.Handle
-> SSL
-> IO (Maybe B.ByteString)
sGet :: Handle -> SSL -> IO (Maybe ByteString)
sGet Handle
handle SSL
ssl =
do ByteString
s <- SSL -> Int -> IO ByteString
SSL.read SSL
ssl Int
chunkSize
Handle -> IO ()
TM.tickle Handle
handle
if ByteString -> Bool
S.null ByteString
s
then Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
else Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s)
where
chunkSize :: Int
chunkSize = Int
65536
sGetContents :: TM.Handle
-> SSL
-> IO L.ByteString
sGetContents :: Handle -> SSL -> IO ByteString
sGetContents Handle
handle SSL
ssl =
([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
L.fromChunks IO [ByteString]
loop
where
chunkSize :: Int
chunkSize = Int
65536
loop :: IO [ByteString]
loop = IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ do
ByteString
s <- SSL -> Int -> IO ByteString
SSL.read SSL
ssl Int
chunkSize
Handle -> IO ()
TM.tickle Handle
handle
if ByteString -> Bool
S.null ByteString
s
then do [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do [ByteString]
ss <- IO [ByteString]
loop
[ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ss)
timeoutSocketIO :: TM.Handle -> Socket -> SSL -> TimeoutIO
timeoutSocketIO :: Handle -> Socket -> SSL -> TimeoutIO
timeoutSocketIO Handle
handle Socket
socket SSL
ssl =
TimeoutIO { toHandle :: Handle
toHandle = Handle
handle
, toShutdown :: IO ()
toShutdown = do SSL -> ShutdownType -> IO ()
SSL.shutdown SSL
ssl ShutdownType
SSL.Unidirectional IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
ignoreException
Socket -> IO ()
close Socket
socket IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ()
ignoreException
, toPutLazy :: ByteString -> IO ()
toPutLazy = Handle -> SSL -> ByteString -> IO ()
sPutLazyTickle Handle
handle SSL
ssl
, toPut :: ByteString -> IO ()
toPut = Handle -> SSL -> ByteString -> IO ()
sPutTickle Handle
handle SSL
ssl
, toGet :: IO (Maybe ByteString)
toGet = Handle -> SSL -> IO (Maybe ByteString)
sGet Handle
handle SSL
ssl
, toGetContents :: IO ByteString
toGetContents = Handle -> SSL -> IO ByteString
sGetContents Handle
handle SSL
ssl
, toSendFile :: FilePath -> ByteCount -> ByteCount -> IO ()
toSendFile = Handle -> SSL -> FilePath -> ByteCount -> ByteCount -> IO ()
sendFileTickle Handle
handle SSL
ssl
, toSecure :: Bool
toSecure = Bool
True
}
where
ignoreException :: SomeException -> IO ()
ignoreException :: SomeException -> IO ()
ignoreException SomeException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendFileTickle :: TM.Handle -> SSL -> FilePath -> Offset -> ByteCount -> IO ()
sendFileTickle :: Handle -> SSL -> FilePath -> ByteCount -> ByteCount -> IO ()
sendFileTickle Handle
thandle SSL
ssl FilePath
fp ByteCount
offset ByteCount
count =
do FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> SeekMode -> ByteCount -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek ByteCount
offset
ByteString
c <- Handle -> IO ByteString
L.hGetContents Handle
h
Handle -> SSL -> ByteString -> IO ()
sPutLazyTickle Handle
thandle SSL
ssl (Int64 -> ByteString -> ByteString
L.take (ByteCount -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
count) ByteString
c)