This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, 0.5 has been created
at 1f8a4b7e68eefc3c1848a4a198c128395d5030e7 (commit)
- Log -----------------------------------------------------------------
commit 1f8a4b7e68eefc3c1848a4a198c128395d5030e7
Merge: cb83715 af0a9be
Author: Gregory Collins <[email protected]>
Date: Sun Mar 20 15:51:06 2011 +0100
Merge branch 'master' of https://github.com/basvandijk/snap-core into 0.5
commit af0a9be5bdb3298a8a71ff962663c871ae7c9f3b
Author: Bas van Dijk <[email protected]>
Date: Wed Mar 9 21:00:44 2011 +0100
Use case-insensitive instead of CIByteString
diff --git a/snap-core.cabal b/snap-core.cabal
index 3b236d0..2a0e92f 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -109,7 +109,6 @@ Library
build-depends: bytestring-mmap >= 0.2.1 && <0.3
exposed-modules:
- Data.CIByteString,
Snap.Types,
Snap.Iteratee,
Snap.Internal.Debug,
@@ -134,6 +133,7 @@ Library
blaze-builder >= 0.2.1.4 && <0.3,
bytestring,
bytestring-nums,
+ case-insensitive >= 0.2 && < 0.3,
containers,
deepseq >= 1.1 && <1.2,
directory,
diff --git a/src/Data/CIByteString.hs b/src/Data/CIByteString.hs
deleted file mode 100644
index ce2b45b..0000000
--- a/src/Data/CIByteString.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-------------------------------------------------------------------------------
--- | "Data.CIByteString" is a module containing 'CIByteString', a wrapper for
--- 'ByteString' which provides case-insensitive (ASCII-wise) 'Ord' and 'Eq'
--- instances.
---
--- 'CIByteString' also has an 'IsString' instance, so if you use the
--- \"OverloadedStrings\" LANGUAGE pragma you can write case-insensitive string
--- literals, e.g.:
---
--- @
--- \> let a = \"Foo\" in
--- putStrLn $ (show $ unCI a) ++ \"==\\\"FoO\\\" is \" ++
--- show (a == \"FoO\")
--- \"Foo\"==\"FoO\" is True
--- @
-
-module Data.CIByteString
- ( CIByteString
- , toCI
- , unCI
- , ciToLower
- ) where
-
-
-------------------------------------------------------------------------------
--- for IsString instance
-import Data.ByteString.Char8 ()
-import Data.ByteString (ByteString)
-import Data.ByteString.Internal (c2w, w2c)
-import qualified Data.ByteString as S
-import Data.Char
-import Data.String
-
-
-------------------------------------------------------------------------------
--- | A case-insensitive newtype wrapper for 'ByteString'
-data CIByteString = CIByteString { unCI :: !ByteString
- , _lowercased :: !ByteString }
-
-
-------------------------------------------------------------------------------
-toCI :: ByteString -> CIByteString
-toCI s = CIByteString s t
- where
- t = lowercase s
-
-
-------------------------------------------------------------------------------
-ciToLower :: CIByteString -> ByteString
-ciToLower = _lowercased
-
-
-------------------------------------------------------------------------------
-instance Show CIByteString where
- show (CIByteString s _) = show s
-
-
-------------------------------------------------------------------------------
-lowercase :: ByteString -> ByteString
-lowercase = S.map (c2w . toLower . w2c)
-
-
-------------------------------------------------------------------------------
-instance Eq CIByteString where
- (CIByteString _ a) == (CIByteString _ b) = a == b
- (CIByteString _ a) /= (CIByteString _ b) = a /= b
-
-
-------------------------------------------------------------------------------
-instance Ord CIByteString where
- (CIByteString _ a) <= (CIByteString _ b) = a <= b
-
-
-------------------------------------------------------------------------------
-instance IsString CIByteString where
- fromString = toCI . fromString
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 120ada2..1d0d05d 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -57,7 +57,8 @@ import Foreign.C.String
#endif
------------------------------------------------------------------------------
-import Data.CIByteString
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
import Snap.Iteratee (Enumerator)
import qualified Snap.Iteratee as I
@@ -84,7 +85,7 @@ foreign import ccall unsafe "c_format_log_time"
------------------------------------------------------------------------------
-- | A type alias for a case-insensitive key-value mapping.
-type Headers = Map CIByteString [ByteString]
+type Headers = Map (CI ByteString) [ByteString]
------------------------------------------------------------------------------
@@ -102,33 +103,33 @@ class HasHeaders a where
-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header
-- with the same name already exists, the new value is appended to the headers
-- list.
-addHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a
+addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
addHeader k v = updateHeaders $ Map.insertWith' (++) k [v]
------------------------------------------------------------------------------
-- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with
-- the same name already exists, it is overwritten with the new value.
-setHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a
+setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
setHeader k v = updateHeaders $ Map.insert k [v]
------------------------------------------------------------------------------
-- | Gets all of the values for a given header.
-getHeaders :: (HasHeaders a) => CIByteString -> a -> Maybe [ByteString]
+getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]
getHeaders k a = Map.lookup k $ headers a
------------------------------------------------------------------------------
-- | Gets a header value out of a 'HasHeaders' datatype. If many headers came
-- in with the same name, they will be catenated together.
-getHeader :: (HasHeaders a) => CIByteString -> a -> Maybe ByteString
+getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString
getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a)
------------------------------------------------------------------------------
-- | Clears a header value from a 'HasHeaders' datatype.
-deleteHeader :: (HasHeaders a) => CIByteString -> a -> a
+deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a
deleteHeader k = updateHeaders $ Map.delete k
@@ -304,7 +305,7 @@ instance Show Request where
beginheaders =
"Headers:\n ========================================"
endheaders = " ========================================"
- hdrs' (a,b) = (B.unpack $ unCI a) ++ ": " ++ (show (map B.unpack b))
+ hdrs' (a,b) = (B.unpack $ CI.original a) ++ ": " ++ (show (map
B.unpack b))
hdrs = " " ++ (concat $ intersperse "\n " $
map hdrs' (Map.toAscList $ rqHeaders r))
contentlength = concat [ "content-length: "
diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs
index 0dc0744..bc0aab7 100644
--- a/src/Snap/Internal/Parsing.hs
+++ b/src/Snap/Internal/Parsing.hs
@@ -6,7 +6,8 @@ import Control.Arrow (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
-import Data.CIByteString
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive (CI)
import Data.Char (isAlpha, isAscii, isControl)
import Control.Applicative
import Control.Monad
@@ -185,21 +186,21 @@ trim = snd . S.span isSpace . fst . S.spanEnd isSpace
------------------------------------------------------------------------------
-pValueWithParameters :: Parser (ByteString, [(CIByteString, ByteString)])
+pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters = do
value <- liftM trim (pSpaces *> takeWhile (/= ';'))
params <- many pParam
- return (value, map (first toCI) params)
+ return (value, map (first CI.mk) params)
where
pParam = pSpaces *> char ';' *> pSpaces *> pParameter
------------------------------------------------------------------------------
pContentTypeWithParameters ::
- Parser (ByteString, [(CIByteString, ByteString)])
+ Parser (ByteString, [(CI ByteString, ByteString)])
pContentTypeWithParameters = do
value <- liftM trim (pSpaces *> takeWhile (not . isSep))
params <- many (pSpaces *> satisfy isSep *> pSpaces *> pParameter)
- return (value, map (first toCI) params)
+ return (value, map (first CI.mk) params)
where
isSep c = c == ';' || c == ','
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 7430aaf..e212cc3 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -19,7 +19,7 @@ import Control.Monad.State
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.CIByteString as CIB
+import Data.CaseInsensitive (CI)
import Data.Int
import Data.IORef
import Data.Maybe
@@ -634,7 +634,7 @@ ipHeaderFilter = ipHeaderFilter' "x-forwarded-for"
-- address can get it in a uniform manner. It has specifically limited
-- functionality to ensure that its transformation can be trusted,
-- when used correctly.
-ipHeaderFilter' :: MonadSnap m => CIB.CIByteString -> m ()
+ipHeaderFilter' :: MonadSnap m => CI ByteString -> m ()
ipHeaderFilter' header = do
headerContents <- getHeader header <$> getRequest
diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs
index 6199144..1d99ec9 100644
--- a/src/Snap/Util/FileUploads.hs
+++ b/src/Snap/Util/FileUploads.hs
@@ -72,10 +72,10 @@ import Control.Monad.Trans
import qualified Data.Attoparsec.Char8 as Atto
import Data.Attoparsec.Char8 hiding (many, Result(..))
import Data.Attoparsec.Enumerator
-import Data.CIByteString
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Internal (c2w)
+import qualified Data.CaseInsensitive as CI
import qualified Data.DList as D
import Data.Enumerator.Binary (iterHandle)
import Data.IORef
@@ -791,7 +791,7 @@ pHeadersWithSeparator = pHeaders <* crlf
toHeaders :: [(ByteString,ByteString)] -> Headers
toHeaders kvps = foldl' f Map.empty kvps'
where
- kvps' = map (first toCI . second (:[])) kvps
+ kvps' = map (first CI.mk . second (:[])) kvps
f m (k,v) = Map.insertWith' (flip (++)) k v m
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
index 17811cd..c453ce3 100755
--- a/test/runTestsAndCoverage.sh
+++ b/test/runTestsAndCoverage.sh
@@ -31,7 +31,6 @@ rm -Rf $DIR
mkdir -p $DIR
EXCLUDES='Main
-Data.CIByteString
Snap.Internal.Debug
Snap.Internal.Iteratee.Debug
Snap.Iteratee.Tests
commit cb83715e62bb93afecff80dded46805b3d049bc5
Merge: 1efe317 247f83e
Author: Gregory Collins <[email protected]>
Date: Sat Feb 26 18:24:39 2011 +0100
Merge branch 'master' of git.snapframework.com:snap-core
commit 1efe3171be6873afb7fd95ffb8f51add8ffc21a1
Author: Gregory Collins <[email protected]>
Date: Thu Feb 17 16:35:37 2011 -0800
Kill an unnecessary copy in BoyerMooreHorspool
diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
index 26ff7e6..871bfb9 100644
--- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
+++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
@@ -19,10 +19,10 @@ import qualified Data.Vector.Unboxed.Mutable as MV
import Prelude hiding (head, last)
-{-# INLINE debug #-}
-debug :: MonadIO m => String -> m ()
+--{-# INLINE debug #-}
+--debug :: MonadIO m => String -> m ()
--debug s = liftIO $ putStrLn s
-debug _ = return ()
+--debug _ = return ()
------------------------------------------------------------------------------
data MatchInfo = Match !ByteString
@@ -41,8 +41,8 @@ lookahead n = go id n
EL.head >>= maybe
(do
let !ls = S.concat $ dlist []
- debug $ "lookahead " ++ show n
- ++ " failing, returning " ++ show ls
+ -- debug $ "lookahead " ++ show n
+ -- ++ " failing, returning " ++ show ls
return $ Left ls)
(\x -> do
@@ -53,9 +53,9 @@ lookahead n = go id n
if r <= 0
then do
let !ls = S.concat $ d' []
- debug $ "lookahead " ++ show n
- ++ " successfully returning "
- ++ show ls
+ -- debug $ "lookahead " ++ show n
+ -- ++ " successfully returning "
+ -- ++ show ls
return $ Right $ ls
else go d' r)
{-# INLINE lookahead #-}
@@ -86,7 +86,7 @@ bmhEnumeratee :: (MonadIO m) =>
-> Step MatchInfo m a
-> Iteratee ByteString m (Step MatchInfo m a)
bmhEnumeratee needle _step = do
- debug $ "boyermoore: needle=" ++ show needle
+ -- debug $ "boyermoore: needle=" ++ show needle
cDone _step iter
where
{-# INLINE cDone #-}
@@ -99,14 +99,14 @@ bmhEnumeratee needle _step = do
(startSearch k)
finishAndEOF k xs = {-# SCC "finishAndEOF" #-} do
- debug $ "finishAndEOF, returning NoMatch for " ++ show xs
+ -- debug $ "finishAndEOF, returning NoMatch for " ++ show xs
step <- lift $ runIteratee $ k $
Chunks (map NoMatch $ filter (not . S.null) xs)
cDone step (\k' -> lift $ runIteratee $ k' EOF)
startSearch !k !haystack = {-# SCC "startSearch" #-} do
- debug $ "startsearch: " ++ show haystack
+ -- debug $ "startsearch: " ++ show haystack
if S.null haystack
then lookahead nlen >>=
either (\s -> finishAndEOF k [s])
@@ -119,8 +119,8 @@ bmhEnumeratee needle _step = do
| hend >= hlen = crossBound hidx
| otherwise = {-# SCC "go" #-} do
let match = matches needle 0 last haystack hidx hend
- debug $ "go " ++ show hidx ++ ", hend=" ++ show hend
- ++ ", match was " ++ show match
+ -- debug $ "go " ++ show hidx ++ ", hend=" ++ show hend
+ -- ++ ", match was " ++ show match
if match
then {-# SCC "go/match" #-} do
let !nomatch = S.take hidx haystack
@@ -140,68 +140,73 @@ bmhEnumeratee needle _step = do
go (hidx + skip)
where
!hend = hidx + nlen - 1
+
+ mkCoeff hidx = let !ll = hlen - hidx
+ !nm = nlen - ll
+ in (ll,nm)
- crossBound !hidx = {-# SCC "crossBound" #-} do
- let !leftLen = hlen - hidx
- let !needMore = nlen - leftLen
- debug $ "crossbound " ++ show hidx ++ ", leftlen=" ++ show leftLen
- ++ ", needmore=" ++ show needMore
+ crossBound !hidx0 = {-# SCC "crossBound" #-} do
+ let (!leftLen, needMore) = mkCoeff hidx0
+
lookahead needMore >>=
- either
- (\s -> finishAndEOF k [haystack, s])
- (\nextHaystack -> do
- let match1 = matches needle leftLen last
- nextHaystack 0 (needMore-1)
- let match2 = matches needle 0 (leftLen-1)
- haystack hidx (hlen-1)
-
- debug $ "crossbound match1=" ++ show match1
- ++ " match2=" ++ show match2
-
- if match1 && match2
- then {-# SCC "crossBound/match" #-} do
- let !nomatch = S.take hidx haystack
- let !aftermatch = S.drop needMore nextHaystack
-
- -- FIXME: merge this code w/ above
- step <- if not $ S.null nomatch
- then lift $ runIteratee $ k $
- Chunks [NoMatch nomatch]
- else return $ Continue k
-
- debug $ "matching"
- cDone step $ \k' -> do
- step' <- lift $ runIteratee $ k' $
- Chunks [Match needle]
- cDone step' $ \k'' ->
- startSearch k'' aftermatch
-
- else {-# SCC "crossBound/nomatch" #-} do
- let c = S.unsafeIndex nextHaystack $ needMore-1
- let p = V.unsafeIndex table (fromEnum c)
-
- debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen
- if p < leftLen
+ either (\s -> finishAndEOF k [haystack, s])
+ (runNext hidx0 leftLen needMore)
+ where
+ runNext !hidx !leftLen !needMore !nextHaystack = do
+ let match1 = matches needle leftLen last
+ nextHaystack 0 (needMore-1)
+ let match2 = matches needle 0 (leftLen-1)
+ haystack hidx (hlen-1)
+
+ -- debug $ "crossbound match1=" ++ show match1
+ -- ++ " match2=" ++ show match2
+
+ if match1 && match2
+ then {-# SCC "crossBound/match" #-} do
+ let !nomatch = S.take hidx haystack
+ let !aftermatch = S.drop needMore nextHaystack
+
+ -- FIXME: merge this code w/ above
+ step <- if not $ S.null nomatch
+ then lift $ runIteratee $ k $
+ Chunks [NoMatch nomatch]
+ else return $ Continue k
+
+ -- debug $ "matching"
+ cDone step $ \k' -> do
+ step' <- lift $ runIteratee $ k' $
+ Chunks [Match needle]
+ cDone step' $ \k'' ->
+ startSearch k'' aftermatch
+
+ else {-# SCC "crossBound/nomatch" #-} do
+ let c = S.unsafeIndex nextHaystack $ needMore-1
+ let p = V.unsafeIndex table (fromEnum c)
+
+ -- debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen
+ if p < leftLen
+ then do
+ let !hidx' = hidx+p
+ let (!leftLen', needMore') = mkCoeff hidx'
+ let !nextlen = S.length nextHaystack
+ if (nextlen < needMore')
then do
- let (!nomatch, !crumb) = S.splitAt (hidx + p)
- haystack
- let !rest = S.append crumb nextHaystack
- step <- lift $ runIteratee $ k $
- Chunks $ map NoMatch $
- filter (not . S.null) [nomatch]
-
- cDone step $ flip startSearch rest
-
- else do
- let sidx = p - leftLen
- let (!crumb, !rest) = S.splitAt sidx nextHaystack
- step <- lift $ runIteratee $ k $
- Chunks $ map NoMatch $
- filter (not . S.null) [haystack, crumb]
-
- cDone step $ flip startSearch rest
- )
-
+ -- this should be impossibly rare
+ lookahead (needMore' - nextlen) >>=
+ either (\s -> finishAndEOF k [ haystack
+ , nextHaystack
+ , s ])
+ (\s -> runNext hidx' leftLen' needMore' $
+ S.append nextHaystack s)
+ else runNext hidx' leftLen' needMore' nextHaystack
+ else do
+ let sidx = p - leftLen
+ let (!crumb, !rest) = S.splitAt sidx nextHaystack
+ step <- lift $ runIteratee $ k $
+ Chunks $ map NoMatch $
+ filter (not . S.null) [haystack, crumb]
+
+ cDone step $ flip startSearch rest
!nlen = S.length needle
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 0dceeb6..89b7148 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -591,7 +591,7 @@ enumFilePartial :: FilePath
enumFile = _enumFile
enumFilePartial fp rng@(start,end) iter = do
- when (end < start) $ throw InvalidRangeException
+ when (end < start) $ throwError InvalidRangeException
_enumFilePartial fp rng iter
#else
@@ -718,7 +718,7 @@ killIfTooSlow !bump !minRate !minSeconds' !inputIter = do
proc !nb (Continue !k) = continue $ cont nb k
proc _ !z = returnI z
- cont !nBytesRead !k EOF = k EOF
+ cont _ !k EOF = k EOF
cont !nBytesRead !k !stream = do
let !slen = toEnum $ streamLength stream
now <- liftIO getTime
@@ -726,7 +726,7 @@ killIfTooSlow !bump !minRate !minSeconds' !inputIter = do
let !newBytes = nBytesRead + slen
when (delta > minSeconds+1 &&
fromIntegral newBytes / (delta-minSeconds) < minRate) $
- throw RateTooSlowException
+ throwError RateTooSlowException
-- otherwise bump the timeout and continue running the iteratee
!_ <- lift bump
commit 5877748c41e6302dc2c3911e4179eca00b5fe9e3
Author: Gregory Collins <[email protected]>
Date: Thu Feb 17 08:52:19 2011 -0800
Kill bytestring bounds checking in BoyerMooreHorspool
diff --git a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
index 1a2d89e..26ff7e6 100644
--- a/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
+++ b/src/Snap/Internal/Iteratee/BoyerMooreHorspool.hs
@@ -73,8 +73,8 @@ matches !needle !nstart !nend' !haystack !hstart !hend' =
go !nend !hend =
if nend < nstart || hend < hstart
then True
- else let !nc = S.index needle nend -- FIXME: use unsafeIndex
- !hc = S.index haystack hend
+ else let !nc = S.unsafeIndex needle nend
+ !hc = S.unsafeIndex haystack hend
in if nc /= hc
then False
else go (nend-1) (hend-1)
@@ -135,7 +135,7 @@ bmhEnumeratee needle _step = do
cDone step' $ \k'' -> startSearch k'' aftermatch
else {-# SCC "go/nomatch" #-} do
-- skip ahead
- let c = S.index haystack hend
+ let c = S.unsafeIndex haystack hend
let !skip = V.unsafeIndex table $ fromEnum c
go (hidx + skip)
where
@@ -177,7 +177,7 @@ bmhEnumeratee needle _step = do
startSearch k'' aftermatch
else {-# SCC "crossBound/nomatch" #-} do
- let c = S.index nextHaystack $ needMore-1
+ let c = S.unsafeIndex nextHaystack $ needMore-1
let p = V.unsafeIndex table (fromEnum c)
debug $ "p was " ++ show p ++ ", ll=" ++ show leftLen
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
