Permalink
Browse files

Initial import

darcs-hash:20070612102126-62b54-0d5edfc0ffb0e262f64c38ac621fc9b4713108d9.gz
  • Loading branch information...
0 parents commit d8a6a593d0150af1f5f08698cdf7961a5f213a78 @depressed-pho committed Jun 12, 2007
Showing with 551 additions and 0 deletions.
  1. +61 −0 .boring
  2. +28 −0 HsOpenSSL.cabal
  3. +31 −0 Makefile
  4. +13 −0 OpenSSL.hsc
  5. +239 −0 OpenSSL/BIO.hsc
  6. +14 −0 OpenSSL/SSL.hsc
  7. +10 −0 OpenSSL/Unsafe.hs
  8. +17 −0 OpenSSL/Utils.hsc
  9. +102 −0 Setup.hs
  10. +5 −0 cbits/HsOpenSSL.c
  11. +7 −0 cbits/HsOpenSSL.h
  12. +14 −0 examples/HelloWorld.hs
  13. +10 −0 examples/Makefile
@@ -0,0 +1,61 @@
+# Boring file regexps:
+\.hi$
+\.hi-boot$
+\.o-boot$
+\.o$
+\.o\.cmd$
+# *.ko files aren't boring by default because they might
+# be Korean translations rather than kernel modules.
+# \.ko$
+\.ko\.cmd$
+\.mod\.c$
+(^|/)\.tmp_versions($|/)
+(^|/)CVS($|/)
+(^|/)RCS($|/)
+~$
+#(^|/)\.[^/]
+(^|/)_darcs($|/)
+\.bak$
+\.BAK$
+\.orig$
+(^|/)vssver\.scc$
+\.swp$
+(^|/)MT($|/)
+(^|/)\{arch\}($|/)
+(^|/).arch-ids($|/)
+(^|/),
+\.class$
+\.prof$
+(^|/)\.DS_Store$
+(^|/)BitKeeper($|/)
+(^|/)ChangeSet($|/)
+(^|/)\.svn($|/)
+\.py[co]$
+\#
+\.cvsignore$
+(^|/)Thumbs\.db$
+(^|/)autom4te\.cache($|/)
+,v$
+^\.#
+\.elc$
+(^|/)(tags|TAGS)$
+(^|/)SCCS($|/)
+(^|/)config\.(log|status)$
+\.rej$
+\.bzr$
+(^|/|\.)core$
+\.(obj|a|exe|so|lo|la)$
+^\.darcs-temp-mail$
+^\.depend$
+
+^\.installed-pkg-config$
+^\.setup-config$
+\.buildinfo$
+
+^OpenSSL\.hs$
+^OpenSSL/BIO\.hs$
+^OpenSSL/SSL\.hs$
+^OpenSSL/Utils\.hs$
+^Setup$
+^dist($|/)
+^examples/HelloWorld$
@@ -0,0 +1,28 @@
+Name: HsOpenSSL
+Synopsis: Wrapper of (part of) the OpenSSL
+Description:
+ FIXME: write this
+Version: 0.1
+License: PublicDomain
+Author: PHO <phonohawk at ps dot sakura dot ne dot jp>
+Maintainer: PHO <phonohawk at ps dot sakura dot ne dot jp>
+Stability: experimental
+Homepage: http://ccm.sherry.jp/hs-openssl/
+Category: Cryptography
+Tested-With: GHC == 6.6.1
+Build-Depends:
+ base
+Exposed-Modules:
+ OpenSSL
+ OpenSSL.BIO
+ OpenSSL.SSL
+ OpenSSL.Unsafe
+ OpenSSL.Utils
+Extensions:
+ ForeignFunctionInterface
+ghc-options:
+ -fglasgow-exts
+C-Sources:
+ cbits/HsOpenSSL.c
+Include-Dirs:
+ cbits
@@ -0,0 +1,31 @@
+CABAL_FILE = HsOpenSSL.cabal
+GHC = ghc
+
+build: .setup-config Setup
+ ./Setup build
+
+run: build
+ @echo ".:.:. Let's go .:.:."
+ $(MAKE) -C examples run
+
+.setup-config: $(CABAL_FILE) Setup
+ ./Setup configure
+
+Setup: Setup.hs
+ $(GHC) --make Setup
+
+clean:
+ rm -rf dist Setup Setup.o Setup.hi .setup-config
+ find . -name '*~' -exec rm -f {} \;
+ $(MAKE) -C examples clean
+
+doc: .setup-config Setup
+ ./Setup haddock
+
+install: build
+ ./Setup install
+
+sdist: Setup
+ ./Setup sdist
+
+.PHONY: build run clean install doc sdist
@@ -0,0 +1,13 @@
+{- -*- haskell -*- -}
+module OpenSSL
+ ( withOpenSSL
+ )
+ where
+
+import OpenSSL.SSL
+
+withOpenSSL :: IO a -> IO a
+withOpenSSL act
+ = do loadErrorStrings
+ libraryInit
+ act
@@ -0,0 +1,239 @@
+{- -*- haskell -*- -}
+module OpenSSL.BIO
+ ( BioMethod
+ , BIO
+ , new
+ , push
+ , (==>)
+
+ , eof
+ , read
+ , readBS
+ , readLBS
+ , gets
+ , getsBS
+ , getsLBS
+ , write
+ , writeBS
+ , writeLBS
+
+ , s_mem
+ , newMemBuf
+ , newMemBufBS
+ , newMemBufLBS
+
+ , s_null
+ )
+ where
+
+#include "HsOpenSSL.h"
+
+import Control.Monad
+import qualified Data.ByteString as B
+import Data.ByteString.Base
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Foreign hiding (new)
+import Foreign.C
+import qualified GHC.ForeignPtr as GF
+import OpenSSL.Unsafe
+import OpenSSL.Utils
+import Prelude hiding (read)
+import System.IO.Unsafe
+
+{- bio ---------------------------------------------------------------------- -}
+
+newtype BioMethod = BioMethod (Ptr ())
+type BioMethod_ptr = Ptr ()
+
+newtype BIO = BIO (ForeignPtr ())
+type BIO_ptr = Ptr ()
+
+foreign import ccall "BIO_new"
+ _new :: BioMethod_ptr -> IO BIO_ptr
+
+foreign import ccall "&BIO_free"
+ _free :: FunPtr (BIO_ptr -> IO ())
+
+foreign import ccall "BIO_push"
+ _push :: BIO_ptr -> BIO_ptr -> IO BIO_ptr
+
+
+new :: BioMethod -> IO BIO
+new (BioMethod method)
+ = do ptr <- _new method
+ failIfNull ptr
+ liftM BIO $ newForeignPtr _free ptr
+
+
+-- a の後ろに b を付ける。a の參照だけ保持してそこに書き込む事も、b の
+-- 參照だけ保持してそこから讀み出す事も、兩方考へられるので、双方の
+-- ForeignPtr が双方を touch する。參照カウント方式ではないから循環參照
+-- しても問題無い。
+push :: BIO -> BIO -> IO ()
+push (BIO a) (BIO b)
+ = withForeignPtr a $ \ aPtr ->
+ withForeignPtr b $ \ bPtr ->
+ do _push aPtr bPtr
+ GF.addForeignPtrConcFinalizer a $ touchForeignPtr b
+ GF.addForeignPtrConcFinalizer b $ touchForeignPtr a
+ return ()
+
+(==>) = push
+
+
+{- I/O ---------------------------------------------------------------------- -}
+
+foreign import ccall "_BIO_eof"
+ _eof :: BIO_ptr -> IO Int
+
+foreign import ccall "BIO_read"
+ _read :: BIO_ptr -> Ptr CChar -> Int -> IO Int
+
+foreign import ccall "BIO_gets"
+ _gets :: BIO_ptr -> Ptr CChar -> Int -> IO Int
+
+foreign import ccall "BIO_write"
+ _write :: BIO_ptr -> Ptr CChar -> Int -> IO Int
+
+
+eof :: BIO -> IO Bool
+eof (BIO bio)
+ = withForeignPtr bio $ \ bioPtr ->
+ do ret <- _eof bioPtr
+ return $ ret == 1
+
+
+read :: BIO -> IO String
+read bio
+ = liftM L8.unpack $ readLBS bio
+
+
+readBS :: BIO -> Int -> IO ByteString
+readBS (BIO bio) maxLen
+ = withForeignPtr bio $ \ bioPtr ->
+ createAndTrim maxLen $ \ buf ->
+ do ret <- _read bioPtr (unsafeCoercePtr buf) maxLen
+ interpret ret
+ where
+ interpret :: Int -> IO Int
+ interpret n
+ | n == 0 = return 0
+ | n == -1 = return 0
+ | n < -1 = raiseOpenSSLError
+ | otherwise = return n
+
+
+readLBS :: BIO -> IO LazyByteString
+readLBS (BIO bio) = lazyRead >>= return . LPS
+ where
+ chunkSize = 32 * 1024
+
+ lazyRead = unsafeInterleaveIO loop
+
+ loop = do bs <- readBS (BIO bio) chunkSize
+ if B.null bs then
+ do isEOF <- eof (BIO bio)
+ if isEOF then
+ return []
+ else
+ loop
+ else
+ do bss <- lazyRead
+ return (bs:bss)
+
+
+gets :: BIO -> Int -> IO String
+gets bio maxLen
+ = liftM B8.unpack (getsBS bio maxLen)
+
+
+getsBS :: BIO -> Int -> IO ByteString
+getsBS (BIO bio) maxLen
+ = withForeignPtr bio $ \ bioPtr ->
+ createAndTrim maxLen $ \ buf ->
+ do ret <- _gets bioPtr (unsafeCoercePtr buf) maxLen
+ interpret ret
+ where
+ interpret :: Int -> IO Int
+ interpret n
+ | n == 0 = return 0
+ | n == -1 = return 0
+ | n < -1 = raiseOpenSSLError
+ | otherwise = return n
+
+
+getsLBS :: BIO -> Int -> IO LazyByteString
+getsLBS bio maxLen
+ = getsBS bio maxLen >>= \ bs -> (return . LPS) [bs]
+
+
+write :: BIO -> String -> IO ()
+write bio str
+ = (return . L8.pack) str >>= writeLBS bio
+
+
+writeBS :: BIO -> ByteString -> IO ()
+writeBS (BIO bio) bs
+ = withForeignPtr bio $ \ bioPtr ->
+ unsafeUseAsCStringLen bs $ \ (buf, len) ->
+ do ret <- _write bioPtr buf len
+ interpret ret
+ where
+ interpret :: Int -> IO ()
+ interpret n
+ | n == B.length bs = return ()
+ | n == -1 = writeBS (BIO bio) bs -- full retry
+ | n < -1 = raiseOpenSSLError
+ | otherwise = writeBS (BIO bio) (B.drop n bs) -- partial retry
+
+
+writeLBS :: BIO -> LazyByteString -> IO ()
+writeLBS bio (LPS chunks)
+ = mapM_ (writeBS bio) chunks
+
+
+{- mem ---------------------------------------------------------------------- -}
+
+foreign import ccall "BIO_s_mem"
+ _s_mem :: IO BioMethod_ptr
+
+foreign import ccall "BIO_new_mem_buf"
+ _new_mem_buf :: Ptr CChar -> Int -> IO BIO_ptr
+
+
+s_mem :: IO BioMethod
+s_mem = liftM BioMethod _s_mem
+
+
+newMemBuf :: String -> IO BIO
+newMemBuf str
+ = (return . B8.pack) str >>= newMemBufBS
+
+
+-- ByteString への參照を BIO の finalizer に持たせる。
+newMemBufBS :: ByteString -> IO BIO
+newMemBufBS bs
+ = let (foreignBuf, off, len) = toForeignPtr bs
+ in
+ withForeignPtr foreignBuf $ \ buf ->
+ do bioPtr <- _new_mem_buf (unsafeCoercePtr $ buf `plusPtr` off) len
+ failIfNull bioPtr
+
+ bio <- newForeignPtr _free bioPtr
+ GF.addForeignPtrConcFinalizer bio $ touchForeignPtr foreignBuf
+
+ return $ BIO bio
+
+
+newMemBufLBS :: LazyByteString -> IO BIO
+newMemBufLBS (LPS bss)
+ = (return . B.concat) bss >>= newMemBufBS
+
+{- null --------------------------------------------------------------------- -}
+
+foreign import ccall "BIO_s_null"
+ _s_null :: IO BioMethod_ptr
+
+s_null :: IO BioMethod
+s_null = liftM BioMethod _s_null
@@ -0,0 +1,14 @@
+{- -*- haskell -*- -}
+module OpenSSL.SSL
+ ( loadErrorStrings
+ , libraryInit
+ )
+ where
+
+#include <openssl/ssl.h>
+
+foreign import ccall "SSL_load_error_strings"
+ loadErrorStrings :: IO ()
+
+foreign import ccall "SSL_library_init"
+ libraryInit :: IO ()
Oops, something went wrong.

0 comments on commit d8a6a59

Please sign in to comment.