snap-core 0.4.3 → 0.5.0
raw patch · 10 files changed
+86/−101 lines, 10 filesdep +case-insensitivedep ~base
Dependencies added: case-insensitive
Dependency ranges changed: base
Files
- snap-core.cabal +4/−3
- src/Data/CIByteString.hs +0/−79
- src/Snap/Internal/Http/Types.hs +9/−8
- src/Snap/Internal/Parsing.hs +6/−5
- src/Snap/Internal/Types.hs +26/−3
- src/Snap/Types.hs +2/−0
- src/Snap/Util/FileUploads.hs +2/−2
- src/Snap/Util/Readable.hs +36/−0
- test/runTestsAndCoverage.sh +0/−1
- test/snap-core-testsuite.cabal +1/−0
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.4.3+version: 0.5.0 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -108,7 +108,6 @@ build-depends: bytestring-mmap >= 0.2.2 && <0.3 exposed-modules:- Data.CIByteString, Snap.Types, Snap.Iteratee, Snap.Internal.Debug,@@ -117,7 +116,8 @@ Snap.Internal.Parsing, Snap.Util.FileServe, Snap.Util.FileUploads,- Snap.Util.GZip+ Snap.Util.GZip,+ Snap.Util.Readable other-modules: Snap.Internal.Instances,@@ -133,6 +133,7 @@ blaze-builder >= 0.2.1.4 && <0.4, bytestring, bytestring-nums,+ case-insensitive >= 0.2 && < 0.3, containers, deepseq >= 1.1 && <1.2, directory,
− src/Data/CIByteString.hs
@@ -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
src/Snap/Internal/Http/Types.hs view
@@ -57,7 +57,8 @@ #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 @@ ------------------------------------------------------------------------------ -- | 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 @@ -- | 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 @@ -303,7 +304,7 @@ 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: "
src/Snap/Internal/Parsing.hs view
@@ -6,7 +6,8 @@ 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 @@ -------------------------------------------------------------------------------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 == ','
src/Snap/Internal/Types.hs view
@@ -19,7 +19,7 @@ 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@@ -32,8 +32,9 @@ ------------------------------------------------------------------ import Snap.Internal.Http.Types-import Snap.Iteratee import Snap.Internal.Iteratee.Debug+import Snap.Util.Readable+import Snap.Iteratee ------------------------------------------------------------------------------@@ -422,6 +423,19 @@ ------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only when the first path component is+-- successfully parsed as the argument to the supplied handler function.+pathArg :: (Readable a, MonadSnap m)+ => (a -> m b)+ -> m b+pathArg f = do+ req <- getRequest+ let (p,_) = S.break (=='/') (rqPathInfo req)+ a <- fromBS p+ localRequest (updateContextPath $ S.length p) (f a)+ ++------------------------------------------------------------------------------ -- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. ifTop :: MonadSnap m => m a -> m a ifTop = path ""@@ -677,7 +691,7 @@ -- 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 @@ -814,6 +828,15 @@ -> m (Maybe Cookie) getCookie name = withRequest $ return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies+++------------------------------------------------------------------------------+-- | Gets the HTTP 'Cookie' with the specified name and decodes it. If the+-- decoding fails, the handler calls pass.+readCookie :: (MonadSnap m, Readable a)+ => ByteString+ -> m a+readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name ------------------------------------------------------------------------------
src/Snap/Types.hs view
@@ -22,6 +22,7 @@ , method , methods , path+ , pathArg , dir , ifTop , route@@ -103,6 +104,7 @@ , deleteResponseCookie , modifyResponseCookie , getCookie+ , readCookie , setContentLength , clearContentLength , redirect
src/Snap/Util/FileUploads.hs view
@@ -72,10 +72,10 @@ 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@@ -789,7 +789,7 @@ 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
+ src/Snap/Util/Readable.hs view
@@ -0,0 +1,36 @@+module Snap.Util.Readable+ ( Readable(..)+ ) where++------------------------------------------------------------------------------+import Data.ByteString.Char8 (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Text.Read+++------------------------------------------------------------------------------+-- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.+class Readable a where+ fromBS :: Monad m => ByteString -> m a+++------------------------------------------------------------------------------+-- | Fails if the input wasn't parsed completely.+checkComplete :: Monad m => (t, Text) -> m t+checkComplete (a,rest)+ | T.null rest = return a+ | otherwise = fail "Readable: could not parse completely"+++instance Readable ByteString where+ fromBS = return+instance Readable Text where+ fromBS = return . decodeUtf8+instance Readable Int where+ fromBS = either fail checkComplete . decimal . decodeUtf8+instance Readable Integer where+ fromBS = either fail checkComplete . decimal . decodeUtf8+instance Readable Double where+ fromBS = either fail checkComplete . double . decodeUtf8
test/runTestsAndCoverage.sh view
@@ -31,7 +31,6 @@ mkdir -p $DIR EXCLUDES='Main-Data.CIByteString Snap.Internal.Debug Snap.Internal.Iteratee.Debug Snap.Iteratee.Tests
test/snap-core-testsuite.cabal view
@@ -28,6 +28,7 @@ blaze-builder >= 0.2.1.4 && <0.4, bytestring, bytestring-nums,+ case-insensitive >= 0.2 && < 0.3, cereal == 0.3.*, containers, deepseq >= 1.1 && <1.2,