{-# LANGUAGE TypeFamilies #-}
module Network.Protocol.TLS.GNU
( TLS
, Session
, Error (..)
, runTLS
, runClient
, getSession
, handshake
, rehandshake
, putBytes
, getBytes
, checkPending
, Transport (..)
, handleTransport
, Credentials
, setCredentials
, certificateCredentials
) where
import Control.Applicative (Applicative, pure, (<*>))
import qualified Control.Concurrent.MVar as M
import Control.Monad (ap, when, foldM, foldM_)
import qualified Control.Monad.Error as E
import Control.Monad.Error (ErrorType)
import qualified Control.Monad.Reader as R
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as B
import Data.IORef
import qualified Foreign as F
import qualified Foreign.C as F
import Foreign.Concurrent as FC
import qualified System.IO as IO
import System.IO.Unsafe (unsafePerformIO)
import Network.Protocol.TLS.GNU.ErrorT
import qualified Network.Protocol.TLS.GNU.Foreign as F
data Error = Error Integer
deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)
globalInitMVar :: M.MVar ()
{-# NOINLINE globalInitMVar #-}
globalInitMVar :: MVar ()
globalInitMVar = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
M.newMVar ()
globalInit :: ErrorT Error IO ()
globalInit :: ErrorT Error IO ()
globalInit = do
let init_ :: IO ReturnCode
init_ = MVar () -> (() -> IO ReturnCode) -> IO ReturnCode
forall a b. MVar a -> (a -> IO b) -> IO b
M.withMVar MVar ()
globalInitMVar ((() -> IO ReturnCode) -> IO ReturnCode)
-> (() -> IO ReturnCode) -> IO ReturnCode
forall a b. (a -> b) -> a -> b
$ \_ -> IO ReturnCode
F.gnutls_global_init
F.ReturnCode rc :: CInt
rc <- IO ReturnCode -> ErrorT Error IO ReturnCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ReturnCode
init_
Bool -> ErrorT Error IO () -> ErrorT Error IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (ErrorT Error IO () -> ErrorT Error IO ())
-> ErrorT Error IO () -> ErrorT Error IO ()
forall a b. (a -> b) -> a -> b
$ ErrorType (ErrorT Error IO) -> ErrorT Error IO ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError (ErrorType (ErrorT Error IO) -> ErrorT Error IO ())
-> ErrorType (ErrorT Error IO) -> ErrorT Error IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Error
mapError CInt
rc
globalDeinit :: IO ()
globalDeinit :: IO ()
globalDeinit = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
M.withMVar MVar ()
globalInitMVar ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> IO ()
F.gnutls_global_deinit
data Session = Session
{ Session -> ForeignPtr Session
sessionPtr :: F.ForeignPtr F.Session
, Session -> IORef [ForeignPtr Credentials]
sessionCredentials :: IORef [F.ForeignPtr F.Credentials]
}
newtype TLS a = TLS { TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS :: ErrorT Error (R.ReaderT Session IO) a }
instance Functor TLS where
fmap :: (a -> b) -> TLS a -> TLS b
fmap f :: a -> b
f = ErrorT Error (ReaderT Session IO) b -> TLS b
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) b -> TLS b)
-> (TLS a -> ErrorT Error (ReaderT Session IO) b) -> TLS a -> TLS b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b)
-> ErrorT Error (ReaderT Session IO) a
-> ErrorT Error (ReaderT Session IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ErrorT Error (ReaderT Session IO) a
-> ErrorT Error (ReaderT Session IO) b)
-> (TLS a -> ErrorT Error (ReaderT Session IO) a)
-> TLS a
-> ErrorT Error (ReaderT Session IO) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLS a -> ErrorT Error (ReaderT Session IO) a
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS
instance Applicative TLS where
pure :: a -> TLS a
pure = ErrorT Error (ReaderT Session IO) a -> TLS a
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) a -> TLS a)
-> (a -> ErrorT Error (ReaderT Session IO) a) -> a -> TLS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrorT Error (ReaderT Session IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: TLS (a -> b) -> TLS a -> TLS b
(<*>) = TLS (a -> b) -> TLS a -> TLS b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad TLS where
return :: a -> TLS a
return = ErrorT Error (ReaderT Session IO) a -> TLS a
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) a -> TLS a)
-> (a -> ErrorT Error (ReaderT Session IO) a) -> a -> TLS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ErrorT Error (ReaderT Session IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return
m :: TLS a
m >>= :: TLS a -> (a -> TLS b) -> TLS b
>>= f :: a -> TLS b
f = ErrorT Error (ReaderT Session IO) b -> TLS b
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) b -> TLS b)
-> ErrorT Error (ReaderT Session IO) b -> TLS b
forall a b. (a -> b) -> a -> b
$ TLS a -> ErrorT Error (ReaderT Session IO) a
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS TLS a
m ErrorT Error (ReaderT Session IO) a
-> (a -> ErrorT Error (ReaderT Session IO) b)
-> ErrorT Error (ReaderT Session IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TLS b -> ErrorT Error (ReaderT Session IO) b
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS (TLS b -> ErrorT Error (ReaderT Session IO) b)
-> (a -> TLS b) -> a -> ErrorT Error (ReaderT Session IO) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TLS b
f
instance MonadIO TLS where
liftIO :: IO a -> TLS a
liftIO = ErrorT Error (ReaderT Session IO) a -> TLS a
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) a -> TLS a)
-> (IO a -> ErrorT Error (ReaderT Session IO) a) -> IO a -> TLS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ErrorT Error (ReaderT Session IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance E.MonadError TLS where
type ErrorType TLS = Error
throwError :: ErrorType TLS -> TLS a
throwError = ErrorT Error (ReaderT Session IO) a -> TLS a
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) a -> TLS a)
-> (Error -> ErrorT Error (ReaderT Session IO) a) -> Error -> TLS a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ErrorT Error (ReaderT Session IO) a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError
catchError :: TLS a -> (ErrorType TLS -> TLS a) -> TLS a
catchError m :: TLS a
m h :: ErrorType TLS -> TLS a
h = ErrorT Error (ReaderT Session IO) a -> TLS a
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS (ErrorT Error (ReaderT Session IO) a -> TLS a)
-> ErrorT Error (ReaderT Session IO) a -> TLS a
forall a b. (a -> b) -> a -> b
$ ErrorT Error (ReaderT Session IO) a
-> (ErrorType (ErrorT Error (ReaderT Session IO))
-> ErrorT Error (ReaderT Session IO) a)
-> ErrorT Error (ReaderT Session IO) a
forall (m :: * -> *) a.
MonadError m =>
m a -> (ErrorType m -> m a) -> m a
E.catchError (TLS a -> ErrorT Error (ReaderT Session IO) a
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS TLS a
m) (TLS a -> ErrorT Error (ReaderT Session IO) a
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS (TLS a -> ErrorT Error (ReaderT Session IO) a)
-> (Error -> TLS a) -> Error -> ErrorT Error (ReaderT Session IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType TLS -> TLS a
Error -> TLS a
h)
runTLS :: Session -> TLS a -> IO (Either Error a)
runTLS :: Session -> TLS a -> IO (Either Error a)
runTLS s :: Session
s tls :: TLS a
tls = ReaderT Session IO (Either Error a)
-> Session -> IO (Either Error a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (ErrorT Error (ReaderT Session IO) a
-> ReaderT Session IO (Either Error a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (TLS a -> ErrorT Error (ReaderT Session IO) a
forall a. TLS a -> ErrorT Error (ReaderT Session IO) a
unTLS TLS a
tls)) Session
s
runClient :: Transport -> TLS a -> IO (Either Error a)
runClient :: Transport -> TLS a -> IO (Either Error a)
runClient transport :: Transport
transport tls :: TLS a
tls = do
Either Error Session
eitherSession <- Transport -> ConnectionEnd -> IO (Either Error Session)
newSession Transport
transport (CInt -> ConnectionEnd
F.ConnectionEnd 2)
case Either Error Session
eitherSession of
Left err :: Error
err -> Either Error a -> IO (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Error -> Either Error a
forall a b. a -> Either a b
Left Error
err)
Right session :: Session
session -> Session -> TLS a -> IO (Either Error a)
forall a. Session -> TLS a -> IO (Either Error a)
runTLS Session
session TLS a
tls
newSession :: Transport -> F.ConnectionEnd -> IO (Either Error Session)
newSession :: Transport -> ConnectionEnd -> IO (Either Error Session)
newSession transport :: Transport
transport end :: ConnectionEnd
end = (Ptr (Ptr Session) -> IO (Either Error Session))
-> IO (Either Error Session)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr Session) -> IO (Either Error Session))
-> IO (Either Error Session))
-> (Ptr (Ptr Session) -> IO (Either Error Session))
-> IO (Either Error Session)
forall a b. (a -> b) -> a -> b
$ \sPtr :: Ptr (Ptr Session)
sPtr -> ErrorT Error IO Session -> IO (Either Error Session)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT Error IO Session -> IO (Either Error Session))
-> ErrorT Error IO Session -> IO (Either Error Session)
forall a b. (a -> b) -> a -> b
$ do
ErrorT Error IO ()
globalInit
F.ReturnCode rc :: CInt
rc <- IO ReturnCode -> ErrorT Error IO ReturnCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ReturnCode -> ErrorT Error IO ReturnCode)
-> IO ReturnCode -> ErrorT Error IO ReturnCode
forall a b. (a -> b) -> a -> b
$ Ptr (Ptr Session) -> ConnectionEnd -> IO ReturnCode
F.gnutls_init Ptr (Ptr Session)
sPtr ConnectionEnd
end
Bool -> ErrorT Error IO () -> ErrorT Error IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (ErrorT Error IO () -> ErrorT Error IO ())
-> ErrorT Error IO () -> ErrorT Error IO ()
forall a b. (a -> b) -> a -> b
$ ErrorType (ErrorT Error IO) -> ErrorT Error IO ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError (ErrorType (ErrorT Error IO) -> ErrorT Error IO ())
-> ErrorType (ErrorT Error IO) -> ErrorT Error IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Error
mapError CInt
rc
IO Session -> ErrorT Error IO Session
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Session -> ErrorT Error IO Session)
-> IO Session -> ErrorT Error IO Session
forall a b. (a -> b) -> a -> b
$ do
Ptr Session
ptr <- Ptr (Ptr Session) -> IO (Ptr Session)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr Session)
sPtr
let session :: Session
session = Ptr Session -> Session
F.Session Ptr Session
ptr
FunPtr TransportFunc
push <- TransportFunc -> IO (FunPtr TransportFunc)
F.wrapTransportFunc (Transport -> TransportFunc
pushImpl Transport
transport)
FunPtr TransportFunc
pull <- TransportFunc -> IO (FunPtr TransportFunc)
F.wrapTransportFunc (Transport -> TransportFunc
pullImpl Transport
transport)
Session -> FunPtr TransportFunc -> IO ()
F.gnutls_transport_set_push_function Session
session FunPtr TransportFunc
push
Session -> FunPtr TransportFunc -> IO ()
F.gnutls_transport_set_pull_function Session
session FunPtr TransportFunc
pull
ReturnCode
_ <- Session -> IO ReturnCode
F.gnutls_set_default_priority Session
session
IORef [ForeignPtr Credentials]
creds <- [ForeignPtr Credentials] -> IO (IORef [ForeignPtr Credentials])
forall a. a -> IO (IORef a)
newIORef []
ForeignPtr Session
fp <- Ptr Session -> IO () -> IO (ForeignPtr Session)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
FC.newForeignPtr Ptr Session
ptr (IO () -> IO (ForeignPtr Session))
-> IO () -> IO (ForeignPtr Session)
forall a b. (a -> b) -> a -> b
$ do
Session -> IO ()
F.gnutls_deinit Session
session
IO ()
globalDeinit
FunPtr TransportFunc -> IO ()
forall a. FunPtr a -> IO ()
F.freeHaskellFunPtr FunPtr TransportFunc
push
FunPtr TransportFunc -> IO ()
forall a. FunPtr a -> IO ()
F.freeHaskellFunPtr FunPtr TransportFunc
pull
Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Session -> IORef [ForeignPtr Credentials] -> Session
Session ForeignPtr Session
fp IORef [ForeignPtr Credentials]
creds)
getSession :: TLS Session
getSession :: TLS Session
getSession = ErrorT Error (ReaderT Session IO) Session -> TLS Session
forall a. ErrorT Error (ReaderT Session IO) a -> TLS a
TLS ErrorT Error (ReaderT Session IO) Session
forall (m :: * -> *). MonadReader m => m (EnvType m)
R.ask
handshake :: TLS ()
handshake :: TLS ()
handshake = (Session -> IO ReturnCode) -> TLS ReturnCode
forall a. (Session -> IO a) -> TLS a
withSession Session -> IO ReturnCode
F.gnutls_handshake TLS ReturnCode -> (ReturnCode -> TLS ()) -> TLS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReturnCode -> TLS ()
checkRC
rehandshake :: TLS ()
rehandshake :: TLS ()
rehandshake = (Session -> IO ReturnCode) -> TLS ReturnCode
forall a. (Session -> IO a) -> TLS a
withSession Session -> IO ReturnCode
F.gnutls_rehandshake TLS ReturnCode -> (ReturnCode -> TLS ()) -> TLS ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReturnCode -> TLS ()
checkRC
putBytes :: BL.ByteString -> TLS ()
putBytes :: ByteString -> TLS ()
putBytes = [ByteString] -> TLS ()
forall (t :: * -> *). Foldable t => t ByteString -> TLS ()
putChunks ([ByteString] -> TLS ())
-> (ByteString -> [ByteString]) -> ByteString -> TLS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks where
putChunks :: t ByteString -> TLS ()
putChunks chunks :: t ByteString
chunks = do
Maybe Int
maybeErr <- (Session -> IO (Maybe Int)) -> TLS (Maybe Int)
forall a. (Session -> IO a) -> TLS a
withSession ((Session -> IO (Maybe Int)) -> TLS (Maybe Int))
-> (Session -> IO (Maybe Int)) -> TLS (Maybe Int)
forall a b. (a -> b) -> a -> b
$ \s :: Session
s -> (Maybe Int -> ByteString -> IO (Maybe Int))
-> Maybe Int -> t ByteString -> IO (Maybe Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Session -> Maybe Int -> ByteString -> IO (Maybe Int)
putChunk Session
s) Maybe Int
forall a. Maybe a
Nothing t ByteString
chunks
case Maybe Int
maybeErr of
Nothing -> () -> TLS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just err :: Int
err -> ErrorType TLS -> TLS ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError (ErrorType TLS -> TLS ()) -> ErrorType TLS -> TLS ()
forall a b. (a -> b) -> a -> b
$ CInt -> ErrorType TLS
CInt -> Error
mapError (CInt -> ErrorType TLS) -> CInt -> ErrorType TLS
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
err
putChunk :: Session -> Maybe Int -> ByteString -> IO (Maybe Int)
putChunk s :: Session
s Nothing chunk :: ByteString
chunk = ByteString -> (CStringLen -> IO (Maybe Int)) -> IO (Maybe Int)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
chunk ((CStringLen -> IO (Maybe Int)) -> IO (Maybe Int))
-> (CStringLen -> IO (Maybe Int)) -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ (Ptr CChar -> Int -> IO (Maybe Int))
-> CStringLen -> IO (Maybe Int)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ptr CChar -> Int -> IO (Maybe Int)
loop where
loop :: Ptr CChar -> Int -> IO (Maybe Int)
loop ptr :: Ptr CChar
ptr len :: Int
len = do
let len' :: CSize
len' = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
CSize
sent <- Session -> Ptr CChar -> CSize -> IO CSize
forall a. Session -> Ptr a -> CSize -> IO CSize
F.gnutls_record_send Session
s Ptr CChar
ptr CSize
len'
let sent' :: Int
sent' = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sent
case Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sent' of
0 -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
x :: Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 -> Ptr CChar -> Int -> IO (Maybe Int)
loop (Ptr CChar -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
F.plusPtr Ptr CChar
ptr Int
sent') Int
x
| Bool
otherwise -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
putChunk _ err :: Maybe Int
err _ = Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
err
getBytes :: Integer -> TLS BL.ByteString
getBytes :: Integer -> TLS ByteString
getBytes count :: Integer
count = do
(mbytes :: Maybe ByteString
mbytes, len :: CSize
len) <- (Session -> IO (Maybe ByteString, CSize))
-> TLS (Maybe ByteString, CSize)
forall a. (Session -> IO a) -> TLS a
withSession ((Session -> IO (Maybe ByteString, CSize))
-> TLS (Maybe ByteString, CSize))
-> (Session -> IO (Maybe ByteString, CSize))
-> TLS (Maybe ByteString, CSize)
forall a b. (a -> b) -> a -> b
$ \s :: Session
s ->
Int
-> (Ptr CChar -> IO (Maybe ByteString, CSize))
-> IO (Maybe ByteString, CSize)
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
count) ((Ptr CChar -> IO (Maybe ByteString, CSize))
-> IO (Maybe ByteString, CSize))
-> (Ptr CChar -> IO (Maybe ByteString, CSize))
-> IO (Maybe ByteString, CSize)
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr CChar
ptr -> do
CSize
len <- Session -> Ptr CChar -> CSize -> IO CSize
forall a. Session -> Ptr a -> CSize -> IO CSize
F.gnutls_record_recv Session
s Ptr CChar
ptr (Integer -> CSize
forall a. Num a => Integer -> a
fromInteger Integer
count)
Maybe ByteString
bytes <- if CSize
len CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
>= 0
then do
ByteString
chunk <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
ptr, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len)
Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
chunk]
else Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
(Maybe ByteString, CSize) -> IO (Maybe ByteString, CSize)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
bytes, CSize
len)
case Maybe ByteString
mbytes of
Just bytes :: ByteString
bytes -> ByteString -> TLS ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes
Nothing -> ErrorType TLS -> TLS ByteString
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError (ErrorType TLS -> TLS ByteString)
-> ErrorType TLS -> TLS ByteString
forall a b. (a -> b) -> a -> b
$ CInt -> ErrorType TLS
CInt -> Error
mapError (CInt -> ErrorType TLS) -> CInt -> ErrorType TLS
forall a b. (a -> b) -> a -> b
$ CSize -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len
checkPending :: TLS Integer
checkPending :: TLS Integer
checkPending = (Session -> IO Integer) -> TLS Integer
forall a. (Session -> IO a) -> TLS a
withSession ((Session -> IO Integer) -> TLS Integer)
-> (Session -> IO Integer) -> TLS Integer
forall a b. (a -> b) -> a -> b
$ \s :: Session
s -> do
CSize
pending <- Session -> IO CSize
F.gnutls_record_check_pending Session
s
Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ CSize -> Integer
forall a. Integral a => a -> Integer
toInteger CSize
pending
data Transport = Transport
{ Transport -> ByteString -> IO ()
transportPush :: BL.ByteString -> IO ()
, Transport -> Integer -> IO ByteString
transportPull :: Integer -> IO BL.ByteString
}
pullImpl :: Transport -> F.TransportFunc
pullImpl :: Transport -> TransportFunc
pullImpl t :: Transport
t _ buf :: Ptr ()
buf bufSize :: CSize
bufSize = do
ByteString
bytes <- Transport -> Integer -> IO ByteString
transportPull Transport
t (Integer -> IO ByteString) -> Integer -> IO ByteString
forall a b. (a -> b) -> a -> b
$ CSize -> Integer
forall a. Integral a => a -> Integer
toInteger CSize
bufSize
let loop :: Ptr a -> ByteString -> IO (Ptr b)
loop ptr :: Ptr a
ptr chunk :: ByteString
chunk =
ByteString -> (CStringLen -> IO (Ptr b)) -> IO (Ptr b)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
chunk ((CStringLen -> IO (Ptr b)) -> IO (Ptr b))
-> (CStringLen -> IO (Ptr b)) -> IO (Ptr b)
forall a b. (a -> b) -> a -> b
$ \(cstr :: Ptr CChar
cstr, len :: Int
len) -> do
Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
F.copyArray (Ptr a -> Ptr CChar
forall a b. Ptr a -> Ptr b
F.castPtr Ptr a
ptr) Ptr CChar
cstr Int
len
Ptr b -> IO (Ptr b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr b -> IO (Ptr b)) -> Ptr b -> IO (Ptr b)
forall a b. (a -> b) -> a -> b
$ Ptr a -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
F.plusPtr Ptr a
ptr Int
len
(Ptr () -> ByteString -> IO (Ptr ()))
-> Ptr () -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Ptr () -> ByteString -> IO (Ptr ())
forall a b. Ptr a -> ByteString -> IO (Ptr b)
loop Ptr ()
buf ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
bytes
CSize -> IO CSize
forall (m :: * -> *) a. Monad m => a -> m a
return (CSize -> IO CSize) -> CSize -> IO CSize
forall a b. (a -> b) -> a -> b
$ Int64 -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> CSize) -> Int64 -> CSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
bytes
pushImpl :: Transport -> F.TransportFunc
pushImpl :: Transport -> TransportFunc
pushImpl t :: Transport
t _ buf :: Ptr ()
buf bufSize :: CSize
bufSize = do
let buf' :: Ptr CChar
buf' = Ptr () -> Ptr CChar
forall a b. Ptr a -> Ptr b
F.castPtr Ptr ()
buf
ByteString
bytes <- CStringLen -> IO ByteString
B.unsafePackCStringLen (Ptr CChar
buf', CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
bufSize)
Transport -> ByteString -> IO ()
transportPush Transport
t (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
bytes]
CSize -> IO CSize
forall (m :: * -> *) a. Monad m => a -> m a
return CSize
bufSize
handleTransport :: IO.Handle -> Transport
handleTransport :: Handle -> Transport
handleTransport h :: Handle
h = (ByteString -> IO ()) -> (Integer -> IO ByteString) -> Transport
Transport (Handle -> ByteString -> IO ()
BL.hPut Handle
h) (Handle -> Int -> IO ByteString
BL.hGet Handle
h (Int -> IO ByteString)
-> (Integer -> Int) -> Integer -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger)
data Credentials = Credentials F.CredentialsType (F.ForeignPtr F.Credentials)
setCredentials :: Credentials -> TLS ()
setCredentials :: Credentials -> TLS ()
setCredentials (Credentials ctype :: CredentialsType
ctype fp :: ForeignPtr Credentials
fp) = do
ReturnCode
rc <- (Session -> IO ReturnCode) -> TLS ReturnCode
forall a. (Session -> IO a) -> TLS a
withSession ((Session -> IO ReturnCode) -> TLS ReturnCode)
-> (Session -> IO ReturnCode) -> TLS ReturnCode
forall a b. (a -> b) -> a -> b
$ \s :: Session
s ->
ForeignPtr Credentials
-> (Ptr Credentials -> IO ReturnCode) -> IO ReturnCode
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
F.withForeignPtr ForeignPtr Credentials
fp ((Ptr Credentials -> IO ReturnCode) -> IO ReturnCode)
-> (Ptr Credentials -> IO ReturnCode) -> IO ReturnCode
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Credentials
ptr -> do
Session -> CredentialsType -> Ptr Credentials -> IO ReturnCode
forall a. Session -> CredentialsType -> Ptr a -> IO ReturnCode
F.gnutls_credentials_set Session
s CredentialsType
ctype Ptr Credentials
ptr
Session
s <- TLS Session
getSession
if ReturnCode -> CInt
F.unRC ReturnCode
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then IO () -> TLS ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [ForeignPtr Credentials]
-> ([ForeignPtr Credentials] -> ([ForeignPtr Credentials], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Session -> IORef [ForeignPtr Credentials]
sessionCredentials Session
s) (\creds :: [ForeignPtr Credentials]
creds -> (ForeignPtr Credentials
fpForeignPtr Credentials
-> [ForeignPtr Credentials] -> [ForeignPtr Credentials]
forall a. a -> [a] -> [a]
:[ForeignPtr Credentials]
creds, ())))
else ReturnCode -> TLS ()
checkRC ReturnCode
rc
certificateCredentials :: TLS Credentials
certificateCredentials :: TLS Credentials
certificateCredentials = do
(rc :: ReturnCode
rc, ptr :: Ptr Credentials
ptr) <- IO (ReturnCode, Ptr Credentials)
-> TLS (ReturnCode, Ptr Credentials)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ReturnCode, Ptr Credentials)
-> TLS (ReturnCode, Ptr Credentials))
-> IO (ReturnCode, Ptr Credentials)
-> TLS (ReturnCode, Ptr Credentials)
forall a b. (a -> b) -> a -> b
$ (Ptr (Ptr Credentials) -> IO (ReturnCode, Ptr Credentials))
-> IO (ReturnCode, Ptr Credentials)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr Credentials) -> IO (ReturnCode, Ptr Credentials))
-> IO (ReturnCode, Ptr Credentials))
-> (Ptr (Ptr Credentials) -> IO (ReturnCode, Ptr Credentials))
-> IO (ReturnCode, Ptr Credentials)
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr (Ptr Credentials)
ptr -> do
ReturnCode
rc <- Ptr (Ptr Credentials) -> IO ReturnCode
F.gnutls_certificate_allocate_credentials Ptr (Ptr Credentials)
ptr
Ptr Credentials
ptr' <- if ReturnCode -> CInt
F.unRC ReturnCode
rc CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0
then Ptr Credentials -> IO (Ptr Credentials)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Credentials
forall a. Ptr a
F.nullPtr
else Ptr (Ptr Credentials) -> IO (Ptr Credentials)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr Credentials)
ptr
(ReturnCode, Ptr Credentials) -> IO (ReturnCode, Ptr Credentials)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReturnCode
rc, Ptr Credentials
ptr')
ReturnCode -> TLS ()
checkRC ReturnCode
rc
ForeignPtr Credentials
fp <- IO (ForeignPtr Credentials) -> TLS (ForeignPtr Credentials)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignPtr Credentials) -> TLS (ForeignPtr Credentials))
-> IO (ForeignPtr Credentials) -> TLS (ForeignPtr Credentials)
forall a b. (a -> b) -> a -> b
$ FinalizerPtr Credentials
-> Ptr Credentials -> IO (ForeignPtr Credentials)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
F.newForeignPtr FinalizerPtr Credentials
F.gnutls_certificate_free_credentials_funptr Ptr Credentials
ptr
Credentials -> TLS Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> TLS Credentials) -> Credentials -> TLS Credentials
forall a b. (a -> b) -> a -> b
$ CredentialsType -> ForeignPtr Credentials -> Credentials
Credentials (CInt -> CredentialsType
F.CredentialsType 1) ForeignPtr Credentials
fp
withSession :: (F.Session -> IO a) -> TLS a
withSession :: (Session -> IO a) -> TLS a
withSession io :: Session -> IO a
io = do
Session
s <- TLS Session
getSession
IO a -> TLS a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> TLS a) -> IO a -> TLS a
forall a b. (a -> b) -> a -> b
$ ForeignPtr Session -> (Ptr Session -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
F.withForeignPtr (Session -> ForeignPtr Session
sessionPtr Session
s) ((Ptr Session -> IO a) -> IO a) -> (Ptr Session -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Session -> IO a
io (Session -> IO a)
-> (Ptr Session -> Session) -> Ptr Session -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Session -> Session
F.Session
checkRC :: F.ReturnCode -> TLS ()
checkRC :: ReturnCode -> TLS ()
checkRC (F.ReturnCode x :: CInt
x) = Bool -> TLS () -> TLS ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (TLS () -> TLS ()) -> TLS () -> TLS ()
forall a b. (a -> b) -> a -> b
$ ErrorType TLS -> TLS ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
E.throwError (ErrorType TLS -> TLS ()) -> ErrorType TLS -> TLS ()
forall a b. (a -> b) -> a -> b
$ CInt -> Error
mapError CInt
x
mapError :: F.CInt -> Error
mapError :: CInt -> Error
mapError = Integer -> Error
Error (Integer -> Error) -> (CInt -> Integer) -> CInt -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Integer
forall a. Integral a => a -> Integer
toInteger