hsgnutls (empty) → 0.2.3.2
raw patch · 17 files changed
+2313/−0 lines, 17 filesdep +basedep +bytestringdep +mtlsetup-changed
Dependencies added: base, bytestring, mtl, old-time
Files
- Codec/Encryption.chs +181/−0
- Codec/Encryption/Ciphers.hsc +84/−0
- LICENSE +510/−0
- Network/GnuTLS.hs +13/−0
- Network/GnuTLS/Attributes.hs +142/−0
- Network/GnuTLS/Errors.hsc +9/−0
- Network/GnuTLS/GnuTLS.chs +593/−0
- Network/GnuTLS/GnuTLSMonad.chs +48/−0
- Network/GnuTLS/IOWrap.hs +17/−0
- Network/GnuTLS/Internals.chs +157/−0
- Network/GnuTLS/OID.hsc +48/−0
- Network/GnuTLS/RefCount.hs +31/−0
- Network/GnuTLS/X509.chs +342/−0
- Setup.hs +5/−0
- crypt_helpers.c +30/−0
- helpers.c +51/−0
- hsgnutls.cabal +52/−0
+ Codec/Encryption.chs view
@@ -0,0 +1,181 @@++module Codec.Encryption+ (Cipher(..)+ ,Word128(..)+ ,Word192(..)+ ,pkcs5+ ,unpkcs5+ ,module Codec.Encryption.Ciphers+ ) where++#include <gcrypt.h>++import Foreign+import Foreign.C.Types+import Prelude hiding (catch)+import Control.Exception (catch)+import Data.Bits+import Data.ByteString(ByteString,useAsCStringLen)+import qualified Data.ByteString as BS+import Data.ByteString.Internal(create)+import Data.List(foldl')+import System.IO.Unsafe(unsafePerformIO)+import Codec.Encryption.Ciphers++data Word128 = Word128 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Show,Eq)+data Word192 = Word192 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Show,Eq)++instance Num Word128 where+ fromInteger num = let+ v1 = fromInteger (shiftR num 64)+ v2 = fromInteger num+ in Word128 v1 v2++instance Num Word192 where+ fromInteger num = let+ v1 = fromInteger (shiftR num 128)+ v2 = fromInteger (shiftR num 64)+ v3 = fromInteger num+ in Word192 v1 v2 v3++class (Show ciph,Show mode,CipherType ciph,CipherMode mode,CipherDatum key,CipherDatum iv) =>+ Cipher ciph mode key iv | ciph mode -> key iv where+ encrypt :: ciph -> mode -> key -> iv -> ByteString -> ByteString+ encrypt ct cm ck ci str = unsafePerformIO $ do+ ciph <- cipherOpen ct cm []+ setKey ciph ck+ setIV ciph ci+ cipherEncrypt ciph str+ decrypt :: ciph -> mode -> key -> iv -> ByteString -> Maybe ByteString+ decrypt ct cm ck ci str = unsafePerformIO ((do+ ciph <- cipherOpen ct cm []+ setKey ciph ck+ setIV ciph ci+ cipherDecrypt ciph str >>= return.Just) `catch` (\_ -> return Nothing))++class CipherDatum k where+ setKey :: CipherHandle -> k -> IO ()+ setIV :: CipherHandle -> k -> IO ()++instance CipherDatum Word64 where+ setKey = cipherSetKey+ setIV = cipherSetIV++instance CipherDatum () where+ setKey _ _ = return ()+ setIV _ _ = return ()++instance CipherDatum Word128 where+ setKey = cipherSetKey + setIV = cipherSetIV++instance CipherDatum Word192 where+ setKey = cipherSetKey + setIV = cipherSetIV++instance Storable Word192 where+ sizeOf _ = 24+ alignment _ = 4+ peek ptr = do+ v1 <- peek (castPtr ptr)+ v2 <- peek (castPtr (plusPtr ptr 8))+ v3 <- peek (castPtr (plusPtr ptr 16))+ return (Word192 v1 v2 v3)+ poke ptr (Word192 v1 v2 v3) = do+ poke (castPtr ptr) v1+ poke (castPtr (plusPtr ptr 8)) v2+ poke (castPtr (plusPtr ptr 16)) v3++instance Storable Word128 where+ sizeOf _ = 16+ alignment _ = 4+ peek ptr = do+ v1 <- peek (castPtr ptr)+ v2 <- peek (castPtr (plusPtr ptr 8))+ return (Word128 v1 v2)+ poke ptr (Word128 v1 v2) = do+ poke (castPtr ptr) v1+ poke (castPtr (plusPtr ptr 8)) v2++instance Cipher CipherDES ModeECB Word64 ()+instance Cipher CipherDES ModeCBC Word64 Word64+instance Cipher Cipher3DES ModeECB Word192 ()+instance Cipher Cipher3DES ModeCBC Word192 Word192+instance Cipher CipherCast5 ModeECB Word128 ()+instance Cipher CipherBlowfish ModeECB Word128 ()+-- ...++{#pointer gcry_cipher_hd_t as CipherHandle foreign newtype#}++flags :: [CUInt] -> CUInt+flags = foldl' (.|.) 0++foreign import ccall unsafe "gcrypt.h &gcry_cipher_close" gcry_cipher_close :: FunPtr (Ptr CipherHandle -> IO ())++cipherOpen :: (Show tp,Show md,CipherType tp,CipherMode md) =>+ tp -> md -> [CipherFlag] -> IO CipherHandle+cipherOpen ct cm flg = alloca $ \hand -> do+ res <- {#call unsafe gcry_cipher_open#} hand (cipherTypeToC ct) (cipherModeToC cm) (flags (map flagToC flg))+ if res /= 0+ then error ("Failed to open cipher "++show ct++" with mode "++show cm++" and flags "++show flg)+ else (do+ fp <- newForeignPtr gcry_cipher_close =<< peek hand+ return $ CipherHandle fp)++#c+gcry_error_t gcry_cipher_setkey2 (gcry_cipher_hd_t H, void *K, size_t L);+gcry_error_t gcry_cipher_setiv2 (gcry_cipher_hd_t H, void *K, size_t L);+#endc++cipherSetKey :: Storable a => CipherHandle -> a -> IO ()+cipherSetKey hand dat = with dat $ \ptr -> cipherSetKey' hand (castPtr ptr) (sizeOf dat)++cipherSetKey' :: CipherHandle -> Ptr () -> Int -> IO ()+cipherSetKey' hand addr len = withCipherHandle hand $ \ptr -> do+ res <- {#call unsafe gcry_cipher_setkey2#} ptr addr (fromIntegral len)+ if res /= 0+ then error "Failed to set key"+ else return ()++cipherSetIV :: Storable a => CipherHandle -> a -> IO ()+cipherSetIV hand dat = with dat $ \ptr -> cipherSetIV' hand (castPtr ptr) (sizeOf dat)++cipherSetIV' :: CipherHandle -> Ptr () -> Int -> IO ()+cipherSetIV' hand addr len = withCipherHandle hand $ \ptr -> do+ res <- {#call unsafe gcry_cipher_setiv2#} ptr addr (fromIntegral len)+ if res /= 0+ then error "Failed to set IV"+ else return ()++cipherEncrypt :: CipherHandle -> ByteString -> IO ByteString+cipherEncrypt hand str = withCipherHandle hand $ \ptr ->+ useAsCStringLen str $ \(strp,len) ->+ create len $ \optr -> do+ res <- {#call unsafe gcry_cipher_encrypt#} ptr (castPtr optr) (fromIntegral len) (castPtr strp) (fromIntegral len)+ if res /= 0+ then error "Failed to encrypt data"+ else return ()++cipherDecrypt :: CipherHandle -> ByteString -> IO ByteString+cipherDecrypt hand str = withCipherHandle hand $ \ptr ->+ useAsCStringLen str $ \(strp,len) ->+ create len $ \optr -> do+ res <- {#call unsafe gcry_cipher_decrypt#} ptr (castPtr optr) (fromIntegral len) (castPtr strp) (fromIntegral len)+ if res /= 0+ then error "Failed to decrypt data"+ else return ()++pkcs5 :: ByteString -> ByteString+pkcs5 bs = let+ len = (BS.length bs) `mod` 8+ pad = BS.replicate (8-len) (fromIntegral (8-len))+ in bs `BS.append` pad++unpkcs5 :: ByteString -> Maybe ByteString+unpkcs5 bs = let+ len = BS.length bs+ pchar = BS.last bs+ (str,pad) = BS.splitAt (len-fromIntegral pchar) bs+ in if BS.all (==pchar) pad+ then Just str+ else Nothing
+ Codec/Encryption/Ciphers.hsc view
@@ -0,0 +1,84 @@+module Codec.Encryption.Ciphers where++#include <gcrypt.h>++import Foreign.C.Types++class CipherType a where+ cipherTypeToC :: a -> CInt++class CipherMode a where+ cipherModeToC :: a -> CInt++data CipherIDEA = CipherIDEA deriving Show+data Cipher3DES = Cipher3DES deriving Show+data CipherCast5 = CipherCast5 deriving Show+data CipherBlowfish = CipherBlowfish deriving Show+data CipherAES = CipherAES deriving Show+data CipherAES128 = CipherAES128 deriving Show+data CipherAES192 = CipherAES192 deriving Show+data CipherAES256 = CipherAES256 deriving Show+data CipherRIJNDAEL = CipherRIJDNDAEL deriving Show+data CipherRIJNDAEL128 = CipherRIJNDAEL128 deriving Show+data CipherRIJNDAEL192 = CipherRIJNDAEL192 deriving Show+data CipherRIJNDAEL256 = CipherRIJNDAEL256 deriving Show+data CipherTwofish = CipherTwofish deriving Show+data CipherTwofish128 = CipherTwofish128 deriving Show+data CipherArcfour = CipherArcfour deriving Show+data CipherDES = CipherDES deriving Show++instance CipherType CipherIDEA where cipherTypeToC _ = #const GCRY_CIPHER_IDEA+instance CipherType Cipher3DES where cipherTypeToC _ = #const GCRY_CIPHER_3DES+instance CipherType CipherCast5 where cipherTypeToC _ = #const GCRY_CIPHER_CAST5+instance CipherType CipherBlowfish where cipherTypeToC _ = #const GCRY_CIPHER_BLOWFISH+instance CipherType CipherAES where cipherTypeToC _ = #const GCRY_CIPHER_AES+instance CipherType CipherAES128 where cipherTypeToC _ = #const GCRY_CIPHER_AES128+instance CipherType CipherAES192 where cipherTypeToC _ = #const GCRY_CIPHER_AES192+instance CipherType CipherAES256 where cipherTypeToC _ = #const GCRY_CIPHER_AES256+instance CipherType CipherRIJNDAEL where cipherTypeToC _ = #const GCRY_CIPHER_RIJNDAEL+instance CipherType CipherRIJNDAEL128 where cipherTypeToC _ = #const GCRY_CIPHER_RIJNDAEL128+instance CipherType CipherRIJNDAEL192 where cipherTypeToC _ = #const GCRY_CIPHER_RIJNDAEL192+instance CipherType CipherRIJNDAEL256 where cipherTypeToC _ = #const GCRY_CIPHER_RIJNDAEL256+instance CipherType CipherTwofish where cipherTypeToC _ = #const GCRY_CIPHER_TWOFISH+instance CipherType CipherTwofish128 where cipherTypeToC _ = #const GCRY_CIPHER_TWOFISH128+instance CipherType CipherArcfour where cipherTypeToC _ = #const GCRY_CIPHER_ARCFOUR+instance CipherType CipherDES where cipherTypeToC _ = #const GCRY_CIPHER_DES++{-data CipherMode+ = ModeNone+ | ModeECB+ | ModeCFB+ | ModeCBC+ | ModeStream+ | ModeOFB+ | ModeCTR+ deriving (Show,Eq)-}++data ModeNone = ModeNone deriving Show+data ModeECB = ModeECB deriving Show+data ModeCFB = ModeCFB deriving Show+data ModeCBC = ModeCBC deriving Show+data ModeStream = ModeStream deriving Show+data ModeOFB = ModeOFB deriving Show+data ModeCTR = ModeCTR deriving Show++instance CipherMode ModeNone where cipherModeToC _ = #const GCRY_CIPHER_MODE_NONE+instance CipherMode ModeECB where cipherModeToC _ = #const GCRY_CIPHER_MODE_ECB+instance CipherMode ModeCFB where cipherModeToC _ = #const GCRY_CIPHER_MODE_CFB+instance CipherMode ModeCBC where cipherModeToC _ = #const GCRY_CIPHER_MODE_CBC+instance CipherMode ModeStream where cipherModeToC _ = #const GCRY_CIPHER_MODE_STREAM+instance CipherMode ModeOFB where cipherModeToC _ = #const GCRY_CIPHER_MODE_OFB+instance CipherMode ModeCTR where cipherModeToC _ = #const GCRY_CIPHER_MODE_CTR++data CipherFlag+ = Secure+ | EnableSync+ | CBC_CTS+ | CBC_MAC+ deriving (Show,Eq)++flagToC :: CipherFlag -> CUInt+flagToC Secure = #const GCRY_CIPHER_SECURE+flagToC EnableSync = #const GCRY_CIPHER_ENABLE_SYNC+flagToC CBC_CTS = #const GCRY_CIPHER_CBC_CTS+flagToC CBC_MAC = #const GCRY_CIPHER_CBC_MAC
+ LICENSE view
@@ -0,0 +1,510 @@++ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL. It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++ This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it. You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations+below.++ When we speak of free software, we are referring to freedom of use,+not price. Our General Public Licenses are designed to make sure that+you have the freedom to distribute copies of free software (and charge+for this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++ To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights. These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++ For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you. You must make sure that they, too, receive or can get the source+code. If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it. And you must show them these terms so they know their rights.++ We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++ To protect each distributor, we want to make it very clear that+there is no warranty for the free library. Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++ Finally, software patents pose a constant threat to the existence of+any free program. We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder. Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++ Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License. This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License. We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++ When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library. The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom. The Lesser General+Public License permits more lax criteria for linking other code with+the library.++ We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License. It also provides other free software developers Less+of an advantage over competing non-free programs. These disadvantages+are the reason we use the ordinary General Public License for many+libraries. However, the Lesser license provides advantages in certain+special circumstances.++ For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it+becomes a de-facto standard. To achieve this, non-free programs must+be allowed to use the library. A more frequent case is that a free+library does the same job as widely used non-free libraries. In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++ In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software. For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++ Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++ The precise terms and conditions for copying, distribution and+modification follow. Pay close attention to the difference between a+"work based on the library" and a "work that uses the library". The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.++ GNU LESSER GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++ A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++ The "Library", below, refers to any such software library or work+which has been distributed under these terms. A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language. (Hereinafter, translation is+included without limitation in the term "modification".)++ "Source code" for a work means the preferred form of the work for+making modifications to it. For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control+compilation and installation of the library.++ Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it). Whether that is true depends on what the Library does+and what the program that uses the Library does.++ 1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++ You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++ 2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) The modified work must itself be a software library.++ b) You must cause the files modified to carry prominent notices+ stating that you changed the files and the date of any change.++ c) You must cause the whole of the work to be licensed at no+ charge to all third parties under the terms of this License.++ d) If a facility in the modified Library refers to a function or a+ table of data to be supplied by an application program that uses+ the facility, other than as an argument passed when the facility+ is invoked, then you must make a good faith effort to ensure that,+ in the event an application does not supply such function or+ table, the facility still operates, and performs whatever part of+ its purpose remains meaningful.++ (For example, a function in a library to compute square roots has+ a purpose that is entirely well-defined independent of the+ application. Therefore, Subsection 2d requires that any+ application-supplied function or table used by this function must+ be optional: if the application does not supply it, the square+ root function must still compute square roots.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library. To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License. (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.) Do not make any other change in+these notices.++ Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++ This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++ 4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++ If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++ 5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library". Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++ However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library". The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++ When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library. The+threshold for this to be true is not precisely defined by law.++ If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work. (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++ Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++ 6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++ You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License. You must supply a copy of this License. If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License. Also, you must do one+of these things:++ a) Accompany the work with the complete corresponding+ machine-readable source code for the Library including whatever+ changes were used in the work (which must be distributed under+ Sections 1 and 2 above); and, if the work is an executable linked+ with the Library, with the complete machine-readable "work that+ uses the Library", as object code and/or source code, so that the+ user can modify the Library and then relink to produce a modified+ executable containing the modified Library. (It is understood+ that the user who changes the contents of definitions files in the+ Library will not necessarily be able to recompile the application+ to use the modified definitions.)++ b) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (1) uses at run time a+ copy of the library already present on the user's computer system,+ rather than copying library functions into the executable, and (2)+ will operate properly with a modified version of the library, if+ the user installs one, as long as the modified version is+ interface-compatible with the version that the work was made with.++ c) Accompany the work with a written offer, valid for at least+ three years, to give the same user the materials specified in+ Subsection 6a, above, for a charge no more than the cost of+ performing this distribution.++ d) If distribution of the work is made by offering access to copy+ from a designated place, offer equivalent access to copy the above+ specified materials from the same place.++ e) Verify that the user has already received a copy of these+ materials or that you have already sent this user a copy.++ For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it. However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++ It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system. Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++ 7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++ a) Accompany the combined library with a copy of the same work+ based on the Library, uncombined with any other library+ facilities. This must be distributed under the terms of the+ Sections above.++ b) Give prominent notice with the combined library of the fact+ that part of it is a work based on the Library, and explaining+ where to find the accompanying uncombined form of the same work.++ 8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License. Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License. However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++ 9. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Library or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++ 10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++ 11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all. For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply, and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License+may add an explicit geographical distribution limitation excluding those+countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 13. The Free Software Foundation may publish revised and/or new+versions of the Lesser General Public License from time to time.+Such new versions will be similar in spirit to the present version,+but may differ in detail to address new problems or concerns.++Each version is given a distinguishing version number. If the Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation. If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++ 14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission. For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this. Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++ NO WARRANTY++ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Libraries++ If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change. You can do so by permitting+redistribution under these terms (or, alternatively, under the terms+of the ordinary General Public License).++ To apply these terms, attach the following notices to the library.+It is safest to attach them to the start of each source file to most+effectively convey the exclusion of warranty; and each file should+have at least the "copyright" line and a pointer to where the full+notice is found.+++ <one line to give the library's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or+your school, if any, to sign a "copyright disclaimer" for the library,+if necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the+ library `Frob' (a library for tweaking knobs) written by James+ Random Hacker.++ <signature of Ty Coon>, 1 April 1990+ Ty Coon, President of Vice++That's all there is to it!++
+ Network/GnuTLS.hs view
@@ -0,0 +1,13 @@+module Network.GnuTLS(+ module Network.GnuTLS.Attributes,+ module Network.GnuTLS.GnuTLS,+ module Network.GnuTLS.GnuTLSMonad,+ module Network.GnuTLS.OID,+ module Network.GnuTLS.X509+ ) where++import Network.GnuTLS.Attributes+import Network.GnuTLS.GnuTLS+import Network.GnuTLS.X509+import Network.GnuTLS.OID+import Network.GnuTLS.GnuTLSMonad
+ Network/GnuTLS/Attributes.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ExistentialQuantification #-}+{- GIMP Toolkit (GTK) Attributes interface++ Author : Duncan Coutts++ Created: 21 January 2005++ Copyright (C) 2005 Duncan Coutts++ Partially derived from the hs-fltk and wxHaskell projects which+ are both under LGPL compatible licenses.++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details. -}++{- |+Maintainer : gtk2hs-users@lists.sourceforge.net+Stability : experimental+Portability : portable++Attributes interface++Attributes of an object can be get and set. Getting the value of an+object's attribute is straingtforward. As an example consider a @button@+widget and an attribute called @buttonLabel@.++> value <- get button buttonLabel++The syntax for setting or updating an attribute is only slightly more+complex. At the simplest level it is just:++> set button [ buttonLabel := value ]++However as the list notation would indicate, you can set or update multiple+attributes of the same object in one go:++> set button [ buttonLabel := value, buttonFocusOnClick := False ]++You are not limited to setting the value of an attribute, you can also+apply an update function to an attribute's value. That is the function+receives the current value of the attribute and returns the new value.++> set spinButton [ spinButtonValue :~ (+1) ]++There are other variants of these operators, (see 'AttrOp'). ':=>' and+':~>' and like ':=' and ':~' but operate in the 'IO' monad rather+than being pure. There is also '::=' and '::~' which take the object+as an extra parameter.++Attributes can be read only, write only or both read\/write. -}++module Network.GnuTLS.Attributes (+ -- * Attribute types+ Attr,+ ReadAttr,+ WriteAttr,+ ReadWriteAttr,++ -- * Interface for getting, setting and updating attributes+ AttrOp(..),+ get,+ set,++ -- * Internal attribute constructors+ newAttr,+ readAttr,+ writeAttr,+ ) where++infixr 0 :=,:~,:=>,:~>,::=,::~++-- | An ordinary attribute. Most attributes have the same get and set types.+type Attr o a = ReadWriteAttr o a a++-- | A read-only attribute.+type ReadAttr o a = ReadWriteAttr o a ()++-- | A write-only attribute.+type WriteAttr o b = ReadWriteAttr o () b++-- | A generalised attribute with independent get and set types.+data ReadWriteAttr o a b = Attr !(o -> IO a) !(o -> b -> IO ())+++-- | Create a new attribute with a getter and setter function.+newAttr :: (o -> IO a) -> (o -> b -> IO ()) -> ReadWriteAttr o a b+newAttr getter setter = Attr getter setter++-- | Create a new read-only attribute.+readAttr :: (o -> IO a) -> ReadAttr o a+readAttr getter = Attr getter (\_ _ -> return ())++-- | Create a new write-only attribute.+writeAttr :: (o -> b -> IO ()) -> WriteAttr o b+writeAttr setter = Attr (\_ -> return ()) setter+++-- | A set or update operation on an attribute.+data AttrOp o+ = forall a b.+ ReadWriteAttr o a b := b -- ^ Assign a value to an+ -- attribute.+ | forall a b.+ ReadWriteAttr o a b :~ ( a -> b) -- ^ Apply an update function to+ -- an attribute.+ | forall a b.+ ReadWriteAttr o a b :=> ( IO b) -- ^ Assign the result of an IO+ -- action to an attribute.+ | forall a b.+ ReadWriteAttr o a b :~> ( a -> IO b) -- ^ Apply a IO update function+ -- to an attribute.+ | forall a b.+ ReadWriteAttr o a b ::= (o -> b) -- ^ Assign a value to an+ -- attribute with the object as+ -- an argument.+ | forall a b.+ ReadWriteAttr o a b ::~ (o -> a -> b) -- ^ Apply an update function to+ -- an attribute with the object+ -- as an argument.++-- | Set a number of properties for some object.+set :: o -> [AttrOp o] -> IO ()+set obj = mapM_ app+ where+ app (Attr _ setter := x) = setter obj x+ app (Attr getter setter :~ f) = getter obj >>= \v -> setter obj (f v)+ app (Attr _ setter :=> x) = x >>= setter obj+ app (Attr getter setter :~> f) = getter obj >>= f >>= setter obj++ app (Attr _ setter ::= f) = setter obj (f obj)+ app (Attr getter setter ::~ f) = getter obj >>= \v -> setter obj (f obj v)++-- | Get an Attr of an object.+get :: o -> ReadWriteAttr o a b -> IO a+get o (Attr getter _) = getter o
+ Network/GnuTLS/Errors.hsc view
@@ -0,0 +1,9 @@+module Network.GnuTLS.Errors where++#include <gnutls/gnutls.h>++import Foreign.C.Types+--import Network.GnuTLS.GnuTLSMonad++errorShortMemory :: CInt+errorShortMemory = #{const GNUTLS_E_SHORT_MEMORY_BUFFER}
+ Network/GnuTLS/GnuTLS.chs view
@@ -0,0 +1,593 @@++module Network.GnuTLS.GnuTLS + (-- * Enumerations+ CipherAlgorithm(..), KxAlgorithm(..), ParamsType(..), CredentialsType(..),+ MacAlgorithm(..), DigestAlgorithm(..), CompressionMethod(..), ConnectionEnd(..),+ AlertLevel(..), AlertDescription(..), HandshakeDescription(..), CertificateStatus(..), + CertificateRequest(..), CloseRequest(..), Protocol(..), + CertificateType(..), X509CertificateFormat(..), PkAlgorithm(..), SignAlgorithm(..), + -- * Types+ Session, DH, RSA, AnonymousServerCredentials, AnonymousClientCredentials,+ Server, Client, Transport, CertificateCredentials,Datum(..),+ -- * Priority+ SetPriority(..), setDefaultPriority, setDefaultExportPriority,+ -- * Credentials+ SetCredentials(..), Clear(..),+ -- * Creating connections+ tlsClient, tlsServer,+ -- * Session Accessors+ priorities, credentials, dhPrimeBits, transport, handle, clientCert,+#ifdef NETWORK_ALT+ sock,+#endif+ -- * Managing connection+ handshake, rehandshake, bye, + setMaxHandshakePacketLength,+ -- * Querying connection attributes+ serverWantedAuth, verifyPeer, isResumed, + getAlert, getCipher, getKx, getMac, getCompression, getCertificateType, getProtocol, + getCredentialsType,+#ifndef COMPAT_GNUTLS_1_0+ getServerCredentialsType, getClientCredentialsType,+#endif+ getPeersCertificatesRaw,+ -- * Sending and receiving data+ tlsSend, tlsSendString, tlsRecv, tlsRecvString, tlsCheckPending,+ -- * Certificate functions+ certificateCredentials, freeKeys, freeCas, freeCaNames, freeCrls,+ certificateTrustFile, certificateCrlFile, certificateKeyFile,+ -- * Miscellaneous+ anonymousServerCredentials, anonymousClientCredentials,+ SetDHParams(..), CredParameter(..),+ newDH, newRSA,cipherKeySize,cipherSuiteName,+ version, gnutlsGlobalInit + ) where++import Control.Concurrent+import Data.Bits((.&.), (.|.))+import Data.IORef(newIORef, readIORef)+import Foreign+import Foreign.C+import qualified Foreign.Concurrent as FC+import Foreign.Ptr+import System.IO+import System.IO.Unsafe+import Network.GnuTLS.Attributes+import Network.GnuTLS.Internals+import Network.GnuTLS.RefCount+#ifdef NETWORK_ALT+import Network.Alt+#endif++#include <gnutls/gnutls.h>++{#context prefix = "gnutls" #}+++--------------------------------------------------------------------------------+------------------------------ Types ---------------------------------------+--------------------------------------------------------------------------------++data DH = DH (ForeignPtr ())! RefCount+data RSA = RSA (ForeignPtr ())! RefCount+data AnonymousServerCredentials = ASC (ForeignPtr ())! RefCount+data AnonymousClientCredentials = ACC (ForeignPtr ())! RefCount+data CertificateCredentials = CC (ForeignPtr ())! RefCount++data Server+data Client+type Transport = Ptr () -> Int -> Ptr CInt -> IO Int++withDH (DH fp _) = withForeignPtr fp+withRSA (RSA fp _) = withForeignPtr fp+withAnonymousServerCredentials (ASC fp _) = withForeignPtr fp+withAnonymousClientCredentials (ACC fp _) = withForeignPtr fp+withCertificateCredentials (CC fp _) = withForeignPtr fp+++--------------------------------------------------------------------------------+------------------------- Show Functions -----------------------------------+--------------------------------------------------------------------------------++instance Show AlertDescription where+ show a = unsafePerformIO $ gnutlsAlertGetName a+{#fun unsafe gnutls_alert_get_name as ^ {enumCInt `AlertDescription'} -> `String' safePeekCString* #}++instance Show CipherAlgorithm where+ show a = unsafePerformIO $ gnutlsCipherGetName a+{#fun unsafe gnutls_cipher_get_name as ^ {enumCInt `CipherAlgorithm'} -> `String' safePeekCString* #}++instance Show MacAlgorithm where+ show a = unsafePerformIO $ gnutlsMacGetName a+{#fun unsafe gnutls_mac_get_name as ^ {enumCInt `MacAlgorithm'} -> `String' safePeekCString* #}++instance Show CompressionMethod where+ show a = unsafePerformIO $ gnutlsCompressionGetName a+{#fun unsafe gnutls_compression_get_name as ^ {enumCInt `CompressionMethod'} -> `String' safePeekCString* #}++instance Show KxAlgorithm where+ show a = unsafePerformIO $ gnutlsKxGetName a+{#fun unsafe gnutls_kx_get_name as ^ {enumCInt `KxAlgorithm'} -> `String' safePeekCString* #}++instance Show CertificateType where+ show a = unsafePerformIO $ gnutlsCertificateTypeGetName a+{#fun unsafe gnutls_certificate_type_get_name as ^ {enumCInt `CertificateType'} -> `String' safePeekCString* #}++instance Show Protocol where+ show a = unsafePerformIO $ gnutlsProtocolGetName a+{#fun unsafe gnutls_protocol_get_name as ^ {enumCInt `Protocol'} -> `String' safePeekCString* #}++instance Show PkAlgorithm where+ show a = unsafePerformIO $ gnutlsPkAlgorithmGetName a+{#fun unsafe gnutls_pk_algorithm_get_name as ^ {enumCInt `PkAlgorithm'} -> `String' safePeekCString* #}++instance Show SignAlgorithm where+ show a = unsafePerformIO $ gnutlsSignAlgorithmGetName a+{#fun unsafe gnutls_sign_algorithm_get_name as ^ {enumCInt `SignAlgorithm'} -> `String' safePeekCString* #}++--------------------------------------------------------------------------------+-------------------------- Set Priority ------------------------------------+--------------------------------------------------------------------------------++setpwrap :: Enum e => (Ptr () -> Ptr CInt -> IO CInt) -> Session t -> [e] -> IO ()+setpwrap comp s x = do+ withEnumList0 x $ \e -> do+ withSession s $ \p -> do+ comp p e >>= throwGnutlsIf++-- | Set the priority of the specified category.+-- On servers this means the set of acceptable values,+-- on clients it sets the priorities.+class SetPriority a where setPriority :: Session t -> [a] -> IO ()++instance SetPriority CipherAlgorithm where + setPriority = setpwrap {#call unsafe gnutls_cipher_set_priority #}++instance SetPriority MacAlgorithm where + setPriority = setpwrap {#call unsafe gnutls_mac_set_priority #}++instance SetPriority CompressionMethod where + setPriority = setpwrap {#call unsafe gnutls_compression_set_priority #}++instance SetPriority KxAlgorithm where + setPriority = setpwrap {#call unsafe gnutls_kx_set_priority #}++instance SetPriority Protocol where + setPriority = setpwrap {#call unsafe gnutls_protocol_set_priority #}++instance SetPriority CertificateType where + setPriority = setpwrap {#call unsafe gnutls_certificate_type_set_priority #}++-- | Set default priorities. This is called whenever a new 'Session' is created to +-- ensure sensible defaults. +{#fun gnutls_set_default_priority as setDefaultPriority {withSession* `Session t'} -> `()' #}+-- | Set default priorities conforming with various export regulations.+-- /Includes weak algorithms./+{#fun gnutls_set_default_export_priority as setDefaultExportPriority {withSession* `Session t'} -> `()' #}+++--------------------------------------------------------------------------------+------------------------ Setting Credentials -------------------------------+--------------------------------------------------------------------------------++-- | Set the credentials associated with a session.+class SetCredentials st a where setCredentials :: Session st -> a -> IO ()+instance SetCredentials st a => SetCredentials st (IO a) where + setCredentials s c = setCredentials s =<< c+instance SetCredentials Server AnonymousServerCredentials where + setCredentials s (ASC a rc) = setcred_ s CrdAnon (castForeignPtr a)+instance SetCredentials Client AnonymousClientCredentials where + setCredentials s (ACC a rc) = setcred_ s CrdAnon (castForeignPtr a)+instance SetCredentials t CertificateCredentials where + setCredentials s (CC a rc) = setcred_ s CrdCertificate (castForeignPtr a)++setcred_ :: Session t -> CredentialsType -> ForeignPtr a -> IO ()+setcred_ (Session sfp refc) ct fp = do+ withForeignPtr sfp $ \sptr -> do+ withForeignPtr fp $ \dptr -> do+ {#call gnutls_credentials_set #} sptr (enumCInt ct) (castPtr dptr) >>= throwGnutlsIf+ addRefFinalizer refc (touchForeignPtr fp)++-- | Used to clear all credentials associated with a session.+data Clear = Clear+instance SetCredentials t Clear where+ setCredentials s _ = withSession s (\s -> {#call gnutls_credentials_clear #} s >> return ())++--------------------------------------------------------------------------------+--------------------------- Session Creation -------------------------------+--------------------------------------------------------------------------------++tlsClient :: [AttrOp (Session Client)] -> IO (Session Client)+tlsClient p = do s <- newSession Client+ set s p+ return s++tlsServer :: [AttrOp (Session Server)] -> IO (Session Server)+tlsServer p = do s <- newSession Server+ set s p+ return s+++newSession :: ConnectionEnd -> IO (Session t)+newSession ce = gnutlsGlobalInit >> alloca (\err -> do+ let efun b l e = putStrLn "TLS pull/push functions not set" >> return 0+ ef1 <- newStablePtr efun+ ef2 <- newStablePtr efun+ sp <- init_session_wrap (enumCInt ce) ef1 ef2 err+ peek err >>= throwGnutlsIf+ rc <- newRefCount (replace_transport_stable_ptrs sp stableNull stableNull >> gnutls_deinit sp)+ ps <- FC.newForeignPtr sp (freeRef rc)+ return $ Session ps rc)++stableNull = castPtrToStablePtr nullPtr++foreign import ccall unsafe "TLS.h gnutls_init" gnutls_init :: Ptr (Ptr ()) -> CInt -> IO CInt+foreign import ccall unsafe "TLS.h gnutls_deinit" gnutls_deinit :: Ptr () -> IO ()++foreign import ccall unsafe "TLS.h init_session_wrap"+ init_session_wrap :: CInt -> StablePtr Transport -> StablePtr Transport -> Ptr CInt -> IO (Ptr ())+#c+#ifdef COMPAT_GNUTLS_1_0+typedef gnutls_transport_ptr gnutls_transport_ptr_t;+typedef gnutls_connection_end gnutls_connection_end_t;+typedef gnutls_session gnutls_session_t;+typedef gnutls_dh_params gnutls_dh_params_t;+typedef gnutls_rsa_params gnutls_rsa_params_t;+typedef gnutls_anon_server_credentials gnutls_anon_server_credentials_t;+typedef gnutls_anon_client_credentials gnutls_anon_client_credentials_t;+typedef gnutls_certificate_credentials gnutls_certificate_credentials_t;+#endif+gnutls_session_t init_session_wrap(gnutls_connection_end_t con_end, void *sptr1, void *sptr2, int *err);+#endc++--------------------------------------------------------------------------------+------------------------- Session Accessors --------------------------------+--------------------------------------------------------------------------------++priorities :: SetPriority a => WriteAttr (Session t) [a]+priorities = writeAttr setPriority++credentials :: SetCredentials t a => WriteAttr (Session t) a+credentials = writeAttr setCredentials++dhPrimeBits :: ReadWriteAttr (Session t) Int Int+dhPrimeBits = newAttr get set+ where get s = withSession s {#call gnutls_dh_get_prime_bits #} >>= return . fromIntegral+ set s v = withSession s (\sp -> {#call gnutls_dh_set_prime_bits #} sp (fromIntegral v))+++transport :: ReadWriteAttr (Session t) (Transport,Transport) (Transport,Transport)+transport = newAttr gnutls_transport_get_ptr2 set+ where set s (a,b) = do a' <- newStablePtr a+ b' <- newStablePtr b+ withSession s $ \sp -> replace_transport_stable_ptrs sp a' b'++{#fun unsafe gnutls_transport_get_ptr2 + {withSession* `Session t',+ alloca- `Transport' ptrDeS*,+ alloca- `Transport' ptrDeS*}+ -> `()' #}++foreign import ccall "replace_transport_stable_ptrs"+ replace_transport_stable_ptrs :: Ptr () -> StablePtr Transport -> StablePtr Transport -> IO ()++#c+void replace_transport_stable_ptrs(gnutls_session_t session, void *p1, void *p2);+#endc++#ifdef NETWORK_ALT++sock :: WriteAttr (Session t) Socket+sock = writeAttr ss+ where rf sfd buf len err = recv sfd buf len `catch` ef err+ sf sfd buf len err = send sfd buf len `catch` ef err+ ef err _ = do (Errno iv) <- getErrno; poke err iv; return (-1)+ ss (Session sfp sr) sfd = do rf' <- newStablePtr $ rf sfd+ sf' <- newStablePtr $ sf sfd+ withForeignPtr sfp $ \p -> replace_transport_stable_ptrs p rf' sf'+ addRefFinalizer sr (close sfd)+#endif /* NETWORK_ALT */++handle :: WriteAttr (Session t) Handle+handle = writeAttr ss+ where rf hdl buf len err = (hGetBuf hdl buf (fromIntegral len)) `catch` ef err+ sf hdl buf len err = (hPutBuf hdl buf (fromIntegral len) >> return len) `catch` ef err+ ef err _ = do (Errno iv) <- getErrno; poke err iv; return (-1)+ ss (Session sfp sr) hdl = do rf' <- newStablePtr $ rf hdl+ sf' <- newStablePtr $ sf hdl+ hSetBuffering hdl NoBuffering+ withForeignPtr sfp $ \p -> replace_transport_stable_ptrs p rf' sf'+ addRefFinalizer sr (hClose hdl)+++--------------------------------------------------------------------------------+----------------------------- Session Actions -------------------------------+--------------------------------------------------------------------------------++-- | Terminates the current TLS connection, which has been succesfully established+-- with 'handshake'. Notifies the peer with an alert that the connection is closing.+{#fun gnutls_bye as bye {withSession* `Session t',enumCInt `CloseRequest'} -> `()' throwGnutlsIf* #}+-- | Perform a handshake with the peer and initialize a TLS\/SSL connection.+-- Note that after the handshake completes applications /must/ check +-- whether a high enough level of confidentiality was established.+{#fun gnutls_handshake as handshake {withSession* `Session t'} -> `' throwGnutlsIf* #}+-- | Tells the client that we want to renogotiate the handshake. If the function+-- succeeds then 'handshake' can be called again on the connection.+{#fun gnutls_rehandshake as rehandshake {withSession* `Session Server'} -> `' throwGnutlsIf* #}++-- | Set the maximum size of a handshake request. Larger requests are ignored.+-- Defaults to 16kb which should be large enough.+{#fun gnutls_handshake_set_max_packet_length as setMaxHandshakePacketLength + {withSession* `Session t', fromIntegral `Int'} -> `()' #}++-- | Set whether we want to do client authentication.+clientCert :: WriteAttr (Session Server) CertificateRequest+clientCert = writeAttr p+ where p s v = withSession s $ \sp -> {#call unsafe gnutls_certificate_server_set_request #} sp (enumCInt v)++--------------------------------------------------------------------------------+---------------------------- Session Getters --------------------------------+--------------------------------------------------------------------------------+ +serverWantedAuth :: Session Client -> IO Bool+serverWantedAuth s = withSession s $ \sp -> do+ iv <- {#call gnutls_certificate_client_get_request_status #} sp+ throwGnutlsIfNeg iv+ return (iv /= 0)++verifyPeer :: Session t -> IO [CertificateStatus]+verifyPeer ses = do + withSession ses $ \sp -> do+ alloca $ \stat -> do+ {#call gnutls_certificate_verify_peers2 #} sp stat >>= throwGnutlsIf+ ci <- peekEnum stat+ return $ filter (\e -> fromEnum e .&. ci /= 0) [CertInvalid, CertRevoked, CertSignerNotFound, CertSignerNotCa]++-- | Test whether this session is a resumed one.+{#fun gnutls_session_is_resumed as isResumed {withSession* `Session t'} -> `Bool' isNotZero #}++isNotZero :: CInt -> Bool+isNotZero 0 = False+isNotZero _ = True++-- | Return the value of the last alert received - undefined if no alert has been received.+{#fun unsafe gnutls_alert_get as getAlert {withSession* `Session t'} -> `AlertDescription' cintEnum #}+-- | Return the currently used cipher.+{#fun unsafe gnutls_cipher_get as getCipher {withSession* `Session t'} -> `CipherAlgorithm' cintEnum #}+-- | Return the key exchange algorithm used in the last handshake.+{#fun unsafe gnutls_kx_get as getKx {withSession* `Session t'} -> `KxAlgorithm' cintEnum #}+-- | Return the mac algorithm currently used.+{#fun unsafe gnutls_mac_get as getMac {withSession* `Session t'} -> `MacAlgorithm' cintEnum #}+-- | Return the compression method currently used.+{#fun unsafe gnutls_compression_get as getCompression {withSession* `Session t'} -> `CompressionMethod' cintEnum #}+-- | Return the currently used certificate type.+{#fun unsafe gnutls_certificate_type_get as getCertificateType {withSession* `Session t'} -> `CertificateType' cintEnum #}+-- | Return the currently used protocol version.+{#fun unsafe gnutls_protocol_get_version as getProtocol {withSession* `Session t'} -> `Protocol' cintEnum #}++-- | Return type of credentials for the current authentication schema.+{#fun gnutls_auth_get_type as getCredentialsType {withSession* `Session t'} -> `CredentialsType' cintEnum #}++#ifndef COMPAT_GNUTLS_1_0+-- | Return the type of credentials used for authenticating the server. Available with GnuTLS 1.2.+{#fun gnutls_auth_server_get_type as getServerCredentialsType {withSession* `Session t'} -> `CredentialsType' cintEnum #}+-- | Return the type of credentials used for authenticating the client. Available with GnuTLS 1.2.+{#fun gnutls_auth_client_get_type as getClientCredentialsType {withSession* `Session t'} -> `CredentialsType' cintEnum #}+#endif++-- | Get the certificate chain of the peer. +-- In the case of X509 will return DER encoded certificate list+-- beginning with the peers key and continuing in the issuer chain.+-- With OpenPGP a single key will be returned in the raw format.+getPeersCertificatesRaw :: Session t -> IO [(Ptr CChar,Int)]+getPeersCertificatesRaw ses = do+ withSession ses $ \sp ->+ alloca $ \lenp -> do+ res <- {#call gnutls_certificate_get_peers #} sp lenp+ if res == nullPtr + then return []+ else do len <- peek lenp+ peekDatumArray (fromIntegral len - 1) res++--------------------------------------------------------------------------------+---------------------------- Read/Write Data --------------------------------+--------------------------------------------------------------------------------++{#fun gnutls_record_send as tlsSend + {withSession* `Session t', castPtr `Ptr a', fromIntegral `Int' } -> `Int' throwGnutlsIfNeg* #}++tlsSendString :: Session t -> String -> IO ()+tlsSendString ses str = withCStringLen str $ \(ptr,len) -> loop ptr len+ where loop ptr len = do r <- tlsSend ses ptr len+ case len-r of+ x | x > 0 -> loop (plusPtr ptr r) x+ | True -> return ()+ +{#fun gnutls_record_check_pending as tlsCheckPending+ {withSession* `Session t'} -> `Int' fromIntegral #}++{#fun gnutls_record_recv as tlsRecv+ {withSession* `Session t', castPtr `Ptr a', fromIntegral `Int'} -> `Int' throwGnutlsIfNeg* #}++tlsRecvString :: Session t -> IO String+tlsRecvString ses = allocaBytes 1024 $ \ptr -> do+ r <- tlsRecv ses ptr 1024+ peekCAStringLen (ptr,r)++--------------------------------------------------------------------------------+--------------------- Anonymous Server Credentials -------------------------+--------------------------------------------------------------------------------++anonymousServerCredentials :: IO AnonymousServerCredentials+anonymousServerCredentials = alloca $ \ptr -> do+ gnutls_anon_allocate_server_credentials ptr >>= throwGnutlsIf+ raw<- peek ptr+ rc <- newRefCount $ gnutls_anon_free_server_credentials raw+ fp <- FC.newForeignPtr raw $ freeRef rc+ return $ ASC fp rc++foreign import ccall safe "TLS.h gnutls_anon_free_server_credentials"+ gnutls_anon_free_server_credentials :: Ptr () -> IO ()++foreign import ccall safe "TLS.h gnutls_anon_allocate_server_credentials" + gnutls_anon_allocate_server_credentials :: Ptr (Ptr ()) -> IO CInt++class SetDHParams a where setDHParams :: a -> DH -> IO ()+instance SetDHParams AnonymousServerCredentials where + setDHParams asc@(ASC _ rc) dh@(DH _ refc) =+ do gnutls_anon_set_server_dh_params asc dh+ allocRef refc+ addRefFinalizer rc $ freeRef refc++{#fun gnutls_anon_set_server_dh_params + {withAnonymousServerCredentials* `AnonymousServerCredentials', withDH* `DH'} -> `()' #}++--------------------------------------------------------------------------------+--------------------- Anonymous Client Credentials -------------------------+--------------------------------------------------------------------------------++anonymousClientCredentials :: IO AnonymousClientCredentials+anonymousClientCredentials = alloca $ \ptr -> do+ gnutls_anon_allocate_client_credentials ptr >>= throwGnutlsIf+ raw<- peek ptr+ rc <- newRefCount $ gnutls_anon_free_client_credentials raw+ fp <- FC.newForeignPtr raw $ freeRef rc+ return $ ACC fp rc++foreign import ccall safe "TLS.h gnutls_anon_free_client_credentials"+ gnutls_anon_free_client_credentials :: Ptr () -> IO ()++foreign import ccall safe "TLS.h gnutls_anon_allocate_client_credentials" + gnutls_anon_allocate_client_credentials :: Ptr (Ptr ()) -> IO CInt++--------------------------------------------------------------------------------+----------------------- Certificate Credentials ----------------------------+--------------------------------------------------------------------------------++certificateCredentials :: IO CertificateCredentials+certificateCredentials = alloca $ \ptr -> do+ gnutls_certificate_allocate_credentials ptr >>= throwGnutlsIf+ raw<- peek ptr+ rc <- newRefCount $ gnutls_certificate_free_credentials raw+ fp <- FC.newForeignPtr raw $ freeRef rc+ return $ CC fp rc++foreign import ccall safe "TLS.h gnutls_certificate_free_credentials" + gnutls_certificate_free_credentials :: Ptr () -> IO ()++foreign import ccall safe "TLS.h gnutls_certificate_allocate_credentials" + gnutls_certificate_allocate_credentials :: Ptr (Ptr ()) -> IO CInt++{#fun gnutls_certificate_free_keys as freeKeys {withCertificateCredentials* `CertificateCredentials'} -> `()' #}+{#fun gnutls_certificate_free_cas as freeCas {withCertificateCredentials* `CertificateCredentials'} -> `()' #}+{#fun gnutls_certificate_free_ca_names as freeCaNames {withCertificateCredentials* `CertificateCredentials'} -> `()' #}+{#fun gnutls_certificate_free_crls as freeCrls {withCertificateCredentials* `CertificateCredentials'} -> `()' #}++instance SetDHParams CertificateCredentials where + setDHParams cc@(CC _ rc) dh@(DH _ refc) =+ do gnutls_certificate_set_dh_params cc dh+ allocRef refc+ addRefFinalizer rc $ freeRef refc++{#fun gnutls_certificate_set_dh_params + {withCertificateCredentials* `CertificateCredentials', withDH* `DH'} -> `()' #}++{#fun gnutls_certificate_set_x509_trust_file as certificateTrustFile+ {withCertificateCredentials* `CertificateCredentials', + withCAString* `FilePath',+ enumCInt `X509CertificateFormat'}+ -> `Int' throwGnutlsIfNeg* #}++{#fun gnutls_certificate_set_x509_crl_file as certificateCrlFile+ {withCertificateCredentials* `CertificateCredentials', + withCAString* `FilePath',+ enumCInt `X509CertificateFormat'}+ -> `Int' throwGnutlsIfNeg* #}++{#fun gnutls_certificate_set_x509_key_file as certificateKeyFile+ {withCertificateCredentials* `CertificateCredentials', + withCAString* `FilePath',+ withCAString* `FilePath',+ enumCInt `X509CertificateFormat'}+ -> `Int' throwGnutlsIfNeg* #}++{-+void gnutls_certificate_set_rsa_export_params (gnutls_certificate_credentials_t res, gnutls_rsa_params_t rsa_params);+void gnutls_certificate_set_verify_flags (gnutls_certificate_credentials_t res, unsigned int flags);+void gnutls_certificate_set_verify_limits (gnutls_certificate_credentials_t res, unsigned int max_bits, unsigned int max_depth);++int gnutls_certificate_set_x509_trust_mem (gnutls_certificate_credentials_t res, const gnutls_datum_t *CA, gnutls_x509_crt_fmt_t type);+int gnutls_certificate_set_x509_trust (gnutls_certificate_credentials_t res, gnutls_x509_crt_t *ca_list, int ca_list_size);++int gnutls_certificate_set_x509_crl_mem (gnutls_certificate_credentials_t res, const gnutls_datum_t *CRL, gnutls_x509_crt_fmt_t type);+int gnutls_certificate_set_x509_crl (gnutls_certificate_credentials_t res, gnutls_x509_crl_t *crl_list, int crl_list_size);++int gnutls_certificate_set_x509_key_mem (gnutls_certificate_credentials_t res, const gnutls_datum_t *CERT, const gnutls_datum_t *KEY, gnutls_x509_crt_fmt_t type);+int gnutls_certificate_set_x509_key (gnutls_certificate_credentials_t res, gnutls_x509_crt_t *cert_list, int cert_list_size, gnutls_x509_privkey_t key);+-}++--------------------------------------------------------------------------------+------------------------- DH and RSA Parameters ----------------------------+--------------------------------------------------------------------------------++class CredParameter a where + -- | Generate a new key with the given number of bits.+ generate :: a -> Int -> IO ()++newDH :: IO DH+newDH = alloca $ \ptr -> do+ gnutls_dh_params_init ptr >>= throwGnutlsIf+ raw<- peek ptr+ rc <- newRefCount (gnutls_dh_params_deinit raw)+ fp <- FC.newForeignPtr raw (freeRef rc)+ return $ DH fp rc++foreign import ccall safe "TLS.h gnutls_dh_params_deinit" gnutls_dh_params_deinit :: Ptr () -> IO ()+foreign import ccall safe "TLS.h gnutls_dh_params_init" gnutls_dh_params_init :: Ptr (Ptr ()) -> IO CInt++instance CredParameter DH where+ generate a i = withDH a (\ap -> {#call gnutls_dh_params_generate2 #} ap (fromIntegral i) >>= throwGnutlsIf)++newRSA :: IO RSA+newRSA = alloca $ \ptr -> do+ gnutls_rsa_params_init ptr >>= throwGnutlsIf+ raw<- peek ptr+ rc <- newRefCount (gnutls_rsa_params_deinit raw)+ fp <- FC.newForeignPtr raw (freeRef rc)+ return $ RSA fp rc++foreign import ccall safe "TLS.h gnutls_rsa_params_deinit" gnutls_rsa_params_deinit :: Ptr () -> IO ()+foreign import ccall safe "TLS.h gnutls_rsa_params_init" gnutls_rsa_params_init :: Ptr (Ptr ()) -> IO CInt++instance CredParameter RSA where+ generate a i = withRSA a (\ap -> {#call gnutls_rsa_params_generate2 #} ap (fromIntegral i) >>= throwGnutlsIf)+++--------------------------------------------------------------------------------+--------------------------- Miscellaneous ----------------------------------+--------------------------------------------------------------------------------++-- | Return the cipher's key size in bytes.+{#fun pure unsafe gnutls_cipher_get_key_size as cipherKeySize + {enumCInt `CipherAlgorithm'} -> `Int' fromIntegral #}++-- | Return the name of the ciphersuite.+{#fun pure unsafe gnutls_cipher_suite_get_name as cipherSuiteName + {enumCInt `KxAlgorithm',+ enumCInt `CipherAlgorithm',+ enumCInt `MacAlgorithm'} + -> `String' safePeekCString* #}++-- | The version of /Gnutls/ used.+version = unsafePerformIO $ {#call gnutls_check_version #} nullPtr >>= safePeekCString++{-# NOINLINE gnutlsGlobalInitIORef #-}+gnutlsGlobalInitIORef = unsafePerformIO $ do+ gcry_init_helper+ {#call unsafe gnutls_global_init #} >>= throwGnutlsIf+ newIORef ()++gnutlsGlobalInit = readIORef gnutlsGlobalInitIORef++foreign import ccall unsafe "gcry_init_helper" gcry_init_helper :: IO ()+
+ Network/GnuTLS/GnuTLSMonad.chs view
@@ -0,0 +1,48 @@++module Network.GnuTLS.GnuTLSMonad(+ GnuTLSError(..),+ GnuTLSMonad,+ checkError,+ getDescription,+ withGnuTLS,+ gnuTLSCheckBool+ ) where++import System.IO.Unsafe(unsafePerformIO)+import Control.Exception(finally)+import Control.Monad.Error+import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr++#include <gnutls/gnutls.h>++{#context prefix="gnutls"#}++withGnuTLS :: IO a -> IO a+withGnuTLS act = do+ res <- {#call unsafe gnutls_global_init#}+ unless (res==0) (fail "couldn't initialize gnutls")+ act `finally` {#call unsafe gnutls_global_deinit#}++data GnuTLSError = GnuTLSError CInt deriving (Eq)++instance Error GnuTLSError where+ noMsg = GnuTLSError 0++getDescription :: GnuTLSError -> String+getDescription (GnuTLSError err) = unsafePerformIO $ {#call gnutls_strerror#} err >>= peekCString++instance Show GnuTLSError where+ show err = getDescription err++type GnuTLSMonad a = Either GnuTLSError a++checkError :: CInt -> GnuTLSMonad ()+checkError 0 = Right ()+checkError i = Left (GnuTLSError i)++gnuTLSCheckBool :: CInt -> GnuTLSMonad Bool+gnuTLSCheckBool 0 = return False+gnuTLSCheckBool 1 = return True+gnuTLSCheckBool i = Left (GnuTLSError i)
+ Network/GnuTLS/IOWrap.hs view
@@ -0,0 +1,17 @@+module Network.GnuTLS.IOWrap() where++import Foreign+import Network.GnuTLS.GnuTLS++--------------------------------------------------------------------------------+-------------------------- Pull/Push Wrapper -------------------------------+--------------------------------------------------------------------------------++foreign export ccall gnutls_io_wrap_h :: + StablePtr Transport -> Transport++gnutls_io_wrap_h :: StablePtr Transport -> Transport+gnutls_io_wrap_h sptr p l e = do+ c <- deRefStablePtr sptr+ c p l e+
+ Network/GnuTLS/Internals.chs view
@@ -0,0 +1,157 @@+module Network.GnuTLS.Internals where++#include <gnutls/gnutls.h>++{#context prefix = "gnutls" #}++import Foreign+import Foreign.C+import System.Time(ClockTime(TOD))+import Network.GnuTLS.RefCount+import Data.ByteString.Internal+import Data.ByteString.Unsafe++data Session a = Session (ForeignPtr ())! RefCount++--------------------------------------------------------------------------------+------------------------------ Enums ---------------------------------------+--------------------------------------------------------------------------------++{#enum gnutls_cipher_algorithm_t as CipherAlgorithm {underscoreToCase} #}+{#enum gnutls_kx_algorithm_t as KxAlgorithm {underscoreToCase} deriving(Eq) #}+{#enum gnutls_params_type_t as ParamsType {underscoreToCase} #}+{#enum gnutls_credentials_type_t as CredentialsType {underscoreToCase} deriving(Eq) #}+{#enum gnutls_mac_algorithm_t as MacAlgorithm {underscoreToCase} #}+{#enum gnutls_digest_algorithm_t as DigestAlgorithm {underscoreToCase} deriving(Show) #}+{#enum gnutls_compression_method_t as CompressionMethod {underscoreToCase} #}+{#enum gnutls_connection_end_t as ConnectionEnd {underscoreToCase} #}+{#enum gnutls_alert_level_t as AlertLevel {underscoreToCase} #}+{#enum gnutls_alert_description_t as AlertDescription {underscoreToCase} #}+{#enum gnutls_handshake_description_t as HandshakeDescription {underscoreToCase} #}+{#enum gnutls_certificate_status_t as CertificateStatus {underscoreToCase} deriving(Show,Eq) #}+{#enum gnutls_certificate_request_t as CertificateRequest {underscoreToCase} #}+--{#enum gnutls_openpgp_key_status_t as KeyStatus {underscoreToCase} #}+{#enum gnutls_close_request_t as CloseRequest {underscoreToCase} #}+{#enum gnutls_protocol_t as Protocol {underscoreToCase} #}+{#enum gnutls_certificate_type_t as CertificateType {underscoreToCase} #}+{#enum gnutls_x509_crt_fmt_t as X509CertificateFormat {underscoreToCase} #}+{#enum gnutls_pk_algorithm_t as PkAlgorithm {underscoreToCase} #}+{#enum gnutls_sign_algorithm_t as SignAlgorithm {underscoreToCase} #}++#c+#ifdef COMPAT_GNUTLS_1_0+typedef gnutls_cipher_algorithm gnutls_cipher_algorithm_t;+typedef gnutls_kx_algorithm gnutls_kx_algorithm_t;+typedef gnutls_mac_algorithm gnutls_mac_algorithm_t;+typedef gnutls_digest_algorithm gnutls_digest_algorithm_t;+typedef gnutls_datum gnutls_datum_t;+typedef gnutls_params_type gnutls_params_type_t;+typedef gnutls_credentials_type gnutls_credentials_type_t;+typedef gnutls_compression_method gnutls_compression_method_t;+typedef gnutls_connection_end gnutls_connection_end_t;+typedef gnutls_alert_level gnutls_alert_level_t;+typedef gnutls_alert_description gnutls_alert_description_t;+typedef gnutls_handshake_description gnutls_handshake_description_t;+typedef gnutls_certificate_status gnutls_certificate_status_t;+typedef gnutls_certificate_request gnutls_certificate_request_t;+typedef gnutls_openpgp_key_status gnutls_openpgp_key_status_t;+typedef gnutls_close_request gnutls_close_request_t;+typedef gnutls_protocol_version gnutls_protocol_t;+typedef gnutls_certificate_type gnutls_certificate_type_t;+typedef gnutls_x509_crt_fmt gnutls_x509_crt_fmt_t;+typedef gnutls_pk_algorithm gnutls_pk_algorithm_t;+typedef gnutls_sign_algorithm gnutls_sign_algorithm_t;+#endif+#endc+++--------------------------------------------------------------------------------+---------------------------- Time Management -------------------------------+--------------------------------------------------------------------------------++integralToClockTime :: Integral n => n -> ClockTime+integralToClockTime ct = TOD (fromIntegral ct) 0++--------------------------------------------------------------------------------+----------------------------- Helpers --------------------------------------+--------------------------------------------------------------------------------++enumCInt :: Enum e => e -> CInt+enumCInt x = fromIntegral $ fromEnum x+cintEnum :: Enum e => CInt -> e+cintEnum x = toEnum $ fromIntegral x++safePeekCString :: CString -> IO String+safePeekCString pointer = if pointer == nullPtr then return "" else peekCString pointer++withEnumList0 :: Enum e => [e] -> (Ptr CInt -> IO ()) -> IO ()+withEnumList0 es f = withArray0 0 is f+ where is = map enumCInt es++withSession :: Session t -> (Ptr () -> IO a) -> IO a+withSession (Session s _) = withForeignPtr s++{-# SPECIALIZE throwGnutlsIf :: CInt -> IO () #-}+{-# SPECIALIZE throwGnutlsIf :: CLong -> IO () #-}++throwGnutlsIf :: Integral n => n -> IO ()+throwGnutlsIf 0 = return ()+throwGnutlsIf v = {#call gnutls_strerror #} (fromIntegral v) >>= safePeekCString >>= (\str -> fail (str++" ("++show v++")"))++{-# SPECIALIZE throwGnutlsIfNeg :: CInt -> IO Int #-}+{-# SPECIALIZE throwGnutlsIfNeg :: CLong -> IO Int #-}+throwGnutlsIfNeg :: (Num b, Integral a) => a -> IO b+throwGnutlsIfNeg v = if v < 0 then throwGnutlsIf v >> return 0 else return (fromIntegral v)++{-# INLINE peekEnum #-}+peekEnum :: (Storable s, Integral s, Num e, Enum e) => Ptr s -> IO e+peekEnum pointer = peek pointer >>= return . fromIntegral++isZero, isNonZero :: (Num a) => a -> Bool+isZero x = x == 0+isNonZero x = x /= 0++ptrDeS :: Ptr (Ptr ()) -> IO a+ptrDeS p = deRefStablePtr $ castPtrToStablePtr $ castPtr p++--------------------------------------------------------------------------------+------------------------------ Datums --------------------------------------+--------------------------------------------------------------------------------++peekDatum :: Ptr a -> IO (Ptr CChar,Int)+peekDatum pntr = do pv <- {#get gnutls_datum_t->data #} (castPtr pntr)+ iv <- {#get gnutls_datum_t->size #} (castPtr pntr)+ return (castPtr pv, fromIntegral iv)++peekDatumArray :: Int -> Ptr a -> IO [(Ptr CChar,Int)]+peekDatumArray i pntr = loop i (plusPtr pntr (i*{#sizeof gnutls_datum_t #})) []+ where loop 0 pointer acc = do d <- peekDatum pointer+ return (d:acc)+ loop k pointer acc = do d <- peekDatum pointer+ loop (k-1) (plusPtr pointer (0-{#sizeof gnutls_datum_t #})) (d:acc)++class Datum a where+ withDatum :: a -> (Ptr () -> IO b) -> IO b++instance Datum String where+ withDatum s p = withCStringLen s (\v -> withDatum v p)++instance Datum (Ptr CChar,Int) where+ withDatum (p,l) c = allocaBytes {#sizeof gnutls_datum_t #} $ \dptr -> do+ {#set gnutls_datum_t->data #} dptr (castPtr p)+ {#set gnutls_datum_t->size #} dptr (fromIntegral l)+ c dptr++instance Datum ByteString where+ withDatum bs f = unsafeUseAsCStringLen bs (\v -> withDatum v f)++--{#fun gnutls_pem_base64_decode_alloc as datumBase64Decode+-- {with+datumBase64Decode :: (Datum d) => Int -> d -> IO ByteString+datumBase64Decode sz dat = withDatum dat $+ \p1 -> createAndTrim sz $+ \pointer -> with (fromIntegral sz::CSize) $+ \sptr -> do+ {#call gnutls_pem_base64_decode#} nullPtr p1 (castPtr pointer) (castPtr sptr) >>= throwGnutlsIf+ peek sptr >>= return . fromIntegral+
+ Network/GnuTLS/OID.hsc view
@@ -0,0 +1,48 @@+module Network.GnuTLS.OID where++#include <gnutls/x509.h>++type OID = String++oidX520CountryName :: OID+oidX520CountryName = #{const_str GNUTLS_OID_X520_COUNTRY_NAME}++oidX520OrganizationName :: OID+oidX520OrganizationName = #{const_str GNUTLS_OID_X520_ORGANIZATION_NAME}++oidX520OrganizationalUnitName :: OID+oidX520OrganizationalUnitName = #{const_str GNUTLS_OID_X520_ORGANIZATIONAL_UNIT_NAME}++oidX520CommonName :: OID+oidX520CommonName = #{const_str GNUTLS_OID_X520_COMMON_NAME}++oidX520LocalityName :: OID+oidX520LocalityName = #{const_str GNUTLS_OID_X520_LOCALITY_NAME}++oidX520StateOrProvinceName :: OID+oidX520StateOrProvinceName = #{const_str GNUTLS_OID_X520_STATE_OR_PROVINCE_NAME }++oidX520Initials :: OID+oidX520Initials = #{const_str GNUTLS_OID_X520_INITIALS}++oidX520GenerationQualifier :: OID+oidX520GenerationQualifier = #{const_str GNUTLS_OID_X520_GENERATION_QUALIFIER}++oidX520Surname :: OID+oidX520Surname = #{const_str GNUTLS_OID_X520_SURNAME}++oidX520GivenName :: OID+oidX520GivenName = #{const_str GNUTLS_OID_X520_GIVEN_NAME}++oidX520Title :: OID+oidX520Title = #{const_str GNUTLS_OID_X520_TITLE}++-- ...++oidPKCS9Email :: OID+oidPKCS9Email = #{const_str GNUTLS_OID_PKCS9_EMAIL}++-- ...++oidX509v3SubjectKeyIdentifier :: OID+oidX509v3SubjectKeyIdentifier = "2.5.29.14"
+ Network/GnuTLS/RefCount.hs view
@@ -0,0 +1,31 @@+module Network.GnuTLS.RefCount + (RefCount, newRefCount, allocRef, freeRef, addRefFinalizer)+ where++import Data.IORef++-- | A simple reference count with a list of finalizers.+newtype RefCount = RC (IORef (Int, [IO ()]))++-- | Create a new reference count with one reference and +-- the suplied action as the initial finalizer.+newRefCount :: IO () -> IO RefCount+newRefCount act = return . RC =<< newIORef (1, [act])++-- | Allocate an additional reference to the RefCount.+allocRef :: RefCount -> IO ()+allocRef (RC ref) = atomicModifyIORef ref $ \(iv,cs) -> ((iv+1,cs),())++-- | Free a reference to the RefCount. If the number +-- of references goes down to zero all the associated+-- finalizers are fired. The RefCount is left in +-- unusable state when all the references have been +-- deleted.+freeRef :: RefCount -> IO ()+freeRef (RC ref) = atomicModifyIORef ref handler >>= sequence_+ where handler (1,cs) = (error "Double free of RefCount",cs)+ handler (k,cs) = ((k-1,cs), [])++-- | Associate an additional finalizer with the RefCount.+addRefFinalizer :: RefCount -> IO () -> IO ()+addRefFinalizer (RC ref) c = atomicModifyIORef ref $ \(iv,cs) -> ((iv,c:cs),())
+ Network/GnuTLS/X509.chs view
@@ -0,0 +1,342 @@++module Network.GnuTLS.X509 (+ -- * Types+ Certificate(),+ PrivateKey(),+ -- * Certificate Functions+ --newCertificate,+ --newPrivateKey,+ importCertificate,+ importPrivateKey,+ exportCertificate,+ exportPrivateKey,+ verifySignature,+ signData,+ certificateRSAParameters,+ privateKeyRSAParameters,+ privateKeyGetKeyId,+ certificateGetKeyId,+ getIssuerDnByOid,+ getDnByOid,+ getExtensionByOid,+-- getPeersX509DN,+ checkHostname,+ checkIssuer,+-- activationTime,+-- expirationTime,+-- getPeersCertificatesX509+ )+ where++import Foreign+import Foreign.C+import Network.GnuTLS.Attributes+import Network.GnuTLS.GnuTLS+import Network.GnuTLS.Internals+import Network.GnuTLS.GnuTLSMonad+import Network.GnuTLS.Errors+import Network.GnuTLS.OID+import System.Time(ClockTime(TOD))+import Data.ByteString.Internal+import System.Time++#include <gnutls/x509.h>++{#context prefix = "gnutls_x509" #}++{#pointer gnutls_x509_crt_t as Certificate foreign newtype #}+{#pointer gnutls_x509_privkey_t as PrivateKey foreign newtype #}+{#pointer gnutls_x509_crl_t as CertificateRevocationList foreign newtype #}++instance Show PrivateKey where+ show _ = "<PrivateKey>"++instance Show Certificate where+ show _ = "<Certificate>"++#c+#ifdef COMPAT_GNUTLS_1_0+typedef gnutls_x509_crt gnutls_x509_crt_t;+typedef gnutls_x509_crl gnutls_x509_crl_t;+#endif+#endc++-- Certificate Initializaion++foreign import ccall unsafe "TLS.h &gnutls_x509_crt_deinit" gnutls_x509_crt_deinit :: FunPtr (Ptr Certificate -> IO ())+foreign import ccall unsafe "TLS.h gnutls_x509_crt_init" gnutls_x509_crt_init :: Ptr (Ptr Certificate) -> IO CInt++foreign import ccall unsafe "TLS.h &gnutls_x509_privkey_deinit" gnutls_x509_privkey_deinit :: FunPtr (Ptr PrivateKey -> IO ())+foreign import ccall unsafe "TLS.h gnutls_x509_privkey_init" gnutls_x509_privkey_init :: Ptr (Ptr PrivateKey) -> IO CInt++-- | Import an encoded certificate to the native format.+importCertificate :: Datum d => d -> X509CertificateFormat -> GnuTLSMonad Certificate+importCertificate dat form = unsafePerformIO $ withDatum dat $+ \rdat -> alloca $ \ptr -> do+ res <- gnutls_x509_crt_init ptr+ if res/=0 then return (Left $ GnuTLSError res)+ else do+ fp <- newForeignPtr gnutls_x509_crt_deinit =<< peek ptr+ res2 <- withForeignPtr fp (\cr -> {#call unsafe gnutls_x509_crt_import#} cr rdat (enumCInt form))+ if res2/=0 then return (Left $ GnuTLSError res2)+ else return (Right $ Certificate fp)++importPrivateKey :: Datum d => d -> X509CertificateFormat -> GnuTLSMonad PrivateKey+importPrivateKey dat form = unsafePerformIO $ withDatum dat $+ \rdat -> alloca $ \ptr -> do+ res <- gnutls_x509_privkey_init ptr+ if res/=0 then return (Left $ GnuTLSError res)+ else do+ fp <- newForeignPtr gnutls_x509_privkey_deinit =<< peek ptr+ res2 <- withForeignPtr fp (\cr -> {#call unsafe gnutls_x509_privkey_import#} cr rdat (enumCInt form))+ if res2/=0 then return (Left $ GnuTLSError res2)+ else return (Right $ PrivateKey fp)++{-getPeersCertificatesX509 :: Session t -> IO [Certificate]+getPeersCertificatesX509 ses = mapM p =<< getPeersCertificatesRaw ses+ where p raw = do c <- newCertificate+ importCertificate c raw X509FmtDer+ return c-}++exportCertificate :: Certificate -> X509CertificateFormat -> GnuTLSMonad ByteString+exportCertificate cert form = unsafePerformIO $ exportCertificate'' cert form 1024++exportPrivateKey :: PrivateKey -> X509CertificateFormat -> GnuTLSMonad ByteString+exportPrivateKey key form = unsafePerformIO $ export'' (exportPrivateKey' key form) 1024++export'' :: (Ptr () -> Ptr CSize -> IO CInt) -> Int -> IO (GnuTLSMonad ByteString)+export'' f sz = do+ (str,res) <- createAndTrim' sz $ \ptr -> with (fromIntegral sz) $ \szptr -> do+ res <- f (castPtr ptr) szptr+ case () of+ () | res==0 -> do+ rsize <- peek szptr+ return (0,fromIntegral rsize,Nothing)+ | res==errorShortMemory -> return (0,0,Just Nothing)+ | otherwise -> return (0,0,Just $ Just res)+ case res of+ Nothing -> return $ Right str+ Just Nothing -> export'' f (sz+1024)+ Just (Just err) -> return $ Left (GnuTLSError err)++exportCertificate'' :: Certificate -> X509CertificateFormat -> Int -> IO (GnuTLSMonad ByteString)+exportCertificate'' cert format sz = export'' (exportCertificate' cert format) sz++-- | Helper function+exportCertificate' :: Certificate -> X509CertificateFormat -> Ptr () -> Ptr CSize -> IO CInt+exportCertificate' cert format ptr sptr = withCertificate cert $ \cp -> {#call unsafe gnutls_x509_crt_export#} cp (enumCInt format) ptr (castPtr sptr)+ +-- | Helper function+exportPrivateKey' :: PrivateKey -> X509CertificateFormat -> Ptr () -> Ptr CSize -> IO CInt+exportPrivateKey' key format ptr sptr = withPrivateKey key $ \cp -> {#call unsafe gnutls_x509_privkey_export#} cp (enumCInt format) ptr (castPtr sptr)++{#fun unsafe gnutls_x509_crt_get_expiration_time as getExpirationTime+ {withCertificate* `Certificate'} -> `ClockTime' toTime* #}++toTime :: Integral n => n -> IO ClockTime+toTime (-1) = fail "Error while getting time"+toTime x = return $ TOD (fromIntegral x) 0++verifySignature :: (Datum dat,Datum sign) => Certificate -> dat -> sign -> GnuTLSMonad Bool+verifySignature cert dat sig = unsafePerformIO $ withCertificate cert $+ \rcert -> withDatum dat $+ \rdat -> withDatum sig $+ \rsig -> do+ res <- {#call unsafe gnutls_x509_crt_verify_data#} rcert 0 rdat rsig+ case () of+ () | res == 0 -> return $ Right False+ | res == 1 -> return $ Right True+ | otherwise -> return $ Left $ GnuTLSError res++signData :: Datum d => PrivateKey -> DigestAlgorithm -> d -> GnuTLSMonad ByteString+signData key alg dat = unsafePerformIO $ signData'' key alg dat 1024++signData'' :: Datum d => PrivateKey -> DigestAlgorithm -> d -> Int -> IO (GnuTLSMonad ByteString)+signData'' key alg dat sz = do+ (str,res) <- createAndTrim' sz $ \ptr -> with (fromIntegral sz) $ \szptr -> do+ res <- signData' key alg dat (castPtr ptr) szptr+ case () of+ () | res==0 -> do+ rsize <- peek szptr+ return (0,fromIntegral rsize,Nothing)+ | res==errorShortMemory -> return (0,0,Just Nothing)+ | otherwise -> return (0,0,Just $ Just res)+ case res of+ Nothing -> return $ Right str+ Just Nothing -> signData'' key alg dat (sz+1024)+ Just (Just err) -> return $ Left (GnuTLSError err)++signData' :: Datum d => PrivateKey -> DigestAlgorithm -> d -> Ptr () -> Ptr CSize -> IO CInt+signData' priv alg dat strptr sptr = withPrivateKey priv $+ \rpriv -> withDatum dat $+ \rdat -> {#call unsafe gnutls_x509_privkey_sign_data#} rpriv (enumCInt alg) 0 rdat strptr (castPtr sptr)+++certificateRSAParameters :: Certificate -> GnuTLSMonad (ByteString,ByteString)+certificateRSAParameters cert = unsafePerformIO $ withCertificate cert $+ \rcert -> alloca $ \(ptrM::Ptr (Ptr ())) -> alloca $+ \(ptrE::Ptr (Ptr ())) -> do+ res <- {#call unsafe gnutls_x509_crt_get_pk_rsa_raw#} rcert (castPtr ptrM) (castPtr ptrE)+ if res/=0 then return $ Left (GnuTLSError res)+ else do+ (cptrM,sizeM) <- peekDatum ptrM+ (cptrE,sizeE) <- peekDatum ptrE+ fpM <- newForeignPtr c_free_finalizer (castPtr cptrM)+ fpE <- newForeignPtr c_free_finalizer (castPtr cptrE)+ return $ Right (fromForeignPtr fpM 0 sizeM,fromForeignPtr fpE 0 sizeE)++privateKeyRSAParameters :: PrivateKey -> GnuTLSMonad (ByteString,ByteString,ByteString,ByteString,ByteString,ByteString)+privateKeyRSAParameters key = unsafePerformIO $ withPrivateKey key $+ \rkey -> alloca $+ \(ptrM::Ptr (Ptr ())) -> alloca $+ \(ptrE::Ptr (Ptr ())) -> alloca $+ \(ptrD::Ptr (Ptr ())) -> alloca $+ \(ptrP::Ptr (Ptr ())) -> alloca $+ \(ptrQ::Ptr (Ptr ())) -> alloca $+ \(ptrU::Ptr (Ptr ())) -> do+ res <- {#call unsafe gnutls_x509_privkey_export_rsa_raw#} rkey+ (castPtr ptrM)+ (castPtr ptrE)+ (castPtr ptrD)+ (castPtr ptrP)+ (castPtr ptrQ)+ (castPtr ptrU)+ if res/= 0 then return $ Left (GnuTLSError res)+ else do+ (cptrM,sizeM) <- peekDatum ptrM+ (cptrE,sizeE) <- peekDatum ptrE+ (cptrD,sizeD) <- peekDatum ptrD+ (cptrP,sizeP) <- peekDatum ptrP+ (cptrQ,sizeQ) <- peekDatum ptrQ+ (cptrU,sizeU) <- peekDatum ptrU+ fpM <- newForeignPtr c_free_finalizer (castPtr cptrM)+ fpE <- newForeignPtr c_free_finalizer (castPtr cptrE)+ fpD <- newForeignPtr c_free_finalizer (castPtr cptrD)+ fpP <- newForeignPtr c_free_finalizer (castPtr cptrP)+ fpQ <- newForeignPtr c_free_finalizer (castPtr cptrQ)+ fpU <- newForeignPtr c_free_finalizer (castPtr cptrU)+ return $ Right+ (fromForeignPtr fpM 0 sizeM+ ,fromForeignPtr fpE 0 sizeE+ ,fromForeignPtr fpD 0 sizeD+ ,fromForeignPtr fpP 0 sizeP+ ,fromForeignPtr fpQ 0 sizeQ+ ,fromForeignPtr fpU 0 sizeU)++getPeersX509DN :: Certificate -> IO String+getPeersX509DN cert = do+ withCertificate cert $ \cp ->+ alloca $ \lenp -> do+ res <- {#call unsafe gnutls_x509_crt_get_dn #} cp nullPtr lenp+ len <- peek lenp+ if (len == 0)+ then return []+ else allocaBytes (fromIntegral len) $ \charp -> do+ res2 <- {#call unsafe gnutls_x509_crt_get_dn #} cp charp lenp+ throwGnutlsIfNeg res2+ len2 <- peek lenp+ peekCStringLen (charp, fromIntegral len2)+++-- | Check whether the certicate hostname matches the given name.+{#fun pure unsafe gnutls_x509_crt_check_hostname as checkHostname+ {withCertificate* `Certificate', withCString* `String'} -> `GnuTLSMonad Bool' gnuTLSCheckBool #}++-- | Check if the second certificate issued the first one.+{#fun pure unsafe gnutls_x509_crt_check_issuer as checkIssuer+ {withCertificate* `Certificate',withCertificate* `Certificate'} -> `GnuTLSMonad Bool' gnuTLSCheckBool#}++activationTime :: ReadWriteAttr Certificate ClockTime ClockTime+activationTime = newAttr g s+ where g c = withCertificate c {#call unsafe gnutls_x509_crt_get_activation_time#} >>= return . integralToClockTime+ s c (TOD s _) = do withCertificate c $ \cp -> do+ {#call gnutls_x509_crt_set_activation_time #} cp (fromIntegral s) >>= throwGnutlsIf++expirationTime :: ReadWriteAttr Certificate ClockTime ClockTime+expirationTime = newAttr g s+ where g c = withCertificate c {#call unsafe gnutls_x509_crt_get_expiration_time#} >>= return . integralToClockTime+ s c (TOD s _) = do withCertificate c $ \cp -> do+ {#call unsafe gnutls_x509_crt_set_expiration_time #} cp (fromIntegral s) >>= throwGnutlsIf++getIssuerDnByOid :: Certificate -> OID -> Int -> GnuTLSMonad (Maybe ByteString)+getIssuerDnByOid cert str ind = unsafePerformIO (getDnByOid' {#call unsafe gnutls_x509_crt_get_issuer_dn_by_oid#} cert str ind)++-- | Retrieves a field by it\'s Object Identifier.+getDnByOid :: Certificate -- ^ Certificate to retrieve the field-data from + -> OID -- ^ The field name, specified by an Object Indentifier+ -> Int -- ^ If there\'s more than one entry, this will be used to describe which one to use(0 gives the first entry)+ -> GnuTLSMonad (Maybe ByteString)+getDnByOid cert str ind = unsafePerformIO (getDnByOid' {#call unsafe gnutls_x509_crt_get_dn_by_oid#} cert str ind)++getExtensionByOid :: Certificate+ -> OID+ -> Int+ -> GnuTLSMonad (Maybe (ByteString,Bool))+getExtensionByOid cert str ind+ = unsafePerformIO $ alloca $ \crit ->+ withCString str $ \cstr -> + withCertificate cert $ \certptr ->+ with (1024::Int) $ \szptr ->+ createAndTrim' 1024 (\ptr -> do+ res <- {#call unsafe gnutls_x509_crt_get_extension_by_oid#} certptr cstr (fromIntegral ind) (castPtr ptr) (castPtr szptr) crit+ if res /= 0+ then return (0,0,Left $ GnuTLSError res)+ else (if ptr == nullPtr+ then return $ (0,0,Right False)+ else (do+ size <- peek szptr+ return (0,size,Right True)+ ))) >>= \(bs,res) -> case res of+ Left err -> return $ Left err+ Right True -> do+ iscrit <- peek crit+ return $ Right $ Just (bs,iscrit < 0)+ Right False -> return $ Right Nothing++getDnByOid' f cert str ind+ = withCString str $ \cstr -> + withCertificate cert $ \certptr ->+ with (1024::Int) $ \szptr ->+ createAndTrim' 1024 (\ptr -> do+ res <- f certptr cstr (fromIntegral ind) 0 (castPtr ptr) (castPtr szptr)+ if res /= 0+ then return (0,0,Left $ GnuTLSError res)+ else (if ptr == nullPtr+ then return $ (0,0,Right False)+ else (do+ size <- peek szptr+ return (0,size,Right True)+ ))) >>= \(bs,res) -> return $ case res of+ Left err -> Left err+ Right True -> Right $ Just bs+ Right False -> Right Nothing++privateKeyGetKeyId :: PrivateKey -> GnuTLSMonad ByteString+privateKeyGetKeyId key = unsafePerformIO $+ withPrivateKey key $ \rkey ->+ with (20::Int) $ \szptr -> -- KeyID is a SHA1 hash, ergo always 20 bytes+ createAndTrim' 20 (\ptr -> do+ res <- {#call unsafe gnutls_x509_privkey_get_key_id#} rkey 0 (castPtr ptr) (castPtr szptr)+ if res /= 0+ then return (0,0,Just $ GnuTLSError res)+ else (do+ size <- peek szptr+ return (0,size,Nothing)+ )) >>= \(bs,res) -> case res of+ Nothing -> return (Right bs)+ Just err -> return (Left err)++certificateGetKeyId :: Certificate -> GnuTLSMonad ByteString+certificateGetKeyId cert = unsafePerformIO $+ withCertificate cert $ \rcert ->+ with (20::Int) $ \szptr ->+ createAndTrim' 20 (\ptr -> do+ res <- {#call unsafe gnutls_x509_crt_get_key_id#} rcert 0 (castPtr ptr) (castPtr szptr)+ if res/=0+ then return (0,0,Just $ GnuTLSError res)+ else (do+ size <- peek szptr+ return (0,size,Nothing)+ )) >>= \(bs,res) -> case res of+ Nothing -> return (Right bs)+ Just err -> return (Left err)
+ Setup.hs view
@@ -0,0 +1,5 @@+module Main where++import Distribution.Simple++main = defaultMain
+ crypt_helpers.c view
@@ -0,0 +1,30 @@+#include <gcrypt.h>++int endian() {+ int i = 1;+ char* p = (char *)&i;+ if(p[0] == 1) return LITTLE_ENDIAN;+ else return BIG_ENDIAN;+}++void fix_endian(char *addr,size_t len) {+ if(endian() == LITTLE_ENDIAN) {+ size_t i;+ char tmp;+ for(i=0;i<len/2;i++) {+ tmp = addr[i];+ addr[i] = addr[len-i-1];+ addr[len-i-1] = tmp;+ }+ }+}++gcry_error_t gcry_cipher_setkey2 (gcry_cipher_hd_t H, void *K, size_t L) {+ fix_endian((char*)K,L);+ return gcry_cipher_setkey(H,K,L);+}++gcry_error_t gcry_cipher_setiv2 (gcry_cipher_hd_t H, void *K, size_t L) {+ fix_endian((char*)K,L);+ return gcry_cipher_setiv(H,K,L);+}
+ helpers.c view
@@ -0,0 +1,51 @@+#include <gnutls/gnutls.h>+#include <gcrypt.h>+#include <errno.h>+#include <pthread.h>+#include <stdlib.h>++long gnutls_io_wrap_h(void*,void*,size_t,int*);+void freeStablePtr(void *ptr);++#ifdef COMPAT_GNUTLS_1_0+typedef gnutls_transport_ptr gnutls_transport_ptr_t;+typedef gnutls_connection_end gnutls_connection_end_t;+typedef gnutls_session gnutls_session_t;+#endif+++static ssize_t gnutls_io_wrap_c(gnutls_transport_ptr_t tr, void* buf, size_t len) +{+ int err, res;+ res = gnutls_io_wrap_h(tr,buf,len,&err);+ errno = err;+ return res;+}+++void replace_transport_stable_ptrs(gnutls_session_t session, void *p1, void *p2) {+ void *o1, *o2;+ gnutls_transport_get_ptr2(session, &o1, &o2);+ gnutls_transport_set_ptr2(session, p1, p2);+ freeStablePtr(o1);+ freeStablePtr(o2);+}++gnutls_session_t init_session_wrap(gnutls_connection_end_t con_end, void *sptr1, void *sptr2, int *err) {+ gnutls_session_t ses;+ *err = gnutls_init(&ses, con_end);+ if(*err != 0) return 0;+ gnutls_transport_set_push_function(ses,(gnutls_push_func)&gnutls_io_wrap_c);+ gnutls_transport_set_pull_function(ses,&gnutls_io_wrap_c);+ gnutls_transport_set_ptr2(ses, sptr1, sptr2);+ gnutls_set_default_priority(ses);+ return ses;+}++GCRY_THREAD_OPTION_PTHREAD_IMPL;++void gcry_init_helper(void) {+ gcry_control(GCRYCTL_DISABLE_SECMEM_WARN);+ gcry_control(GCRYCTL_SET_THREAD_CBS, &gcry_threads_pthread);+ gcry_control(GCRYCTL_INIT_SECMEM, 16384, 0);+}
+ hsgnutls.cabal view
@@ -0,0 +1,52 @@+Name: hsgnutls+Version: 0.2.3.2+License: LGPL+License-File: LICENSE+Author: Einar Kartunen <ekarttun@cs.helsinki.fi>,+ Henning Günther <h.guenther@tu-bs.de>++Stability: Alpha+Category: Network+Synopsis: Library wrapping the GnuTLS API.+Description: hsgnutls is a wrapper to the GNU TLS Library.+ Currently it is in quite early stages but offers client functionality+ and parts of the server-side interface. Anonymous and X509 authentication+ is supported, but SRP and OpenPGP will appear in a future version.+ hsgnutls uses the attribute implementation borrowed from Gtk2Hs.+ .+ Note this is not the official hsgnutls, but rather a fork updated for the needs+ of the Barracuda ad-hoc chat client, which repo can be found at+ <http://repos.mroot.net/sep07-adhoc>.+Homepage: http://www.cs.helsinki.fi/u/ekarttun/hsgnutls++Build-Type: Simple+Build-Depends: base>3, mtl, old-time, bytestring>0.9+Tested-With: GHC==6.8.2++extra-libraries: gnutls, gcrypt++c-sources: helpers.c, crypt_helpers.c++Exposed-Modules: Network.GnuTLS,+ Network.GnuTLS.Attributes,+ Network.GnuTLS.GnuTLSMonad,+ Network.GnuTLS.Errors,+ Network.GnuTLS.X509,+ Network.GnuTLS.OID,+ Codec.Encryption,+ Codec.Encryption.Ciphers++Other-Modules: Network.GnuTLS.GnuTLS,+ Network.GnuTLS.Internals,+ Network.GnuTLS.IOWrap,+ Network.GnuTLS.RefCount++Extensions: FunctionalDependencies,+ ForeignFunctionInterface,+ TypeSynonymInstances,+ FlexibleInstances,+ MultiParamTypeClasses,+ ExistentialQuantification,+ FlexibleContexts,+ EmptyDataDecls,+ PatternSignatures