gnutls 0.2 → 0.3
raw patch · 5 files changed
+361/−432 lines, 5 filesdep +unexceptionalio-transdep −monads-tfdep ~transformersnew-uploader
Dependencies added: unexceptionalio-trans
Dependencies removed: monads-tf
Dependency ranges changed: transformers
Files
- gnutls.cabal +12/−12
- lib/Network/Protocol/TLS/GNU.hs +63/−62
- lib/Network/Protocol/TLS/GNU/ErrorT.hs +0/−82
- lib/Network/Protocol/TLS/GNU/Foreign.chs +286/−0
- lib/Network/Protocol/TLS/GNU/Foreign.hs +0/−276
gnutls.cabal view
@@ -1,15 +1,15 @@ name: gnutls-version: 0.2+version: 0.3 license: GPL-3 license-file: license.txt author: John Millikin <jmillikin@gmail.com>-maintainer: John Millikin <jmillikin@gmail.com>+maintainer: Stephen Paul Weber <singpolyma@singpolyma.net> 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,22 +21,23 @@ 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 library+ default-language: Haskell2010 hs-source-dirs: lib- ghc-options: -Wall -O2+ ghc-options: -Wall -Wno-tabs -O2 build-depends: base >= 4.0 && < 5.0 , bytestring >= 0.9- , transformers >= 0.2- , monads-tf >= 0.1 && < 0.2+ , transformers >= 0.4.0.0+ , unexceptionalio-trans extra-libraries: gnutls pkgconfig-depends: gnutls@@ -45,5 +46,4 @@ Network.Protocol.TLS.GNU other-modules:- Network.Protocol.TLS.GNU.ErrorT Network.Protocol.TLS.GNU.Foreign
lib/Network/Protocol/TLS/GNU.hs view
@@ -17,10 +17,12 @@ module Network.Protocol.TLS.GNU ( TLS+ , TLST , Session , Error (..) , runTLS+ , runTLS' , runClient , getSession , handshake@@ -36,15 +38,15 @@ , 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 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 Control.Monad (when, foldM, foldM_)+import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.Except as E+import qualified Control.Monad.Trans.Reader as R import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as B@@ -54,8 +56,9 @@ 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 Network.Protocol.TLS.GNU.ErrorT import qualified Network.Protocol.TLS.GNU.Foreign as F data Error = Error Integer@@ -65,11 +68,11 @@ {-# NOINLINE globalInitMVar #-} globalInitMVar = unsafePerformIO $ M.newMVar () -globalInit :: ErrorT 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) $ E.throwError $ 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@@ -87,43 +90,31 @@ , sessionCredentials :: IORef [F.ForeignPtr F.Credentials] } -newtype TLS a = TLS { unTLS :: ErrorT Error (R.ReaderT Session IO) a }--instance Functor TLS where- fmap f = TLS . fmap f . unTLS--instance Applicative TLS where- pure = TLS . return- (<*>) = ap--instance Monad TLS where- return = TLS . return- m >>= f = TLS $ unTLS m >>= unTLS . f--instance MonadIO TLS where- liftIO = TLS . liftIO+type TLS a = TLST IO a+type TLST m a = E.ExceptT Error (R.ReaderT Session m) a -instance E.MonadError TLS where- type ErrorType TLS = Error- throwError = TLS . E.throwError- catchError m h = TLS $ E.catchError (unTLS m) (unTLS . h)+runTLS :: (Unexceptional m) => Session -> TLST m a -> m (Either Error a)+runTLS s = E.runExceptT . runTLS' s -runTLS :: Session -> TLS a -> IO (Either Error a)-runTLS s tls = R.runReaderT (runErrorT (unTLS tls)) s+runTLS' :: Session -> TLST m a -> E.ExceptT Error m a+runTLS' s = E.mapExceptT (flip R.runReaderT 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 -> runErrorT $ 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) $ E.throwError $ 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)@@ -139,22 +130,22 @@ F.freeHaskellFunPtr pull return (Session fp creds) -getSession :: TLS Session-getSession = TLS 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 -> E.throwError $ mapError $ fromIntegral err+ Just err -> E.throwE $ mapError $ fromIntegral err putChunk s Nothing chunk = B.unsafeUseAsCStringLen chunk $ uncurry loop where loop ptr len = do@@ -168,9 +159,9 @@ 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@@ -182,10 +173,10 @@ case mbytes of Just bytes -> return bytes- Nothing -> E.throwError $ 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 @@ -216,36 +207,46 @@ 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) $ E.throwError $ 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
− lib/Network/Protocol/TLS/GNU/ErrorT.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE TypeFamilies #-}---- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--module Network.Protocol.TLS.GNU.ErrorT- ( ErrorT (..)- , mapErrorT- ) where--import Control.Applicative (Applicative, pure, (<*>))-import Control.Monad (ap,liftM)-import Control.Monad.Trans (MonadIO, liftIO)-import Control.Monad.Trans.Class (MonadTrans, lift)-import qualified Control.Monad.Error as E-import Control.Monad.Error (ErrorType)-import qualified Control.Monad.Reader as R-import Control.Monad.Reader (EnvType)---- A custom version of ErrorT, without the 'Error' class restriction.--newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }--instance Functor m => Functor (ErrorT e m) where- fmap f = ErrorT . fmap (fmap f) . runErrorT--instance (Functor m, Monad m) => Applicative (ErrorT e m) where- pure a = ErrorT $ return (Right a)- f <*> v = ErrorT $ do- mf <- runErrorT f- case mf of- Left e -> return (Left e)- Right k -> do- mv <- runErrorT v- case mv of- Left e -> return (Left e)- Right x -> return (Right (k x))--instance Monad m => Monad (ErrorT e m) where- return = ErrorT . return . Right- (>>=) m k = ErrorT $ do- x <- runErrorT m- case x of- Left l -> return $ Left l- Right r -> runErrorT $ k r--instance Monad m => E.MonadError (ErrorT e m) where- type ErrorType (ErrorT e m) = e- throwError = ErrorT . return . Left- catchError m h = ErrorT $ do- x <- runErrorT m- case x of- Left l -> runErrorT $ h l- Right r -> return $ Right r--instance MonadTrans (ErrorT e) where- lift = ErrorT . liftM Right--instance R.MonadReader m => R.MonadReader (ErrorT e m) where- type EnvType (ErrorT e m) = EnvType m- ask = lift R.ask- local = mapErrorT . R.local--instance MonadIO m => MonadIO (ErrorT e m) where- liftIO = lift . liftIO--mapErrorT :: (m (Either e a) -> n (Either e' b))- -> ErrorT e m a- -> ErrorT e' n b-mapErrorT f m = ErrorT $ f (runErrorT m)
+ lib/Network/Protocol/TLS/GNU/Foreign.chs view
@@ -0,0 +1,286 @@+{-# LANGUAGE ForeignFunctionInterface #-}++#include <gnutls/crypto.h>++-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Network.Protocol.TLS.GNU.Foreign where++import Foreign+import Foreign.C++-- Type aliases {{{++newtype ReturnCode = ReturnCode { unRC :: CInt }+ deriving (Show, Eq)++newtype CipherAlgorithm = CipherAlgorithm CInt+ deriving (Show, Eq)++newtype KXAlgorithm = KXAlgorithm CInt+ deriving (Show, Eq)++newtype ParamsType = ParamsType CInt+ deriving (Show, Eq)++newtype CredentialsType = CredentialsType CInt+ deriving (Show, Eq)++newtype MACAlgorithm = MACAlgorithm CInt+ deriving (Show, Eq)++newtype CompressionMethod = CompressionMethod CInt+ deriving (Show, Eq)++newtype ConnectionEnd = ConnectionEnd CInt+ deriving (Show, Eq)++newtype AlertLevel = AlertLevel CInt+ deriving (Show, Eq)++newtype AlertDescription = AlertDescription CInt+ deriving (Show, Eq)++newtype HandshakeDescription = HandshakeDescription CInt+ deriving (Show, Eq)++newtype CertificateStatus = CertificateStatus CInt+ deriving (Show, Eq)++newtype CertificateRequest = CertificateRequest CInt+ deriving (Show, Eq)++newtype OpenPGPCrtStatus = OpenPGPCrtStatus CInt+ deriving (Show, Eq)++newtype CloseRequest = CloseRequest CInt+ deriving (Show, Eq)++newtype Protocol = Protocol CInt+ deriving (Show, Eq)++newtype CertificateType = CertificateType CInt+ deriving (Show, Eq)++newtype X509CrtFormat = X509CrtFormat CInt+ deriving (Show, Eq)++newtype CertificatePrintFormats = CertificatePrintFormats CInt+ deriving (Show, Eq)++newtype PKAlgorithm = PKAlgorithm CInt+ deriving (Show, Eq)++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)++-- }}}++-- Global library info / state {{{++foreign import ccall safe "gnutls_check_version"+ gnutls_check_version :: CString -> IO CString++foreign import ccall safe "gnutls_global_init"+ gnutls_global_init :: IO ReturnCode++foreign import ccall safe "gnutls_global_deinit"+ gnutls_global_deinit :: IO ()++foreign import ccall safe "gnutls_global_set_log_function"+ gnutls_global_set_log_function :: FunPtr (CInt -> CString -> IO ()) -> IO ()++foreign import ccall safe "gnutls_global_set_log_level"+ gnutls_global_set_log_level :: CInt -> IO ()++-- }}}++-- Error handling {{{++foreign import ccall safe "gnutls_error_is_fatal"+ gnutls_error_is_fatal :: ReturnCode -> IO CInt++foreign import ccall safe "gnutls_perror"+ gnutls_perror :: ReturnCode -> IO ()++foreign import ccall safe "gnutls_strerror"+ gnutls_strerror :: ReturnCode -> IO CString++foreign import ccall safe "gnutls_strerror_name"+ gnutls_strerror_name :: ReturnCode -> IO CString++-- }}}++-- Sessions {{{++foreign import ccall safe "gnutls_init"+ gnutls_init :: Ptr (Ptr Session) -> ConnectionEnd -> IO ReturnCode++foreign import ccall safe "gnutls_deinit"+ gnutls_deinit :: Session -> IO ()++foreign import ccall safe "gnutls_handshake"+ gnutls_handshake :: Session -> IO ReturnCode++foreign import ccall safe "gnutls_rehandshake"+ gnutls_rehandshake :: Session -> IO ReturnCode++foreign import ccall safe "gnutls_bye"+ gnutls_bye :: Session -> CloseRequest -> IO ReturnCode++foreign import ccall safe "gnutls_set_default_priority"+ gnutls_set_default_priority :: Session -> IO ReturnCode++-- }}}++-- Alerts {{{++foreign import ccall safe "gnutls_alert_get_name"+ gnutls_alert_get_name :: AlertDescription -> IO CString++foreign import ccall safe "gnutls_error_to_alert"+ gnutls_error_to_alert :: ReturnCode -> Ptr AlertLevel -> IO AlertDescription++foreign import ccall safe "gnutls_alert_get"+ gnutls_alert_get :: Session -> IO AlertDescription++foreign import ccall safe "gnutls_alert_send_appropriate"+ gnutls_alert_send_appropriate :: Session -> ReturnCode -> IO ReturnCode++foreign import ccall safe "gnutls_alert_send"+ gnutls_alert_send :: Session -> AlertLevel -> AlertDescription -> IO ReturnCode++-- }}}++-- Certificates {{{++foreign import ccall safe "gnutls_certificate_allocate_credentials"+ gnutls_certificate_allocate_credentials :: Ptr (Ptr Credentials) -> IO ReturnCode++foreign import ccall safe "&gnutls_certificate_free_credentials"+ gnutls_certificate_free_credentials_funptr :: FunPtr (Ptr Credentials -> IO ())++foreign import ccall safe "gnutls_certificate_type_get_id"+ gnutls_certificate_type_get_id :: CString -> IO CertificateType++foreign import ccall safe "gnutls_certificate_type_get_name"+ gnutls_certificate_type_get_name :: CertificateType -> IO CString++foreign import ccall safe "gnutls_certificate_type_get"+ gnutls_certificate_type_get :: Session -> IO CertificateType++foreign import ccall safe "gnutls_certificate_type_list"+ gnutls_certificate_type_list :: IO (Ptr CertificateType)++-- }}}++-- Credentials {{{++foreign import ccall safe "gnutls_credentials_clear"+ gnutls_credentials_clear :: Session -> IO ()++foreign import ccall safe "gnutls_credentials_set"+ gnutls_credentials_set :: Session -> CredentialsType -> Ptr a -> IO ReturnCode++-- }}}++-- Records {{{++foreign import ccall safe "gnutls_record_check_pending"+ gnutls_record_check_pending :: Session -> IO CSize++foreign import ccall safe "gnutls_record_disable_padding"+ gnutls_record_disable_padding :: Session -> IO ()++foreign import ccall safe "gnutls_record_get_direction"+ gnutls_record_get_direction :: Session -> IO CInt++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++foreign import ccall safe "gnutls_record_send"+ gnutls_record_send :: Session -> Ptr a -> CSize -> IO CSize++foreign import ccall safe "gnutls_record_set_max_size"+ gnutls_record_set_max_size :: Session -> CSize -> IO CSize++-- }}}++-- Transports {{{++type TransportFunc = Transport -> Ptr () -> CSize -> IO CSize++foreign import ccall safe "gnutls_transport_set_push_function"+ gnutls_transport_set_push_function :: Session -> FunPtr TransportFunc -> IO ()++foreign import ccall safe "gnutls_transport_set_pull_function"+ gnutls_transport_set_pull_function :: Session -> FunPtr TransportFunc -> IO ()++foreign import ccall "wrapper"+ wrapTransportFunc :: TransportFunc -> IO (FunPtr TransportFunc)++-- }}}++-- 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"+ gnutls_global_set_mem_functions+ :: FunPtr (CSize -> IO (Ptr ()))+ -> FunPtr (CSize -> CSize -> IO (Ptr ()))+ -> FunPtr (Ptr () -> IO CInt)+ -> FunPtr (Ptr () -> CSize -> IO (Ptr ()))+ -> FunPtr (Ptr () -> IO ())+ -> IO ()++foreign import ccall safe "gnutls_malloc"+ gnutls_malloc :: CSize -> IO (Ptr a)++foreign import ccall safe "gnutls_free"+ gnutls_free :: Ptr a -> IO ()++foreign import ccall safe "gnutls_hex2bin"+ gnutls_hex2bin :: CString -> CSize -> Ptr Word8 -> Ptr CSize -> IO ReturnCode++foreign import ccall safe "gnutls_hex_decode"+ gnutls_hex_decode :: Ptr Datum -> Ptr Word8 -> Ptr CSize -> IO ReturnCode++foreign import ccall safe "gnutls_hex_encode"+ gnutls_hex_encode :: Ptr Datum -> CString -> Ptr CSize -> IO ReturnCode++-- }}}
− lib/Network/Protocol/TLS/GNU/Foreign.hs
@@ -1,276 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}---- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--module Network.Protocol.TLS.GNU.Foreign where--import Foreign-import Foreign.C---- Type aliases {{{--newtype ReturnCode = ReturnCode { unRC :: CInt }- deriving (Show, Eq)--newtype CipherAlgorithm = CipherAlgorithm CInt- deriving (Show, Eq)--newtype KXAlgorithm = KXAlgorithm CInt- deriving (Show, Eq)--newtype ParamsType = ParamsType CInt- deriving (Show, Eq)--newtype CredentialsType = CredentialsType CInt- deriving (Show, Eq)--newtype MACAlgorithm = MACAlgorithm CInt- deriving (Show, Eq)--newtype DigestAlgorithm = DigestAlgorithm CInt- deriving (Show, Eq)--newtype CompressionMethod = CompressionMethod CInt- deriving (Show, Eq)--newtype ConnectionEnd = ConnectionEnd CInt- deriving (Show, Eq)--newtype AlertLevel = AlertLevel CInt- deriving (Show, Eq)--newtype AlertDescription = AlertDescription CInt- deriving (Show, Eq)--newtype HandshakeDescription = HandshakeDescription CInt- deriving (Show, Eq)--newtype CertificateStatus = CertificateStatus CInt- deriving (Show, Eq)--newtype CertificateRequest = CertificateRequest CInt- deriving (Show, Eq)--newtype OpenPGPCrtStatus = OpenPGPCrtStatus CInt- deriving (Show, Eq)--newtype CloseRequest = CloseRequest CInt- deriving (Show, Eq)--newtype Protocol = Protocol CInt- deriving (Show, Eq)--newtype CertificateType = CertificateType CInt- deriving (Show, Eq)--newtype X509CrtFormat = X509CrtFormat CInt- deriving (Show, Eq)--newtype CertificatePrintFormats = CertificatePrintFormats CInt- deriving (Show, Eq)--newtype PKAlgorithm = PKAlgorithm CInt- deriving (Show, Eq)--newtype SignAlgorithm = SignAlgorithm CInt- deriving (Show, Eq)--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 Datum = Datum (Ptr Word8, CUInt)---- }}}---- Global library info / state {{{--foreign import ccall safe "gnutls_check_version"- gnutls_check_version :: CString -> IO CString--foreign import ccall safe "gnutls_global_init"- gnutls_global_init :: IO ReturnCode--foreign import ccall safe "gnutls_global_deinit"- gnutls_global_deinit :: IO ()--foreign import ccall safe "gnutls_global_set_log_function"- gnutls_global_set_log_function :: FunPtr (CInt -> CString -> IO ()) -> IO ()--foreign import ccall safe "gnutls_global_set_log_level"- gnutls_global_set_log_level :: CInt -> IO ()---- }}}---- Error handling {{{--foreign import ccall safe "gnutls_error_is_fatal"- gnutls_error_is_fatal :: ReturnCode -> IO CInt--foreign import ccall safe "gnutls_perror"- gnutls_perror :: ReturnCode -> IO ()--foreign import ccall safe "gnutls_strerror"- gnutls_strerror :: ReturnCode -> IO CString--foreign import ccall safe "gnutls_strerror_name"- gnutls_strerror_name :: ReturnCode -> IO CString---- }}}---- Sessions {{{--foreign import ccall safe "gnutls_init"- gnutls_init :: Ptr (Ptr Session) -> ConnectionEnd -> IO ReturnCode--foreign import ccall safe "gnutls_deinit"- gnutls_deinit :: Session -> IO ()--foreign import ccall safe "gnutls_handshake"- gnutls_handshake :: Session -> IO ReturnCode--foreign import ccall safe "gnutls_rehandshake"- gnutls_rehandshake :: Session -> IO ReturnCode--foreign import ccall safe "gnutls_bye"- gnutls_bye :: Session -> CloseRequest -> IO ReturnCode--foreign import ccall safe "gnutls_set_default_priority"- gnutls_set_default_priority :: Session -> IO ReturnCode---- }}}---- Alerts {{{--foreign import ccall safe "gnutls_alert_get_name"- gnutls_alert_get_name :: AlertDescription -> IO CString--foreign import ccall safe "gnutls_error_to_alert"- gnutls_error_to_alert :: ReturnCode -> Ptr AlertLevel -> IO AlertDescription--foreign import ccall safe "gnutls_alert_get"- gnutls_alert_get :: Session -> IO AlertDescription--foreign import ccall safe "gnutls_alert_send_appropriate"- gnutls_alert_send_appropriate :: Session -> ReturnCode -> IO ReturnCode--foreign import ccall safe "gnutls_alert_send"- gnutls_alert_send :: Session -> AlertLevel -> AlertDescription -> IO ReturnCode---- }}}---- Certificates {{{--foreign import ccall safe "gnutls_certificate_allocate_credentials"- gnutls_certificate_allocate_credentials :: Ptr (Ptr Credentials) -> IO ReturnCode--foreign import ccall safe "&gnutls_certificate_free_credentials"- gnutls_certificate_free_credentials_funptr :: FunPtr (Ptr Credentials -> IO ())--foreign import ccall safe "gnutls_certificate_type_get_id"- gnutls_certificate_type_get_id :: CString -> IO CertificateType--foreign import ccall safe "gnutls_certificate_type_get_name"- gnutls_certificate_type_get_name :: CertificateType -> IO CString--foreign import ccall safe "gnutls_certificate_type_get"- gnutls_certificate_type_get :: Session -> IO CertificateType--foreign import ccall safe "gnutls_certificate_type_list"- gnutls_certificate_type_list :: IO (Ptr CertificateType)---- }}}---- Credentials {{{--foreign import ccall safe "gnutls_credentials_clear"- gnutls_credentials_clear :: Session -> IO ()--foreign import ccall safe "gnutls_credentials_set"- gnutls_credentials_set :: Session -> CredentialsType -> Ptr a -> IO ReturnCode---- }}}---- Records {{{--foreign import ccall safe "gnutls_record_check_pending"- gnutls_record_check_pending :: Session -> IO CSize--foreign import ccall safe "gnutls_record_disable_padding"- gnutls_record_disable_padding :: Session -> IO ()--foreign import ccall safe "gnutls_record_get_direction"- gnutls_record_get_direction :: Session -> IO CInt--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--foreign import ccall safe "gnutls_record_send"- gnutls_record_send :: Session -> Ptr a -> CSize -> IO CSize--foreign import ccall safe "gnutls_record_set_max_size"- gnutls_record_set_max_size :: Session -> CSize -> IO CSize---- }}}---- Transports {{{--type TransportFunc = Transport -> Ptr () -> CSize -> IO CSize--foreign import ccall safe "gnutls_transport_set_push_function"- gnutls_transport_set_push_function :: Session -> FunPtr TransportFunc -> IO ()--foreign import ccall safe "gnutls_transport_set_pull_function"- gnutls_transport_set_pull_function :: Session -> FunPtr TransportFunc -> IO ()--foreign import ccall "wrapper"- wrapTransportFunc :: TransportFunc -> IO (FunPtr TransportFunc)---- }}}---- Utility {{{--foreign import ccall safe "gnutls_global_set_mem_functions"- gnutls_global_set_mem_functions- :: FunPtr (CSize -> IO (Ptr ()))- -> FunPtr (CSize -> CSize -> IO (Ptr ()))- -> FunPtr (Ptr () -> IO CInt)- -> FunPtr (Ptr () -> CSize -> IO (Ptr ()))- -> FunPtr (Ptr () -> IO ())- -> IO ()--foreign import ccall safe "gnutls_malloc"- gnutls_malloc :: CSize -> IO (Ptr a)--foreign import ccall safe "gnutls_free"- gnutls_free :: Ptr a -> IO ()--foreign import ccall safe "gnutls_hex2bin"- gnutls_hex2bin :: CString -> CSize -> Ptr Word8 -> Ptr CSize -> IO ReturnCode--foreign import ccall safe "gnutls_hex_decode"- gnutls_hex_decode :: Ptr Datum -> Ptr Word8 -> Ptr CSize -> IO ReturnCode--foreign import ccall safe "gnutls_hex_encode"- gnutls_hex_encode :: Ptr Datum -> CString -> Ptr CSize -> IO ReturnCode---- }}}