diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,4 +1,6 @@ Doug Beardsley Gregory Collins Shu-yu Guo +Carl Howells James Sanders +Jacob Stanley diff --git a/cbits/timefuncs.c b/cbits/timefuncs.c --- a/cbits/timefuncs.c +++ b/cbits/timefuncs.c @@ -11,11 +11,17 @@ time_t c_parse_http_time(char* s) { struct tm dest; strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest); - return mktime(&dest); + return timegm(&dest); } void c_format_http_time(time_t src, char* dest) { struct tm t; gmtime_r(&src, &t); strftime(dest, 40, "%a, %d %b %Y %H:%M:%S GMT", &t); +} + +void c_format_log_time(time_t src, char* dest) { + struct tm t; + localtime_r(&src, &t); + strftime(dest, 40, "%d/%b/%Y:%H:%M:%S %z", &t); } diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.2.3 +version: 0.2.4 synopsis: Snap: A Haskell Web Framework (Core) description: @@ -100,6 +100,11 @@ be evaluated but not printed. Default: False +Flag portable + Description: Compile in cross-platform mode. No platform-specific code or + optimizations such as C routines will be used. + Default: False + Library hs-source-dirs: src @@ -109,8 +114,12 @@ if flag(testsuite) cpp-options: -DDEBUG_TEST - c-sources: cbits/timefuncs.c - include-dirs: cbits + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + else + c-sources: cbits/timefuncs.c + include-dirs: cbits + build-depends: bytestring-mmap >= 0.2.1 && <0.3 exposed-modules: Data.CIByteString, @@ -130,7 +139,6 @@ attoparsec >= 0.8.0.2 && < 0.9, base >= 4 && < 5, bytestring, - bytestring-mmap >= 0.2.1 && <0.3, bytestring-nums, cereal >= 0.2 && < 0.3, containers, @@ -145,7 +153,7 @@ text >= 0.7.1 && <0.8, time, transformers, - unix, + unix-compat, zlib ghc-prof-options: -prof -auto-all @@ -168,6 +176,7 @@ cereal >= 0.2 && < 0.3, containers, directory, + directory-tree, dlist >= 0.5 && < 0.6, filepath, haskell98, @@ -175,10 +184,11 @@ monads-fd, old-locale, old-time, + template-haskell, text >= 0.7.1 && <0.8, time, transformers, - unix, + unix-compat, zlib ghc-prof-options: -prof -auto-all diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs --- a/src/Snap/Internal/Debug.hs +++ b/src/Snap/Internal/Debug.hs @@ -37,7 +37,7 @@ ------------------------------------------------------------------------------ _debugMVar :: MVar () _debugMVar = unsafePerformIO $ newMVar () - +{-# NOINLINE _debugMVar #-} ------------------------------------------------------------------------------ debug :: (MonadIO m) => String -> m () diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -5,6 +5,7 @@ -- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Types". {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} @@ -24,6 +25,7 @@ import Data.ByteString.Internal (c2w,w2c) import qualified Data.ByteString.Nums.Careless.Hex as Cvt import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S import Data.Char import Data.DList (DList) import qualified Data.DList as DL @@ -36,30 +38,42 @@ import Data.Time.Format import Data.Word import Foreign hiding (new) -import Foreign.C.String import Foreign.C.Types import Prelude hiding (take) import System.Locale (defaultTimeLocale) + +#ifdef PORTABLE +import Data.Time.LocalTime +import Data.Time.Clock.POSIX +#else +import Foreign.C.String +#endif + ------------------------------------------------------------------------------ import Data.CIByteString import qualified Snap.Iteratee as I +#ifndef PORTABLE + ------------------------------------------------------------------------------ +-- foreign imports from cbits + foreign import ccall unsafe "set_c_locale" set_c_locale :: IO () - ------------------------------------------------------------------------------- foreign import ccall unsafe "c_parse_http_time" c_parse_http_time :: CString -> IO CTime - ------------------------------------------------------------------------------- foreign import ccall unsafe "c_format_http_time" c_format_http_time :: CTime -> CString -> IO () +foreign import ccall unsafe "c_format_log_time" + c_format_log_time :: CTime -> CString -> IO () + +#endif + ------------------------------------------------------------------------------ type Enumerator a = I.Enumerator IO a @@ -502,31 +516,62 @@ ------------------------------------------------------------------------------ -- HTTP dates -{- --- | Converts a 'ClockTime' into an HTTP timestamp. -formatHttpTime :: UTCTime -> ByteString -formatHttpTime = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" - --- | Converts an HTTP timestamp into a 'UTCTime'. -parseHttpTime :: ByteString -> Maybe UTCTime -parseHttpTime s' = - parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" s - where - s = toStr s' --} - -- | Converts a 'CTime' into an HTTP timestamp. formatHttpTime :: CTime -> IO ByteString -formatHttpTime t = allocaBytes 40 $ \ptr -> do - c_format_http_time t ptr - S.packCString ptr +-- | Converts a 'CTime' into common log entry format. +formatLogTime :: CTime -> IO ByteString ------------------------------------------------------------------------------- -- | Converts an HTTP timestamp into a 'CTime'. parseHttpTime :: ByteString -> IO CTime -parseHttpTime s = S.useAsCString s $ \ptr -> + +#ifdef PORTABLE + +formatHttpTime = return . format . toUTCTime + where + format :: UTCTime -> ByteString + format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" + + toUTCTime :: CTime -> UTCTime + toUTCTime = posixSecondsToUTCTime . realToFrac + +formatLogTime ctime = do + t <- utcToLocalZonedTime $ toUTCTime ctime + return $ format t + + where + format :: ZonedTime -> ByteString + format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" + + toUTCTime :: CTime -> UTCTime + toUTCTime = posixSecondsToUTCTime . realToFrac + + +parseHttpTime = return . toCTime . parse . toStr + where + parse :: String -> Maybe UTCTime + parse = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" + + toCTime :: Maybe UTCTime -> CTime + toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t + toCTime Nothing = fromInteger 0 + +#else + +formatLogTime t = do + ptr <- mallocBytes 40 + c_format_log_time t ptr + S.unsafePackMallocCString ptr + +formatHttpTime t = do + ptr <- mallocBytes 40 + c_format_http_time t ptr + S.unsafePackMallocCString ptr + +parseHttpTime s = S.unsafeUseAsCString s $ \ptr -> c_parse_http_time ptr + +#endif ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -84,7 +84,7 @@ ------------------------------------------------------------------------------ newtype Snap a = Snap { unSnap :: StateT SnapState (Iteratee IO) (Maybe (Either Response a)) -} +} deriving Typeable ------------------------------------------------------------------------------ diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -36,23 +37,40 @@ , takeNoMoreThan , countBytes , bufferIteratee + , mkIterateeBuffer + , unsafeBufferIterateeWithBuffer + , unsafeBufferIteratee ) where ------------------------------------------------------------------------------ -import Control.Exception (SomeException) import Control.Monad import Control.Monad.CatchIO import Data.ByteString (ByteString) import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Lazy as L +import Data.IORef import Data.Iteratee +#ifdef PORTABLE +import Data.Iteratee.IO (enumHandle) +#endif import qualified Data.Iteratee.Base.StreamChunk as SC import Data.Iteratee.WrappedByteString import Data.Monoid (mappend) -import Data.Word (Word8) +import Foreign +import Foreign.C.Types +import GHC.ForeignPtr import Prelude hiding (catch,drop) -import System.IO.Posix.MMap import qualified Data.DList as D + +#ifdef PORTABLE +import Control.Monad.Trans (liftIO) +import System.IO +#else +import Control.Exception (SomeException) +import System.IO.Posix.MMap +#endif + ------------------------------------------------------------------------------ type Stream = StreamG WrappedByteString Word8 @@ -67,11 +85,11 @@ --catch :: Exception e => m a -> (e -> m a) -> m a catch m handler = IterateeG $ \str -> do ee <- try $ runIter m str - case ee of + case ee of (Left e) -> runIter (handler e) str (Right v) -> return v - --block :: m a -> m a + --block :: m a -> m a block m = IterateeG $ \str -> block $ runIter m str unblock m = IterateeG $ \str -> unblock $ runIter m str @@ -126,8 +144,8 @@ Cont i Nothing -> runIter i ch where big = toWrap $ L.fromChunks [S.concat $ D.toList dl] - - f (!dl,!n) iter (Chunk ws) = + + f (!dl,!n) iter (Chunk (WrapBS s)) = if n' > blocksize then do iterv <- runIter iter (Chunk big) @@ -137,14 +155,136 @@ Cont i Nothing -> return $ Cont (go (D.empty,0) i) Nothing else return $ Cont (go (dl',n') iter) Nothing where - s = S.concat $ L.toChunks $ fromWrap ws m = S.length s n' = n+m dl' = D.snoc dl s big = toWrap $ L.fromChunks [S.concat $ D.toList dl'] - + +bUFSIZ :: Int +bUFSIZ = 8192 + + +-- | Creates a buffer to be passed into 'unsafeBufferIterateeWithBuffer'. +mkIterateeBuffer :: IO (ForeignPtr CChar) +mkIterateeBuffer = mallocPlainForeignPtrBytes bUFSIZ + ------------------------------------------------------------------------------ +-- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer which +-- we'll re-use, meaning that if you hold on to any of the bytestring data +-- passed into your iteratee (instead of, let's say, shoving it right out a +-- socket) it'll get changed out from underneath you, breaking referential +-- transparency. Use with caution! +-- +-- The IORef returned can be set to True to "cancel" buffering. We added this +-- so that transfer-encoding: chunked (which needs its own buffer and therefore +-- doesn't need /its/ output buffered) can switch the outer buffer off. +-- +unsafeBufferIteratee :: Iteratee IO a -> IO (Iteratee IO a, IORef Bool) +unsafeBufferIteratee iter = do + buf <- mkIterateeBuffer + unsafeBufferIterateeWithBuffer buf iter + + +------------------------------------------------------------------------------ +-- | Buffers an iteratee, \"unsafely\". Here we use a fixed binary buffer which +-- we'll re-use, meaning that if you hold on to any of the bytestring data +-- passed into your iteratee (instead of, let's say, shoving it right out a +-- socket) it'll get changed out from underneath you, breaking referential +-- transparency. Use with caution! +-- +-- This version accepts a buffer created by 'mkIterateeBuffer'. +-- +-- The IORef returned can be set to True to "cancel" buffering. We added this +-- so that transfer-encoding: chunked (which needs its own buffer and therefore +-- doesn't need /its/ output buffered) can switch the outer buffer off. +-- +unsafeBufferIterateeWithBuffer :: ForeignPtr CChar + -> Iteratee IO a + -> IO (Iteratee IO a, IORef Bool) +unsafeBufferIterateeWithBuffer buf iteratee = do + esc <- newIORef False + return $! (start esc iteratee, esc) + + where + start esc iter = IterateeG $! checkRef esc iter + go bytesSoFar iter = + {-# SCC "unsafeBufferIteratee/go" #-} + IterateeG $! f bytesSoFar iter + + checkRef esc iter ch = do + quit <- readIORef esc + if quit + then runIter iter ch + else f 0 iter ch + + sendBuf n iter = + {-# SCC "unsafeBufferIteratee/sendBuf" #-} + withForeignPtr buf $ \ptr -> do + s <- S.unsafePackCStringLen (ptr, n) + runIter iter $ Chunk $ WrapBS s + + copy c@(EOF _) = c + copy (Chunk (WrapBS s)) = Chunk $ WrapBS $ S.copy s + + f _ iter ch@(EOF (Just _)) = runIter iter ch + + f !n iter ch@(EOF Nothing) = + if n == 0 + then runIter iter ch + else do + iterv <- sendBuf n iter + case iterv of + Done x rest -> return $ Done x $ copy rest + Cont i (Just e) -> return $ Cont i (Just e) + Cont i Nothing -> runIter i ch + + f !n iter (Chunk (WrapBS s)) = do + let m = S.length s + if m+n > bUFSIZ + then overflow n iter s m + else copyAndCont n iter s m + + copyAndCont n iter s m = + {-# SCC "unsafeBufferIteratee/copyAndCont" #-} do + S.unsafeUseAsCStringLen s $ \(p,sz) -> + withForeignPtr buf $ \bufp -> do + let b' = plusPtr bufp n + copyBytes b' p sz + + return $ Cont (go (n+m) iter) Nothing + + + overflow n iter s m = + {-# SCC "unsafeBufferIteratee/overflow" #-} do + let rest = bUFSIZ - n + let m2 = m - rest + let (s1,s2) = S.splitAt rest s + + S.unsafeUseAsCStringLen s1 $ \(p,_) -> + withForeignPtr buf $ \bufp -> do + let b' = plusPtr bufp n + copyBytes b' p rest + + iv <- sendBuf bUFSIZ iter + case iv of + Done x r -> return $ + Done x (copy r `mappend` (Chunk $ WrapBS s2)) + Cont i (Just e) -> return $ Cont i (Just e) + Cont i Nothing -> do + -- check the size of the remainder; if it's bigger than the + -- buffer size then just send it + if m2 >= bUFSIZ + then do + iv' <- runIter i (Chunk $ WrapBS s2) + case iv' of + Done x r -> return $ Done x (copy r) + Cont i' (Just e) -> return $ Cont i' (Just e) + Cont i' Nothing -> return $ Cont (go 0 i') Nothing + else copyAndCont 0 i s2 m2 + + +------------------------------------------------------------------------------ -- | Enumerates a strict bytestring. enumBS :: (Monad m) => ByteString -> Enumerator m a enumBS bs = enumPure1Chunk $ WrapBS bs @@ -156,9 +296,9 @@ enumLBS :: (Monad m) => L.ByteString -> Enumerator m a enumLBS lbs = el chunks where - el [] i = return i + el [] i = liftM liftI $ runIter i (EOF Nothing) el (x:xs) i = do - i' <- enumBS x i + i' <- liftM liftI $ runIter i (Chunk $ WrapBS x) el xs i' chunks = L.toChunks lbs @@ -251,11 +391,26 @@ ------------------------------------------------------------------------------ enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a) + +#ifdef PORTABLE + enumFile fp iter = do + h <- liftIO $ openBinaryFile fp ReadMode + i' <- enumHandle h iter + return $ do + x <- i' + liftIO (hClose h) + return x + +#else + +enumFile fp iter = do es <- (try $ liftM WrapBS $ unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8)) - + case es of (Left e) -> return $ throwErr $ Err $ "IO error" ++ show e (Right s) -> liftM liftI $ runIter iter $ Chunk s + +#endif diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs --- a/src/Snap/Starter.hs +++ b/src/Snap/Starter.hs @@ -1,14 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} module Main where ------------------------------------------------------------------------------ -import System -import System.Directory -import System.Console.GetOpt -import System.FilePath.Posix +import Data.List +import qualified Data.Text as T +import System +import System.Directory +import System.Console.GetOpt +import System.FilePath ------------------------------------------------------------------------------ +import Snap.StarterTH + ------------------------------------------------------------------------------ +-- Creates a value tDir :: ([String], [(String, String)]) +$(buildData "tDirDefault" "default") +$(buildData "tDirBareBones" "barebones") + + +------------------------------------------------------------------------------ usage :: String usage = unlines ["Usage:" @@ -26,6 +37,19 @@ deriving (Show, Eq) +setup :: String -> ([FilePath], [(String, String)]) -> IO () +setup projName tDir = do + mapM createDirectory (fst tDir) + mapM_ write (snd tDir) + where + write (f,c) = + if isSuffixOf "foo.cabal" f + then writeFile (projName++".cabal") (insertProjName $ T.pack c) + else writeFile f c + insertProjName c = T.unpack $ T.replace + (T.pack "projname") + (T.pack projName) c + ------------------------------------------------------------------------------ initProject :: [String] -> IO () initProject args = do @@ -59,9 +83,7 @@ cur <- getCurrentDirectory let dirs = splitDirectories cur projName = last dirs - writeFile (projName++".cabal") (cabalFile projName isBareBones) - createDirectory "src" - writeFile "src/Main.hs" (mainFile isBareBones) + setup projName (if isBareBones then tDirBareBones else tDirDefault) ------------------------------------------------------------------------------ @@ -72,69 +94,4 @@ ("init":args') -> initProject args' _ -> do putStrLn usage exitFailure - - ------------------------------------------------------------------------------- -cabalFile :: String -> Bool -> String -cabalFile projName isBareBones = unlines $ - ["Name: "++projName - ,"Version: 0.1" - ,"Synopsis: Project Synopsis Here" - ,"Description: Project Description Here" - ,"License: AllRightsReserved" - ,"Author: Author" - ,"Maintainer: maintainer@example.com" - ,"Stability: Experimental" - ,"Category: Web" - ,"Build-type: Simple" - ,"Cabal-version: >=1.2" - ,"" - ,"Executable "++projName - ," hs-source-dirs: src" - ," main-is: Main.hs" - ,"" - ," Build-depends:" - ," base >= 4," - ," haskell98," - ," monads-fd >= 0.1 && <0.2," - ," bytestring >= 0.9.1 && <0.10," - ," snap-core >= 0.2 && <0.3," - ," snap-server >= 0.2 && <0.3," - ] ++ (if isBareBones then [] else [" heist >= 0.1 && <0.2,"]) ++ - [" filepath >= 1.1 && <1.2" - ,"" - ," ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-imports" - ] - - ------------------------------------------------------------------------------- -mainFile :: Bool -> String -mainFile isBareBones = unlines $ - ["{-# LANGUAGE OverloadedStrings #-}" - ,"module Main where" - ,"" - ,"import System" - ,"import Control.Applicative" - ,"import Control.Monad.Trans" - ,"import Snap.Http.Server" - ,"import Snap.Types" - ,"import Snap.Util.FileServe" - ] ++ (if isBareBones then [] else ["import Text.Templating.Heist"]) ++ - ["" - ,"site :: Snap ()" - ,"site =" - ," ifTop (writeBS \"hello world\") <|>" - ," fileServe \".\"" - ,"" - ,"main :: IO ()" - ,"main = do" - ," args <- getArgs" - ," let port = case args of" - ," [] -> 8000" - ," p:_ -> read p" - ," httpServe \"*\" port \"myserver\"" - ," (Just \"access.log\")" - ," (Just \"error.log\")" - ," site" - ] diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,7 +24,7 @@ import Data.Maybe (fromMaybe) import System.Directory import System.FilePath -import System.Posix.Files +import System.PosixCompat.Files ------------------------------------------------------------------------------ import Snap.Types diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -300,7 +300,7 @@ coding = string "*" <|> takeWhile isCodingChar - isCodingChar c = isAlpha_ascii c || c == '-' + isCodingChar ch = isDigit ch || isAlpha_ascii ch || ch == '-' || ch == '_' float = takeWhile isDigit >> option () (char '.' >> takeWhile isDigit >> pure ()) diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -12,9 +12,12 @@ be evaluated but not printed. Default: False +Flag portable + Description: Compile in cross-platform mode. No platform-specific code or + optimizations such as C routines will be used. + Default: False + Executable testsuite - c-sources: ../cbits/timefuncs.c - include-dirs: ../cbits hs-source-dirs: ../src suite main-is: TestSuite.hs @@ -24,12 +27,18 @@ if flag(testsuite) cpp-options: -DDEBUG_TEST + if flag(portable) || os(windows) + cpp-options: -DPORTABLE + else + c-sources: ../cbits/timefuncs.c + include-dirs: ../cbits + build-depends: bytestring-mmap >= 0.2.1 && <0.3 + build-depends: QuickCheck >= 2, attoparsec >= 0.8.0.2 && < 0.9, base >= 4 && < 5, bytestring, - bytestring-mmap >= 0.2.1 && <0.3, bytestring-nums, cereal >= 0.2 && < 0.3, containers, @@ -49,7 +58,7 @@ text >= 0.7.1 && <0.8, time, transformers, - unix, + unix-compat, zlib ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded diff --git a/test/suite/Snap/Iteratee/Tests.hs b/test/suite/Snap/Iteratee/Tests.hs --- a/test/suite/Snap/Iteratee/Tests.hs +++ b/test/suite/Snap/Iteratee/Tests.hs @@ -11,6 +11,9 @@ import Control.Monad.Identity import qualified Data.ByteString as S import qualified Data.ByteString.Lazy.Char8 as L +import Data.Monoid +import Data.Iteratee.WrappedByteString +import Data.Word import Prelude hiding (drop, take) import Test.Framework import Test.Framework.Providers.QuickCheck2 @@ -19,6 +22,7 @@ import Test.QuickCheck.Monadic hiding (run) import Test.Framework.Providers.HUnit import qualified Test.HUnit as H +import System.IO.Unsafe import Snap.Iteratee import Snap.Test.Common () @@ -41,6 +45,11 @@ , testBuffer2 , testBuffer3 , testBuffer4 + , testUnsafeBuffer + , testUnsafeBuffer2 + , testUnsafeBuffer3 + , testUnsafeBuffer4 + , testUnsafeBuffer5 , testTakeExactly1 , testTakeExactly2 , testTakeExactly3 @@ -113,6 +122,93 @@ k <- liftQ $ enumErr "foo" j expectException $ run k + + +copyingStream2stream :: Iteratee IO (WrappedByteString Word8) +copyingStream2stream = IterateeG (step mempty) + where + step acc (Chunk (WrapBS ls)) + | S.null ls = return $ Cont (IterateeG (step acc)) Nothing + | otherwise = do + let !ls' = S.copy ls + let !bs' = WrapBS $! ls' + return $ Cont (IterateeG (step (acc `mappend` bs'))) + Nothing + + step acc str = return $ Done acc str + + +bufferAndRun :: Iteratee IO a -> L.ByteString -> IO a +bufferAndRun ii s = do + (i,_) <- unsafeBufferIteratee ii + iter <- enumLBS s i + run iter + + +testUnsafeBuffer :: Test +testUnsafeBuffer = testProperty "testUnsafeBuffer" $ + monadicIO $ forAllM arbitrary prop + where + prop s = do + pre $ s /= L.empty + x <- liftQ $ bufferAndRun copyingStream2stream s' + assert $ fromWrap x == s' + + where + s' = L.take 20000 $ L.cycle s + + +testUnsafeBuffer2 :: Test +testUnsafeBuffer2 = testCase "testUnsafeBuffer2" prop + where + prop = do + (i,_) <- unsafeBufferIteratee $ drop 4 >> copyingStream2stream + + s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap + H.assertEqual "s == 'efgh'" "efgh" s + + +testUnsafeBuffer3 :: Test +testUnsafeBuffer3 = testProperty "testUnsafeBuffer3" $ + monadicIO $ forAllM arbitrary prop + where + prop s = do + pre $ s /= L.empty + x <- liftQ $ bufferAndRun (ss >>= \x -> drop 1 >> return x) s' + + assert $ fromWrap x == (L.take 19999 s') + where + s' = L.take 20000 $ L.cycle s + ss = joinI $ take 19999 copyingStream2stream + + +testUnsafeBuffer4 :: Test +testUnsafeBuffer4 = testProperty "testUnsafeBuffer4" $ + monadicIO $ forAllM arbitrary prop + where + prop s = do + (i,_) <- liftQ $ + unsafeBufferIteratee (copyingStream2stream >> throwErr (Err "foo")) + i' <- liftQ $ enumLBS s i + expectException $ run i' + + (j,_) <- liftQ $ + unsafeBufferIteratee (throwErr (Err "foo") >> copyingStream2stream) + j' <- liftQ $ enumLBS s j + expectException $ run j' + + k <- liftQ $ enumErr "foo" j + expectException $ run k + + +testUnsafeBuffer5 :: Test +testUnsafeBuffer5 = testProperty "testUnsafeBuffer5" $ + monadicIO $ forAllM arbitrary prop + where + prop s = do + pre $ s /= L.empty + x <- liftQ $ bufferAndRun copyingStream2stream s + assert $ fromWrap x == s testTakeExactly1 :: Test