diff --git a/Codec/Compression/Snappy.hs b/Codec/Compression/Snappy.hs new file mode 100644 --- /dev/null +++ b/Codec/Compression/Snappy.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module: Codec.Compression.Snappy +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- This library provides fast, pure Haskell bindings to Google's +-- Snappy compression and decompression library: +-- + +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 data into the Snappy format. +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 data in the Snappy format. +-- +-- If the input is not compressed or is corrupt, an exception will be +-- thrown. +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# Welcome to snappy + +snappy is a fast Haskell library for working with data compressed +using Google's Snappy format. It is implemented as a binding to the +[Snappy library](http://code.google.com/p/snappy/). + +# Join in! + +We are happy to receive bug reports, fixes, documentation enhancements, +and other improvements. + +Please report bugs via the +[github issue tracker](http://github.com/mailrank/snappy/issues). + +Master [git repository](http://github.com/mailrank/snappy): + +* `git clone git://github.com/mailrank/snappy.git` + +There's also a [Mercurial mirror](http://bitbucket.org/bos/snappy): + +* `hg clone http://bitbucket.org/bos/snappy` + +(You can create and contribute changes using either git or Mercurial.) + +Authors +------- + +This library is written and maintained by Bryan O'Sullivan, +. 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/cbits/hs_snappy.cpp b/cbits/hs_snappy.cpp new file mode 100644 --- /dev/null +++ b/cbits/hs_snappy.cpp @@ -0,0 +1,26 @@ +#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); +} diff --git a/include/hs_snappy.h b/include/hs_snappy.h new file mode 100644 --- /dev/null +++ b/include/hs_snappy.h @@ -0,0 +1,27 @@ +#ifndef _hs_snappy_h +#define _hs_snappy_h + +#include + +#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 */ diff --git a/snappy.cabal b/snappy.cabal new file mode 100644 --- /dev/null +++ b/snappy.cabal @@ -0,0 +1,38 @@ +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 fast, pure Haskell bindings to Google's Snappy + compression and decompression library: +license: BSD3 +license-file: LICENSE +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan +copyright: Copyright 2011 MailRank, Inc. +category: Codec, Compression +build-type: Simple +cabal-version: >= 1.6 +extra-source-files: + README.md + include/hs_snappy.h + 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 diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,9 @@ +ghc := ghc + +all: qc + +qc: Properties.hs + $(ghc) --make -o $@ $^ + +clean: + -rm -f qc *.o *.hi diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,14 @@ +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 + ]