diff --git a/Data/Digest/OpenSSL/MD5.hs b/Data/Digest/OpenSSL/MD5.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/OpenSSL/MD5.hs @@ -0,0 +1,66 @@ +{-# OPTIONS -#include "openssl/md5.h" #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.Digest.OpenSSL.MD5 +-- Copyright : (c) Galois, Inc. 2007 +-- License : BSD3 +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: Requires FFI +-- +-------------------------------------------------------------------- +-- +-- | ByteString-based, zero-copying binding to OpenSSL's md5 interface +-- + +module Data.Digest.OpenSSL.MD5 where + + +-- +-- A few imports, should tidy these up one day. +-- +#if __GLASGOW_HASKELL__ >= 608 +import qualified Data.ByteString.Unsafe as B (unsafeUseAsCStringLen) +#else +import qualified Data.ByteString.Base as B (unsafeUseAsCStringLen) +#endif +import qualified Data.ByteString as B +import Foreign +import Foreign.C.Types +import Numeric (showHex) + +-- +-- | Fast md5 using OpenSSL. The md5 hash should be referentially transparent.. +-- The ByteString is guaranteed not to be copied. +-- +-- The result string should be identical to the output of MD5(1). +-- That is: +-- +-- > $ md5 /usr/share/dict/words +-- > MD5 (/usr/share/dict/words) = e5c152147e93b81424c13772330e74b3 +-- +-- While this md5sum binding will return: +-- +md5sum :: B.ByteString -> String +md5sum p = unsafePerformIO $ B.unsafeUseAsCStringLen p $ \(ptr,n) -> do + digest <- c_md5 ptr (fromIntegral n) nullPtr + go digest 0 [] + where + + -- print it in 0-padded hex format + go :: Ptr Word8 -> Int -> [String] -> IO String + go !q !n acc + | n >= 16 = return $ concat (reverse acc) + | otherwise = do w <- peekElemOff q n + go q (n+1) (draw w : acc) + + draw w = case showHex w [] of + [x] -> ['0', x] + x -> x + +-- +-- unsigned char *MD5(const unsigned char *d, unsigned long n, unsigned char *md); +-- +foreign import ccall "openssl/md5.h MD5" c_md5 + :: Ptr CChar -> CULong -> Ptr CChar -> IO (Ptr Word8) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright : (c) Galois, Inc. 2007 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +Minimal bytestring binding to openssl's md5sum diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/nano-md5.cabal b/nano-md5.cabal new file mode 100644 --- /dev/null +++ b/nano-md5.cabal @@ -0,0 +1,24 @@ +name: nano-md5 +version: 0.1 +description: Efficient, ByteString bindings to OpenSSL. +synopsis: Efficient, ByteString bindings to OpenSSL. +license: BSD3 +license-file: LICENSE +homepage: http://code.haskell.org/~dons/code/nano-md5 +author: Don Stewart +category: Codec +maintainer: +Cabal-Version: >= 1.2 + +flag split-base +library + if flag(split-base) + build-depends: base >= 3, bytestring + else + build-depends: base < 3 + exposed-modules: Data.Digest.OpenSSL.MD5 + ghc-options: -Wall -Werror -O2 -fvia-C + extensions: ForeignFunctionInterface, BangPatterns, CPP + includes: openssl/md5.h + extra-libraries: crypto + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,62 @@ +module Main where + +import Test.QuickCheck +import System.IO.Unsafe +import System.IO +import System.Process +import Data.ByteString (pack) +import Data.ByteString.Char8 (unpack) +import Data.Char +import Data.Word +import System.Random +import System.Directory + +import Data.Digest.OpenSSL.MD5 +import Run + +main = quickCheck prop_md5sum + +prop_md5sum :: [Word8] -> Bool +prop_md5sum x = md5sum (pack x) == model_md5 (toString x) + +toString :: [Word8] -> String +toString = unpack . pack + +-- [] --> "d41d8cd98f00b204e9800998ecf8427e" + +model_md5 :: String -> String +model_md5 x = unsafePerformIO $ do + f <- do writeFile "test.txt" x + return "test.txt" + + v <- readProcess "md5" [f] [] + removeFile f + return $! case v of + Left e -> "ERROR: " ++ show e + Right s -> reverse. tail. takeWhile (/= ' ') . reverse $ s + + -- "MD5 (test.txt) = d41d8cd98f00b204e9800998ecf8427e\n" + +{- +*Main> quickCheck prop_md5sum +OK, passed 100 tests. +-} + + +------------------------------------------------------------------------ + +instance Arbitrary Word8 where + arbitrary = choose (minBound, maxBound) + coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + + +------------------------------------------------------------------------ diff --git a/tests/Run.hs b/tests/Run.hs new file mode 100644 --- /dev/null +++ b/tests/Run.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Process.Run +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : currently non-portable (Control.Concurrent) +-- +-- Convenient interface to external processes +-- + +module Run ( + + -- * Running processes + readProcess + + ) where + +import System.Process +import System.Exit +import System.IO + +import Control.Monad +import Control.Concurrent +import qualified Control.Exception as C + +-- +-- | readProcess forks an external process, reads its standard output, +-- waits for the process to terminate, and returns either the output +-- string, or an exitcode. +-- +readProcess :: FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO (Either ExitCode String) -- ^ either the stdout, or an exitcode + +readProcess cmd args input = C.handle (return . handler) $ do + + (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + forkIO $ C.evaluate (length output) >> putMVar outMVar () + + -- now write and flush any input + when (not (null input)) $ hPutStr inh input + hClose inh -- done with stdin + hClose errh -- ignore stderr + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- C.catch (waitForProcess pid) (\_ -> return ExitSuccess) + + return $ case ex of + ExitSuccess -> Right output + ExitFailure _ -> Left ex + + where + handler (C.ExitException e) = Left e + handler e = Left (ExitFailure 1) +