diff --git a/Codec/Encryption.chs b/Codec/Encryption.chs new file mode 100644 --- /dev/null +++ b/Codec/Encryption.chs @@ -0,0 +1,181 @@ + +module Codec.Encryption + (Cipher(..) + ,Word128(..) + ,Word192(..) + ,pkcs5 + ,unpkcs5 + ,module Codec.Encryption.Ciphers + ) where + +#include + +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 diff --git a/Codec/Encryption/Ciphers.hsc b/Codec/Encryption/Ciphers.hsc new file mode 100644 --- /dev/null +++ b/Codec/Encryption/Ciphers.hsc @@ -0,0 +1,84 @@ +module Codec.Encryption.Ciphers where + +#include + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + + Copyright (C) + + 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. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/Network/GnuTLS.hs b/Network/GnuTLS.hs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS.hs @@ -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 diff --git a/Network/GnuTLS/Attributes.hs b/Network/GnuTLS/Attributes.hs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/Attributes.hs @@ -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 diff --git a/Network/GnuTLS/Errors.hsc b/Network/GnuTLS/Errors.hsc new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/Errors.hsc @@ -0,0 +1,9 @@ +module Network.GnuTLS.Errors where + +#include + +import Foreign.C.Types +--import Network.GnuTLS.GnuTLSMonad + +errorShortMemory :: CInt +errorShortMemory = #{const GNUTLS_E_SHORT_MEMORY_BUFFER} diff --git a/Network/GnuTLS/GnuTLS.chs b/Network/GnuTLS/GnuTLS.chs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/GnuTLS.chs @@ -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 + +{#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 () + diff --git a/Network/GnuTLS/GnuTLSMonad.chs b/Network/GnuTLS/GnuTLSMonad.chs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/GnuTLSMonad.chs @@ -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 + +{#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) diff --git a/Network/GnuTLS/IOWrap.hs b/Network/GnuTLS/IOWrap.hs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/IOWrap.hs @@ -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 + diff --git a/Network/GnuTLS/Internals.chs b/Network/GnuTLS/Internals.chs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/Internals.chs @@ -0,0 +1,157 @@ +module Network.GnuTLS.Internals where + +#include + +{#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 + diff --git a/Network/GnuTLS/OID.hsc b/Network/GnuTLS/OID.hsc new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/OID.hsc @@ -0,0 +1,48 @@ +module Network.GnuTLS.OID where + +#include + +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" diff --git a/Network/GnuTLS/RefCount.hs b/Network/GnuTLS/RefCount.hs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/RefCount.hs @@ -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),()) diff --git a/Network/GnuTLS/X509.chs b/Network/GnuTLS/X509.chs new file mode 100644 --- /dev/null +++ b/Network/GnuTLS/X509.chs @@ -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 + +{#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 _ = "" + +instance Show Certificate where + show _ = "" + +#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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +module Main where + +import Distribution.Simple + +main = defaultMain diff --git a/crypt_helpers.c b/crypt_helpers.c new file mode 100644 --- /dev/null +++ b/crypt_helpers.c @@ -0,0 +1,30 @@ +#include + +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 +#include +#include +#include +#include + +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); +} diff --git a/hsgnutls.cabal b/hsgnutls.cabal new file mode 100644 --- /dev/null +++ b/hsgnutls.cabal @@ -0,0 +1,52 @@ +Name: hsgnutls +Version: 0.2.3.2 +License: LGPL +License-File: LICENSE +Author: Einar Kartunen , + Henning Günther + +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 + . +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