Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial import

darcs-hash:20070612102126-62b54-0d5edfc0ffb0e262f64c38ac621fc9b4713108d9.gz
  • Loading branch information...
commit d8a6a593d0150af1f5f08698cdf7961a5f213a78 0 parents
PHO authored
61 .boring
@@ -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$
28 HsOpenSSL.cabal
@@ -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
31 Makefile
@@ -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
13 OpenSSL.hsc
@@ -0,0 +1,13 @@
+{- -*- haskell -*- -}
+module OpenSSL
+ ( withOpenSSL
+ )
+ where
+
+import OpenSSL.SSL
+
+withOpenSSL :: IO a -> IO a
+withOpenSSL act
+ = do loadErrorStrings
+ libraryInit
+ act
239 OpenSSL/BIO.hsc
@@ -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
14 OpenSSL/SSL.hsc
@@ -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 ()
10 OpenSSL/Unsafe.hs
@@ -0,0 +1,10 @@
+module OpenSSL.Unsafe
+ ( unsafeCoercePtr
+ )
+ where
+
+import GHC.Base
+import Foreign.Ptr
+
+unsafeCoercePtr :: Ptr a -> Ptr b
+unsafeCoercePtr = unsafeCoerce#
17 OpenSSL/Utils.hsc
@@ -0,0 +1,17 @@
+{- -*- haskell -*- -}
+module OpenSSL.Utils
+ ( failIfNull
+ , raiseOpenSSLError
+ )
+ where
+
+
+import Foreign
+import Foreign.C
+import Control.Monad
+
+failIfNull :: Ptr a -> IO ()
+failIfNull ptr = when (ptr == nullPtr) raiseOpenSSLError
+
+raiseOpenSSLError :: IO a
+raiseOpenSSLError = fail "FIXME: raiseOpenSSLError"
102 Setup.hs
@@ -0,0 +1,102 @@
+#!/usr/bin/env runghc
+
+import Data.Maybe
+import Distribution.PackageDescription
+import Distribution.Setup
+import Distribution.Simple
+import Distribution.Simple.Configure
+import Distribution.Simple.LocalBuildInfo
+import System.IO
+import System.Exit
+import System.Directory
+import System.Process
+import Control.Monad
+import Control.Exception
+
+main = defaultMainWithHooks defaultUserHooks {preConf = preConf, postConf = postConf}
+ where
+ preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo
+ preConf args flags
+ = do try (removeFile "HsOpenSSL.buildinfo")
+ return emptyHookedBuildInfo
+ postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode
+ postConf args flags _ localbuildinfo
+ = do biOpenSSL <- openSSLBuildInfo (configVerbose flags)
+ writeHookedBuildInfo "HsOpenSSL.buildinfo" (biOpenSSL, [])
+ return ExitSuccess
+
+
+message :: String -> IO ()
+message s = putStrLn $ "configure: " ++ s
+
+rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String
+rawSystemGrabOutput verbose path args
+ = do when (verbose > 0) $
+ putStrLn (path ++ concatMap (' ':) args)
+ (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing
+ exitCode <- waitForProcess pid
+ if exitCode /= ExitSuccess then
+ do errMsg <- hGetContents err
+ hPutStr stderr errMsg
+ exitWith exitCode else
+ return ()
+ hClose inp
+ hClose err
+ hGetContents out
+
+mergeBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo
+mergeBuildInfo b1 b2 = BuildInfo {
+ buildable = buildable b1 || buildable b2,
+ ccOptions = ccOptions b1 ++ ccOptions b2,
+ ldOptions = ldOptions b1 ++ ldOptions b2,
+ frameworks = frameworks b1 ++ frameworks b2,
+ cSources = cSources b1 ++ cSources b2,
+ hsSourceDirs = hsSourceDirs b1 ++ hsSourceDirs b2,
+ otherModules = otherModules b1 ++ otherModules b2,
+ extensions = extensions b1 ++ extensions b2,
+ extraLibs = extraLibs b1 ++ extraLibs b2,
+ extraLibDirs = extraLibDirs b1 ++ extraLibDirs b2,
+ includeDirs = includeDirs b1 ++ includeDirs b2,
+ includes = includes b1 ++ includes b2,
+ installIncludes = installIncludes b1 ++ installIncludes b2,
+ options = options b1 ++ options b2,
+ ghcProfOptions = ghcProfOptions b1 ++ ghcProfOptions b2
+ }
+
+openSSLBuildInfo :: Int -> IO (Maybe BuildInfo)
+openSSLBuildInfo verbose
+ = do Just pkg_config_path <- findProgram "pkg-config" Nothing
+ message "configuring OpenSSL library"
+ res <- rawSystemGrabOutput verbose pkg_config_path ["--libs", "openssl"]
+ let (lib_dirs, libs, ld_opts) = splitLibsFlags (words res)
+ res <- rawSystemGrabOutput verbose pkg_config_path ["--cflags", "openssl"]
+ let (inc_dirs, cc_opts) = splitCFlags (words res)
+ let bi = emptyBuildInfo {
+ extraLibDirs = lib_dirs
+ , extraLibs = libs
+ , ldOptions = ld_opts
+ , includeDirs = inc_dirs
+ , ccOptions = cc_opts
+ }
+ return $ Just bi
+
+
+splitLibsFlags :: [String] -> ([String], [String], [String])
+splitLibsFlags [] = ([], [], [])
+splitLibsFlags (arg:args)
+ = case arg
+ of ('-':'L':lib_dir) -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args
+ in (lib_dir:lib_dirs, libs, ld_opts)
+ ('-':'l':lib) -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args
+ in (lib_dirs, lib:libs, ld_opts)
+ ld_opt -> let (lib_dirs, libs, ld_opts) = splitLibsFlags args
+ in (lib_dirs, libs, ld_opt:ld_opts)
+
+splitCFlags :: [String] -> ([String], [String])
+splitCFlags [] = ([], [])
+splitCFlags (arg:args)
+ = case arg
+ of ('-':'I':inc_dir) -> let (inc_dirs, c_opts) = splitCFlags args
+ in (inc_dir:inc_dirs, c_opts)
+ c_opt -> let (inc_dirs, c_opts) = splitCFlags args
+ in (inc_dirs, c_opt:c_opts)
5 cbits/HsOpenSSL.c
@@ -0,0 +1,5 @@
+#include "HsOpenSSL.h"
+
+int _BIO_eof(BIO* bio) {
+ return BIO_eof(bio);
+}
7 cbits/HsOpenSSL.h
@@ -0,0 +1,7 @@
+#ifndef HSOPENSSL_H_INCLUDED
+#define HSOPENSSL_H_INCLUDED
+#include <openssl/bio.h>
+
+int _BIO_eof(BIO* bio);
+
+#endif
14 examples/HelloWorld.hs
@@ -0,0 +1,14 @@
+import OpenSSL
+import OpenSSL.BIO as BIO
+
+main = withOpenSSL $
+ do --bMem <- new =<< s_mem
+ --write bMem "Hello, world!"
+
+ bMem <- newMemBuf "Hello, WORLD!\x0a---"
+
+ cont <- BIO.gets bMem 100
+ putStrLn (":" ++ cont)
+
+ cont' <- BIO.gets bMem 100
+ putStrLn (":" ++ cont')
10 examples/Makefile
@@ -0,0 +1,10 @@
+build:
+ ghc --make HelloWorld -threaded -fglasgow-exts -O3
+
+run: build
+ ./HelloWorld
+
+clean:
+ rm -f HelloWorld *.hi *.o
+
+.PHONY: build run clean
Please sign in to comment.
Something went wrong with that request. Please try again.