diff --git a/gnutls.cabal b/gnutls.cabal index 5b77759..8993058 100644 --- a/gnutls.cabal +++ b/gnutls.cabal @@ -1,15 +1,15 @@ name: gnutls -version: 0.2 +version: 0.3.1 license: GPL-3 license-file: license.txt author: John Millikin -maintainer: John Millikin +maintainer: Stephen Paul Weber build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 category: Network stability: experimental -homepage: https://john-millikin.com/software/haskell-gnutls/ -bug-reports: mailto:jmillikin@gmail.com +homepage: https://git.singpolyma.net/haskell-gnutls +bug-reports: mailto:dev@singpolyma.net synopsis: Bindings for GNU libgnutls description: @@ -21,14 +21,15 @@ description: source-repository head type: git - location: https://john-millikin.com/code/haskell-gnutls/ + location: https://git.singpolyma.net/haskell-gnutls source-repository this type: git - location: https://john-millikin.com/code/haskell-gnutls/ - tag: haskell-gnutls_0.2 + location: https://git.singpolyma.net/haskell-gnutls + tag: 0.3.1 library + default-language: Haskell2010 hs-source-dirs: lib ghc-options: -Wall -Wno-tabs -O2 @@ -36,6 +37,9 @@ library base >= 4.0 && < 5.0 , bytestring >= 0.9 , transformers >= 0.4.0.0 + , unexceptionalio-trans + build-tool-depends: + c2hs:c2hs extra-libraries: gnutls pkgconfig-depends: gnutls diff --git a/lib/Network/Protocol/TLS/GNU.hs b/lib/Network/Protocol/TLS/GNU.hs index 59c95ac..cfab870 100644 --- a/lib/Network/Protocol/TLS/GNU.hs +++ b/lib/Network/Protocol/TLS/GNU.hs @@ -17,10 +17,12 @@ module Network.Protocol.TLS.GNU ( TLS + , TLST , Session , Error (..) , runTLS + , runTLS' , runClient , getSession , handshake @@ -36,15 +38,15 @@ module Network.Protocol.TLS.GNU , Credentials , setCredentials , certificateCredentials + , F.DigestAlgorithm(..) + , hash ) where -import Control.Applicative (Applicative, pure, (<*>)) import qualified Control.Concurrent.MVar as M -import Control.Monad (ap, when, foldM, foldM_) +import Control.Monad (when, foldM, foldM_) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.Except as E import qualified Control.Monad.Trans.Reader as R -import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as B @@ -54,6 +56,8 @@ import qualified Foreign.C as F import Foreign.Concurrent as FC import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) +import UnexceptionalIO.Trans (Unexceptional) +import qualified UnexceptionalIO.Trans as UIO import qualified Network.Protocol.TLS.GNU.Foreign as F @@ -64,11 +68,11 @@ globalInitMVar :: M.MVar () {-# NOINLINE globalInitMVar #-} globalInitMVar = unsafePerformIO $ M.newMVar () -globalInit :: ExceptT Error IO () +globalInit :: (Unexceptional m) => E.ExceptT Error m () globalInit = do let init_ = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_init - F.ReturnCode rc <- liftIO init_ - when (rc < 0) $ throwE $ mapError rc + F.ReturnCode rc <- UIO.unsafeFromIO init_ + when (rc < 0) $ E.throwE $ mapError rc globalDeinit :: IO () globalDeinit = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_deinit @@ -86,38 +90,31 @@ data Session = Session , sessionCredentials :: IORef [F.ForeignPtr F.Credentials] } -newtype TLS a = TLS { unTLS :: ExceptT Error (R.ReaderT Session IO) a } +type TLS a = TLST IO a +type TLST m a = E.ExceptT Error (R.ReaderT Session m) a -instance Functor TLS where - fmap f = TLS . fmap f . unTLS +runTLS :: (Unexceptional m) => Session -> TLST m a -> m (Either Error a) +runTLS s = E.runExceptT . runTLS' s -instance Applicative TLS where - pure = TLS . return - (<*>) = ap +runTLS' :: Session -> TLST m a -> E.ExceptT Error m a +runTLS' s = E.mapExceptT (flip R.runReaderT s) -instance Monad TLS where - return = TLS . return - m >>= f = TLS $ unTLS m >>= unTLS . f - -instance MonadIO TLS where - liftIO = TLS . liftIO - -runTLS :: Session -> TLS a -> IO (Either Error a) -runTLS s tls = R.runReaderT (runExceptT (unTLS tls)) s - -runClient :: Transport -> TLS a -> IO (Either Error a) +runClient :: (Unexceptional m) => Transport -> TLST m a -> m (Either Error a) runClient transport tls = do eitherSession <- newSession transport (F.ConnectionEnd 2) case eitherSession of Left err -> return (Left err) Right session -> runTLS session tls -newSession :: Transport -> F.ConnectionEnd -> IO (Either Error Session) -newSession transport end = F.alloca $ \sPtr -> runExceptT $ do +newSession :: (Unexceptional m) => + Transport + -> F.ConnectionEnd + -> m (Either Error Session) +newSession transport end = UIO.unsafeFromIO . F.alloca $ \sPtr -> E.runExceptT $ do globalInit - F.ReturnCode rc <- liftIO $ F.gnutls_init sPtr end - when (rc < 0) $ throwE $ mapError rc - liftIO $ do + F.ReturnCode rc <- UIO.unsafeFromIO $ F.gnutls_init sPtr end + when (rc < 0) $ E.throwE $ mapError rc + UIO.unsafeFromIO $ do ptr <- F.peek sPtr let session = F.Session ptr push <- F.wrapTransportFunc (pushImpl transport) @@ -133,22 +130,22 @@ newSession transport end = F.alloca $ \sPtr -> runExceptT $ do F.freeHaskellFunPtr pull return (Session fp creds) -getSession :: TLS Session -getSession = TLS $ lift R.ask +getSession :: (Monad m) => TLST m Session +getSession = lift R.ask -handshake :: TLS () -handshake = withSession F.gnutls_handshake >>= checkRC +handshake :: (Unexceptional m) => TLST m () +handshake = unsafeWithSession F.gnutls_handshake >>= checkRC -rehandshake :: TLS () -rehandshake = withSession F.gnutls_rehandshake >>= checkRC +rehandshake :: (Unexceptional m) => TLST m () +rehandshake = unsafeWithSession F.gnutls_rehandshake >>= checkRC -putBytes :: BL.ByteString -> TLS () +putBytes :: (Unexceptional m) => BL.ByteString -> TLST m () putBytes = putChunks . BL.toChunks where putChunks chunks = do - maybeErr <- withSession $ \s -> foldM (putChunk s) Nothing chunks + maybeErr <- unsafeWithSession $ \s -> foldM (putChunk s) Nothing chunks case maybeErr of Nothing -> return () - Just err -> TLS $ mapExceptT lift $ throwE $ mapError $ fromIntegral err + Just err -> E.throwE $ mapError $ fromIntegral err putChunk s Nothing chunk = B.unsafeUseAsCStringLen chunk $ uncurry loop where loop ptr len = do @@ -162,9 +159,9 @@ putBytes = putChunks . BL.toChunks where putChunk _ err _ = return err -getBytes :: Integer -> TLS BL.ByteString +getBytes :: (Unexceptional m) => Integer -> TLST m BL.ByteString getBytes count = do - (mbytes, len) <- withSession $ \s -> + (mbytes, len) <- unsafeWithSession $ \s -> F.allocaBytes (fromInteger count) $ \ptr -> do len <- F.gnutls_record_recv s ptr (fromInteger count) bytes <- if len >= 0 @@ -176,10 +173,10 @@ getBytes count = do case mbytes of Just bytes -> return bytes - Nothing -> TLS $ mapExceptT lift $ throwE $ mapError $ fromIntegral len + Nothing -> E.throwE $ mapError $ fromIntegral len -checkPending :: TLS Integer -checkPending = withSession $ \s -> do +checkPending :: (Unexceptional m) => TLST m Integer +checkPending = unsafeWithSession $ \s -> do pending <- F.gnutls_record_check_pending s return $ toInteger pending @@ -210,36 +207,46 @@ handleTransport h = Transport (BL.hPut h) (BL.hGet h . fromInteger) data Credentials = Credentials F.CredentialsType (F.ForeignPtr F.Credentials) -setCredentials :: Credentials -> TLS () +setCredentials :: (Unexceptional m) => Credentials -> TLST m () setCredentials (Credentials ctype fp) = do - rc <- withSession $ \s -> + rc <- unsafeWithSession $ \s -> F.withForeignPtr fp $ \ptr -> do F.gnutls_credentials_set s ctype ptr s <- getSession if F.unRC rc == 0 - then liftIO (atomicModifyIORef (sessionCredentials s) (\creds -> (fp:creds, ()))) + then UIO.unsafeFromIO (atomicModifyIORef (sessionCredentials s) (\creds -> (fp:creds, ()))) else checkRC rc -certificateCredentials :: TLS Credentials +certificateCredentials :: (Unexceptional m) => TLST m Credentials certificateCredentials = do - (rc, ptr) <- liftIO $ F.alloca $ \ptr -> do + (rc, ptr) <- UIO.unsafeFromIO $ F.alloca $ \ptr -> do rc <- F.gnutls_certificate_allocate_credentials ptr ptr' <- if F.unRC rc < 0 then return F.nullPtr else F.peek ptr return (rc, ptr') checkRC rc - fp <- liftIO $ F.newForeignPtr F.gnutls_certificate_free_credentials_funptr ptr + fp <- UIO.unsafeFromIO $ F.newForeignPtr F.gnutls_certificate_free_credentials_funptr ptr return $ Credentials (F.CredentialsType 1) fp -withSession :: (F.Session -> IO a) -> TLS a -withSession io = do +-- | This must only be called with IO actions that do not throw NonPseudoException +unsafeWithSession :: (Unexceptional m) => (F.Session -> IO a) -> TLST m a +unsafeWithSession io = do s <- getSession - liftIO $ F.withForeignPtr (sessionPtr s) $ io . F.Session + UIO.unsafeFromIO $ F.withForeignPtr (sessionPtr s) $ io . F.Session -checkRC :: F.ReturnCode -> TLS () -checkRC (F.ReturnCode x) = when (x < 0) $ TLS $ mapExceptT lift $ throwE $ mapError x +checkRC :: (Monad m) => F.ReturnCode -> E.ExceptT Error m () +checkRC (F.ReturnCode x) = when (x < 0) $ E.throwE $ mapError x mapError :: F.CInt -> Error mapError = Error . toInteger + +hash :: (Unexceptional m) => F.DigestAlgorithm -> B.ByteString -> E.ExceptT Error m B.ByteString +hash algo input = E.ExceptT $ UIO.unsafeFromIO $ F.alloca $ \hashp -> F.alloca $ \output -> E.runExceptT $ do + checkRC =<< UIO.unsafeFromIO (F.gnutls_hash_init hashp (fromIntegral $ fromEnum algo)) + hsh <- UIO.unsafeFromIO $ F.peek hashp + (checkRC =<<) $ UIO.unsafeFromIO $ B.unsafeUseAsCStringLen input $ \(cstr, len) -> + F.gnutls_hash hsh cstr (fromIntegral len) + UIO.unsafeFromIO $ F.gnutls_hash_deinit hsh output + UIO.unsafeFromIO $ B.unsafePackCString output diff --git a/lib/Network/Protocol/TLS/GNU/Foreign.hs b/lib/Network/Protocol/TLS/GNU/Foreign.chs similarity index 91% rename from lib/Network/Protocol/TLS/GNU/Foreign.hs rename to lib/Network/Protocol/TLS/GNU/Foreign.chs index 28d1b9c..b313612 100644 --- a/lib/Network/Protocol/TLS/GNU/Foreign.hs +++ b/lib/Network/Protocol/TLS/GNU/Foreign.chs @@ -1,5 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} +#include + -- Copyright (C) 2010 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -19,6 +21,7 @@ module Network.Protocol.TLS.GNU.Foreign where import Foreign import Foreign.C +import System.Posix.Types -- Type aliases {{{ @@ -40,9 +43,6 @@ newtype CredentialsType = CredentialsType CInt newtype MACAlgorithm = MACAlgorithm CInt deriving (Show, Eq) -newtype DigestAlgorithm = DigestAlgorithm CInt - deriving (Show, Eq) - newtype CompressionMethod = CompressionMethod CInt deriving (Show, Eq) @@ -88,12 +88,15 @@ newtype PKAlgorithm = PKAlgorithm CInt newtype SignAlgorithm = SignAlgorithm CInt deriving (Show, Eq) +{#enum define DigestAlgorithm {GNUTLS_DIG_SHA1 as SHA1} deriving (Eq, Ord) #} + newtype Credentials = Credentials (Ptr Credentials) newtype Transport = Transport (Ptr Transport) newtype Session = Session (Ptr Session) newtype DHParams = DHParams (Ptr DHParams) newtype RSAParams = RSAParams (Ptr RSAParams) newtype Priority = Priority (Ptr Priority) +newtype Hash = Hash (Ptr Hash) newtype Datum = Datum (Ptr Word8, CUInt) @@ -222,13 +225,13 @@ foreign import ccall safe "gnutls_record_get_max_size" gnutls_record_get_max_size :: Session -> IO CSize foreign import ccall safe "gnutls_record_recv" - gnutls_record_recv :: Session -> Ptr a -> CSize -> IO CSize + gnutls_record_recv :: Session -> Ptr a -> CSize -> IO CSsize foreign import ccall safe "gnutls_record_send" - gnutls_record_send :: Session -> Ptr a -> CSize -> IO CSize + gnutls_record_send :: Session -> Ptr a -> CSize -> IO CSsize foreign import ccall safe "gnutls_record_set_max_size" - gnutls_record_set_max_size :: Session -> CSize -> IO CSize + gnutls_record_set_max_size :: Session -> CSize -> IO CSsize -- }}} @@ -247,6 +250,14 @@ foreign import ccall "wrapper" -- }}} +-- Crypto {{{ + +foreign import ccall safe "gnutls_hash_init" gnutls_hash_init :: Ptr (Ptr Hash) -> CInt -> IO ReturnCode +foreign import ccall safe "gnutls_hash" gnutls_hash :: Ptr Hash -> CString -> CSize -> IO ReturnCode +foreign import ccall safe "gnutls_hash_deinit" gnutls_hash_deinit :: Ptr Hash -> CString -> IO () + +-- }}} + -- Utility {{{ foreign import ccall safe "gnutls_global_set_mem_functions"