Commits

Bryan O'Sullivan committed 9fc3f2c

Initial commit

Comments (0)

Files changed (8)

+^(?:dist|\.DS_Store)$
+.*\.(?:aux|h[ip]|o|orig|out|pdf|prof|ps|rej)$
+^tests/(?:qc)$
+
+syntax: glob
+*~
+.*.swp
+.\#*
+\#*

Codec/Compression/Snappy.hs

+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Codec.Compression.Snappy
+    (
+      compress
+    , decompress
+    ) where
+
+import Control.Monad (unless)
+import Data.ByteString.Internal (ByteString(..), mallocByteString)
+import Data.Word (Word8)
+import Foreign.C.Types (CSize)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (Ptr, plusPtr)
+import Foreign.Storable (peek)
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.ByteString as B
+
+compress :: ByteString -> ByteString
+compress bs@(PS sfp off len) = unsafePerformIO $ do
+  let dlen0 = fromIntegral . c_MaxCompressedLength . fromIntegral $ len
+  dfp <- mallocByteString dlen0
+  withForeignPtr sfp $ \sptr ->
+    withForeignPtr dfp $ \dptr ->
+      with (fromIntegral dlen0) $ \dlenPtr -> do
+        c_RawCompress (sptr `plusPtr` off) (fromIntegral len) dptr dlenPtr
+        (PS dfp 0 . fromIntegral) `fmap` peek dlenPtr
+
+decompress :: ByteString -> ByteString
+decompress (PS sfp off slen) = unsafePerformIO $
+  withForeignPtr sfp $ \sptr0 -> do
+    let sptr = sptr0 `plusPtr` off
+        len = fromIntegral slen
+    alloca $ \dlenPtr -> do
+      ok0 <- c_GetUncompressedLength sptr len dlenPtr
+      unless ok0 $ error "Codec.Compression.Snappy.decompress: corrupt input"
+      dlen <- fromIntegral `fmap` peek dlenPtr
+      dfp <- mallocByteString dlen
+      withForeignPtr dfp $ \dptr -> do
+        ok1 <- c_RawUncompress sptr len dptr
+        unless ok1 $ error "Codec.Compression.Snappy.decompress: corrupt input"
+        return (PS dfp 0 dlen)
+
+foreign import ccall unsafe "hs_snappy.h _hsnappy_MaxCompressedLength"
+    c_MaxCompressedLength :: CSize -> CSize
+
+foreign import ccall unsafe "hs_snappy.h _hsnappy_RawCompress"
+    c_RawCompress :: Ptr a -> CSize -> Ptr Word8 -> Ptr CSize -> IO ()
+
+foreign import ccall unsafe "hs_snappy.h _hsnappy_GetUncompressedLength"
+    c_GetUncompressedLength :: Ptr a -> CSize -> Ptr CSize -> IO Bool
+
+foreign import ccall unsafe "hs_snappy.h _hsnappy_RawUncompress"
+    c_RawUncompress :: Ptr a -> CSize -> Ptr Word8 -> IO Bool
+Copyright (c) 2011, MailRank Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+    * Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+    * 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.
+    * Neither the name of MailRank Inc. nor the names of its
+contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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
+COPYRIGHT OWNER 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.

cbits/hs_snappy.cpp

+#include "hs_snappy.h"
+#include "snappy.h"
+
+size_t _hsnappy_MaxCompressedLength(size_t n)
+{
+  return snappy::MaxCompressedLength(n);
+}
+
+void _hsnappy_RawCompress(const char *input, size_t input_length,
+			  char *compressed, size_t *compressed_length)
+{
+  snappy::RawCompress(input, input_length, compressed, compressed_length);
+}
+
+bool _hsnappy_GetUncompressedLength(const char *compressed,
+				    size_t compressed_length,
+				    size_t *result)
+{
+  return snappy::GetUncompressedLength(compressed, compressed_length, result);
+}
+
+bool _hsnappy_RawUncompress(const char *compressed, size_t compressed_length,
+			    char *uncompressed)
+{
+  return snappy::RawUncompress(compressed, compressed_length, uncompressed);
+}

include/hs_snappy.h

+#ifndef _hs_snappy_h
+#define _hs_snappy_h
+
+#include <stddef.h>
+
+#ifdef __cplusplus
+extern "C" 
+{
+#endif
+
+size_t _hsnappy_MaxCompressedLength(size_t);
+
+void _hsnappy_RawCompress(const char *input, size_t input_length,
+			  char *compressed, size_t *compressed_length);
+
+bool _hsnappy_GetUncompressedLength(const char *compressed,
+				    size_t compressed_length,
+				    size_t *result);
+
+bool _hsnappy_RawUncompress(const char *compressed, size_t compressed_length,
+			    char *uncompressed);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _hs_snappy_h */
+name:           snappy
+version:        0.1.0.0
+homepage:       http://github.com/mailrank/snappy
+bug-reports:    http://github.com/mailrank/snappy/issues
+synopsis:
+  Bindings to the Google Snappy library for fast compression/decompression
+description:
+  This library provides efficient Haskell bindings to Google's Snappy
+  compression and decompression library.
+license:        BSD3
+license-file:   LICENSE
+author:         Bryan O'Sullivan <bos@mailrank.com>
+maintainer:     Bryan O'Sullivan <bos@mailrank.com>
+copyright:      Copyright 2011 MailRank, Inc.
+category:       Codec, Compression
+build-type:     Simple
+cabal-version:  >= 1.6
+extra-source-files:
+  tests/Makefile
+  tests/Properties.hs
+
+library
+  c-sources:       cbits/hs_snappy.cpp
+  include-dirs:    include
+  extra-libraries: snappy stdc++
+
+  build-depends:     base < 5, bytestring
+  if impl(ghc >= 6.10)
+    build-depends:   base >= 4
+
+  exposed-modules:
+    Codec.Compression.Snappy
+
+source-repository head
+  type:     git
+  location: http://github.com/mailrank/snappy
+ghc := ghc
+
+all: qc
+
+qc: Properties.hs
+	$(ghc) --make -o $@ $^
+
+clean:
+	-rm -f qc *.o *.hi

tests/Properties.hs

+import Codec.Compression.Snappy
+import Test.Framework (defaultMain, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck (Arbitrary(..))
+import qualified Data.ByteString as B
+
+roundtrip s = decompress (compress bs) == bs
+  where bs = B.pack s
+
+main = defaultMain tests
+
+tests = [
+    testProperty "roundtrip" roundtrip
+  ]
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.