packages feed

snap-predicates 0.2.0 → 0.3.0

raw patch · 33 files changed

+1757/−1479 lines, 33 files

Files

snap-predicates.cabal view
@@ -1,5 +1,5 @@ name:                snap-predicates-version:             0.2.0+version:             0.3.0 synopsis:            Declarative routing for Snap. license:             MIT license-file:        LICENSE@@ -25,23 +25,24 @@     ghc-prof-options: -prof -auto-all      exposed-modules:-        Data.ByteString.Readable-      , Data.Predicate+        Data.Predicate       , Data.Predicate.Env-      , Snap.Predicates-      , Snap.Predicates.Accept-      , Snap.Predicates.Error-      , Snap.Predicates.Params-      , Snap.Predicates.Content-      , Snap.Predicates.MediaTypes-      , Snap.Predicates.Tutorial-      , Snap.Routes+      , Snap.Predicate+      , Snap.Predicate.Accept+      , Snap.Predicate.Error+      , Snap.Predicate.Param+      , Snap.Predicate.Header+      , Snap.Predicate.Content+      , Snap.Predicate.MediaType+      , Snap.Predicate.Tutorial+      , Snap.Predicate.Types+      , Snap.Route      other-modules:-        Snap.Predicates.Internal-        Snap.Predicates.MediaTypes.Internal-      , Snap.Predicates.Parsers.Accept-      , Snap.Predicates.Parsers.Shared+        Snap.Predicate.Internal+        Snap.Predicate.MediaType.Internal+      , Snap.Predicate.Parser.Accept+      , Snap.Predicate.Parser.Shared      build-depends:         base             >= 4   && < 5@@ -64,8 +65,8 @@      other-modules:         Tests.Data.Predicate-      , Tests.Snap.Predicates-      , Tests.Snap.Routes+      , Tests.Snap.Predicate+      , Tests.Snap.Route      build-depends:         base             >= 4   && < 5
− src/Data/ByteString/Readable.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}-module Data.ByteString.Readable (Readable (..)) where--import Control.Applicative-import Data.ByteString (ByteString)-import Data.Monoid-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8', encodeUtf8)-import Data.Text.Read-import qualified Data.Text as T-import qualified Data.ByteString as S---- | The type-class 'Readable' is used to convert 'ByteString' values to--- values of other types. Most instances assume the 'ByteString' is--- encoded via UTF-8.------ Minimal complete instance definition is given by 'readByteString'.-class Readable a where-    -- | Parse the given 'ByteString' into a typed value and also return-    -- the unconsumed bytes. In case of error, provide an error message.-    readByteString :: ByteString -> Either ByteString (a, ByteString)--    -- | Parse the given 'ByteString' into a list of typed values and-    -- return the unconsumed bytes. In case of error, provide an error-    -- message. Instances can use this function to express their way of-    -- reading lists of values. The default implementation parses-    -- comma-separated values (also accepting interspersed spaces).-    readByteStringList :: ByteString -> Either ByteString ([a], ByteString)-    readByteStringList s = parseList ([], s)--    -- | Either turn the given 'ByteString' into a typed value or an error-    -- message. This function also checks, that all input bytes have been-    -- consumed or else it will fail.-    fromByteString :: ByteString -> Either ByteString a-    fromByteString s = do-        (v, s') <- readByteString s-        if S.null s'-            then Right v-            else Left ("unconsumed bytes: '" <> s' <> "'.")--parseList :: Readable a => ([a], ByteString) -> Either ByteString ([a], ByteString)-parseList (!acc, !s)-    | S.null s  = return (reverse acc, s)-    | otherwise = do-        (a, s') <- readByteString s-        parseList (a:acc, S.dropWhile noise s')-  where-    noise w = w `elem` [0x20, 0x2C] -- [' ', ',']--instance Readable a => Readable (Maybe a) where-    readByteString s =-        case readByteString s of-            Left       _  -> Right (Nothing, "")-            Right (v, s') -> Right (Just v, s')--instance Readable a => Readable [a] where-    readByteString = readByteStringList--instance Readable ByteString where-    readByteString = Right . (, "")--instance Readable Text where-    readByteString s = (, "") <$> mapLeft (decodeUtf8' s)--instance Readable Char where-    readByteString s = do-        t <- mapLeft (decodeUtf8' s)-        return (T.head t, encodeUtf8 (T.tail t))--    readByteStringList s = (, "") . T.unpack <$> mapLeft (decodeUtf8' s)--instance Readable Double where-    readByteString = parse (signed double)--instance Readable Int where-    readByteString = parse (signed decimal)--mapLeft :: Show e => Either e a -> Either ByteString a-mapLeft (Left  s) = Left (encodeUtf8 . T.pack . show $ s)-mapLeft (Right x) = Right x--parse :: (Text -> Either String (a, Text)) -> ByteString -> Either ByteString (a, ByteString)-parse f s = do-    t <- mapLeft (decodeUtf8' s)-    case f t of-        Left       e  -> Left (encodeUtf8 (T.pack e))-        Right (v, t') -> return (v, encodeUtf8 t')
+ src/Snap/Predicate.hs view
@@ -0,0 +1,7 @@+module Snap.Predicate (module M) where++import Snap.Predicate.Error     as M+import Snap.Predicate.Accept    as M+import Snap.Predicate.Content   as M+import Snap.Predicate.Param     as M+import Snap.Predicate.Header    as M
+ src/Snap/Predicate/Accept.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicate.Accept+  ( Accept (..)+  , module Snap.Predicate.MediaType+  )+where++import Data.Monoid hiding (All)+import Data.String+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicate.Error+import Snap.Predicate.MediaType+import Snap.Predicate.MediaType.Internal+import qualified Data.Predicate.Env as E++-- | A 'Predicate' against the 'Request's \"Accept\" header.+data Accept t s = Accept t s deriving Eq++instance (MType t, MSubType s) => Predicate (Accept t s) Request where+    type FVal (Accept t s) = Error+    type TVal (Accept t s) = MediaType t s+    apply (Accept x y) r   = do+        mtypes <- E.lookup "accept" >>= maybe (readMediaTypes "accept" r) return+        if null mtypes+            then return (T 0 (MediaType x y 1.0 []))+            else case mediaType True x y mtypes of+               Just m  -> return (T (1.0 - _quality m) m)+               Nothing -> return (F (err 406 message))+      where+        message = "Expected 'Accept: "+                    <> fromString (show x)+                    <> "/"+                    <> fromString (show y)+                    <> "'."++instance (Show t, Show s) => Show (Accept t s) where+    show (Accept t s) = "Accept: " ++ show t ++ "/" ++ show s
+ src/Snap/Predicate/Content.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicate.Content+  ( Content+  , ContentType (..)+  , module Snap.Predicate.MediaType+  )+where++import Data.Monoid hiding (All)+import Data.String+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicate.Error+import Snap.Predicate.MediaType+import Snap.Predicate.MediaType.Internal+import qualified Data.Predicate.Env as E++type Content x y = MediaType x y++-- | A 'Predicate' against the 'Request's \"Content-Type\" header.+data ContentType t s = ContentType t s deriving Eq++instance (MType t, MSubType s) => Predicate (ContentType t s) Request where+    type FVal (ContentType t s) = Error+    type TVal (ContentType t s) = MediaType t s+    apply (ContentType x y) r   = do+        mtypes <- E.lookup "content-type" >>= maybe (readMediaTypes "content-type" r) return+        case mediaType False x y mtypes of+               Just m  -> return (T 0 m)+               Nothing -> return (F (err 415 message))+      where+        message = "Expected 'Content-Type: "+                    <> fromString (show x)+                    <> "/"+                    <> fromString (show y)+                    <> "'."++instance (Show t, Show s) => Show (ContentType t s) where+    show (ContentType t s) = "ContentType: " ++ show t ++ "/" ++ show s
+ src/Snap/Predicate/Error.hs view
@@ -0,0 +1,15 @@+module Snap.Predicate.Error where++import Data.ByteString (ByteString)+import Data.Word++-- | The error type used as 'F' meta-data in all snap predicates.+data Error = Error+  { _status  :: !Word               -- ^ (HTTP) status code+  , _message :: !(Maybe ByteString) -- ^ optional status message+  } deriving (Eq, Show)++-- | Convenience function to construct 'Error' values from+-- status code and status message.+err :: Word -> ByteString -> Error+err s = Error s . Just
+ src/Snap/Predicate/Header.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicate.Header+  ( Header (..)+  , Hdr    (..)+  , HdrOpt (..)+  , HdrDef (..)+  , HasHdr (..)+  )+where++import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import Data.Maybe+import Data.Monoid+import Data.Typeable+import Data.Predicate+import Snap.Core hiding (headers)+import Snap.Predicate.Error+import Snap.Predicate.Internal+import Snap.Util.Readable++-- | The most generic request header predicate provided.+-- It will get all request header values of '_name' and pass them on to+-- the conversion function '_read', which might either yield an error+-- message or a value. If the header is not present, an optional default may be+-- returned instead, if nothing is provided, the error message will be used+-- when construction the 400 status.+data Header a = Header+  { _hdrName    :: !ByteString                         -- ^ request header name+  , _hdrRead    :: [ByteString] -> Either ByteString a -- ^ conversion function+  , _hdrDefault :: !(Maybe a)                          -- ^ (optional) default value+  }++instance Typeable a => Predicate (Header a) Request where+    type FVal (Header a)     = Error+    type TVal (Header a)     = a+    apply (Header nme f def) =+        rqApply RqPred+          { _rqName      = nme+          , _rqRead      = f+          , _rqDef       = def+          , _rqCachePref = "header:"+          , _rqVals      = headers nme+          , _rqError     = Just $ err 400 ("Missing header '" <> nme <> "'.")+          }++instance Show (Header a) where+    show p = "Header: " ++ show (_hdrName p)++-- | Specialisation of 'Header' which returns the first request+-- header value which could be converted to the target type.+-- Relies on 'Readable' type-class for the actual conversion.+data Hdr a = Hdr ByteString++instance (Typeable a, Readable a) => Predicate (Hdr a) Request where+    type FVal (Hdr a) = Error+    type TVal (Hdr a) = a+    apply (Hdr x)     = apply (Header x readValues Nothing)++instance Show (Hdr a) where+    show (Hdr x) = "Hdr: " ++ show x++-- | Specialisation of 'Header' which returns the first request+-- header value which could be converted to the target type.+-- If the header is not present, the provided default will be used.+-- Relies on 'Readable' type-class for the actual conversion.+data HdrDef a = HdrDef ByteString a++instance (Typeable a, Readable a) => Predicate (HdrDef a) Request where+    type FVal (HdrDef a) = Error+    type TVal (HdrDef a) = a+    apply (HdrDef x d)   = apply (Header x readValues (Just d))++instance Show a => Show (HdrDef a) where+    show (HdrDef x d) = "HdrDef: " ++ show x ++ " [" ++ show d ++ "]"++-- | Predicate which returns the first request header which could be+-- converted to the target type wrapped in a Maybe.+-- If the header is not present, 'Nothing' will be returned.+-- Relies on 'Readable' type-class for the actual conversion.+data HdrOpt a = HdrOpt ByteString++instance (Typeable a, Readable a) => Predicate (HdrOpt a) Request where+    type FVal (HdrOpt a) = Error+    type TVal (HdrOpt a) = Maybe a+    apply (HdrOpt x)     =+        rqApplyMaybe RqPred+          { _rqName      = x+          , _rqRead      = readValues+          , _rqDef       = Nothing+          , _rqCachePref = "headeropt:"+          , _rqVals      = headers x+          , _rqError     = Nothing+          }++instance Show (HdrOpt a) where+    show (HdrOpt x) = "HdrOpt: " ++ show x++-- | Predicate which is true if the request has a header with the+-- given name.+data HasHdr = HasHdr ByteString++instance Predicate HasHdr Request where+    type FVal HasHdr   = Error+    type TVal HasHdr   = ()+    apply (HasHdr x) r = return $+        if isJust (getHeaders (mk x) r)+            then T 0 ()+            else F (err 400 ("Missing header '" <> x <> "'."))++instance Show HasHdr where+    show (HasHdr x) = "HasHdr: " ++ show x
+ src/Snap/Predicate/Internal.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+module Snap.Predicate.Internal+  ( RqPred (..)+  , headers+  , params+  , cookies+  , safeHead+  , readValues+  , rqApply+  , rqApplyMaybe+  , key+  )+where++import Control.Monad.State.Class+import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import Data.Maybe+import Data.Monoid+import Data.Predicate+import Data.Predicate.Env (Env)+import Data.String+import Data.Typeable+import Snap.Core hiding (headers)+import Snap.Predicate.Error+import Snap.Util.Readable++import qualified Data.Predicate.Env as E+import qualified Data.Map.Strict    as M++headers :: ByteString -> Request -> [ByteString]+headers name = fromMaybe [] . getHeaders (mk name)++params :: ByteString -> Request -> [ByteString]+params name = fromMaybe [] . M.lookup name . rqParams++cookies :: ByteString -> Request -> [Cookie]+cookies name rq = filter ((name ==) . cookieName) (rqCookies rq)++safeHead :: [a] -> Maybe a+safeHead []    = Nothing+safeHead (h:_) = Just h++readValues :: Readable a => [ByteString] -> Either ByteString a+readValues vs =+    case listToMaybe . catMaybes $ map fromBS vs of+        Nothing -> Left "no read"+        Just x  -> Right x++data RqPred a = RqPred+  { _rqName      :: !ByteString+  , _rqRead      :: [ByteString] -> Either ByteString a+  , _rqDef       :: !(Maybe a)+  , _rqCachePref :: !ByteString+  , _rqVals      :: Request -> [ByteString]+  , _rqError     :: !(Maybe Error)+  }++rqApply :: (Typeable a, MonadState m, StateType m ~ Env)+        => RqPred a -> Request -> m (Boolean Error a)+rqApply p r =+    let k = key (_rqCachePref p) (_rqName p) (_rqDef p)+    in E.lookup k >>= maybe (work k) result+  where+    work k = case _rqVals p r of+        [] -> return $ maybe (F (fromMaybe defErr (_rqError p))) (T 0) (_rqDef p)+        vs -> do+            let v = _rqRead p vs+            E.insert k v+            result v++    result = return . either (F . err 400) (T 0)+    defErr = Error 400 Nothing++rqApplyMaybe :: (Typeable a, MonadState m, StateType m ~ Env)+             => RqPred a -> Request -> m (Boolean Error (Maybe a))+rqApplyMaybe p r =+    let n = Nothing :: Typeable a => Maybe a+        k = key (_rqCachePref p) (_rqName p) n+    in E.lookup k >>= maybe (work k n) result+  where+    work k n = case _rqVals p r of+        [] -> return (T 0 n)+        vs -> do+            let v = _rqRead p vs+            E.insert k v+            result v++    result = return . either (F . err 400) (T 0 . Just)++key :: (Typeable a, IsString m, Monoid m) => m -> m -> a -> m+key prefix name def = prefix <> name <> ":" <> (fromString . show . typeOf $ def)
+ src/Snap/Predicate/MediaType.hs view
@@ -0,0 +1,490 @@+{-# LANGUAGE OverloadedStrings #-}+module Snap.Predicate.MediaType+  ( -- * Types+    MType (..)+  , MSubType (..)+  , MediaType (..)++  -- * Media-Types+  , Type (..)+  , All (..)+  , Application (..)+  , Audio (..)+  , Image (..)+  , Message (..)+  , Multipart (..)+  , Text (..)+  , Video (..)++  -- * Media-Sub-Types+  , SubType (..)+  , AtomXml (..)+  , Css (..)+  , Csv (..)+  , Encrypted (..)+  , FormData (..)+  , FormUrlEncoded (..)+  , Gif (..)+  , Gzip (..)+  , Javascript (..)+  , Jpeg (..)+  , Json (..)+  , Mixed (..)+  , Mp4 (..)+  , Mpeg (..)+  , OctetStream (..)+  , Ogg (..)+  , Partial (..)+  , Pkcs12 (..)+  , Pkcs7Cert (..)+  , Pkcs7Sig (..)+  , Pkcs7Mime (..)+  , Pkcs7CertRqRs (..)+  , Plain (..)+  , Png (..)+  , Postscript (..)+  , Protobuf (..)+  , RdfXml (..)+  , RssXml (..)+  , Tar (..)+  , Tiff (..)+  , Thrift (..)+  , Vorbis (..)+  , Webm (..)+  , XhtmlXml (..)+  , Xml (..)+  )+where++import Data.ByteString (ByteString)++-- | Type-class for converting a 'ByteString' to a media-type.+class (Show a, Eq a) => MType a where+    toType :: a -> ByteString -> Maybe a++-- | Type-class for converting a 'ByteString' to a media-subtype.+class (Show a, Eq a) => MSubType a where+    toSubType :: a -> ByteString -> Maybe a++-- | The Media-type representation.+data MediaType t s = MediaType+  { _type    :: !t+  , _subtype :: !s+  , _quality :: !Double+  , _params  :: ![(ByteString, ByteString)]+  } deriving (Eq, Show)++-- Media-Types:++-- | Generic media-type.+data Type = Type ByteString deriving Eq++instance MType Type where+    toType o@(Type t) s = if t == s then Just o else Nothing++instance Show Type where+    show (Type t) = show t++data Application = Application deriving Eq++instance MType Application where+    toType _ "application" = Just Application+    toType _ _             = Nothing++instance Show Application where+    show _ = "application"++data Audio = Audio deriving Eq++instance MType Audio where+    toType _ "audio" = Just Audio+    toType _ _       = Nothing++instance Show Audio where+    show _ = "audio"++data Image = Image deriving Eq++instance MType Image where+    toType _ "image" = Just Image+    toType _ _       = Nothing++instance Show Image where+    show _ = "image"++data Message = Message deriving Eq++instance MType Message where+    toType _ "message" = Just Message+    toType _ _         = Nothing++instance Show Message where+    show _ = "message"++data Multipart = Multipart deriving Eq++instance MType Multipart where+    toType _ "multipart" = Just Multipart+    toType _ _           = Nothing++instance Show Multipart where+    show _ = "multipart"++data Text = Text deriving Eq++instance MType Text where+    toType _ "text" = Just Text+    toType _ _      = Nothing++instance Show Text where+    show _ = "text"++data Video = Video deriving Eq++instance MType Video where+    toType _ "video" = Just Video+    toType _ _       = Nothing++instance Show Video where+    show _ = "video"++-- Media-Subtypes:++-- | Generic media-subtype.+data SubType = SubType ByteString deriving Eq++instance MSubType SubType where+    toSubType o@(SubType t) s = if t == s then Just o else Nothing++instance Show SubType where+    show (SubType t) = show t++data AtomXml = AtomXml deriving Eq++instance MSubType AtomXml where+    toSubType _ "atom+xml" = Just AtomXml+    toSubType _ _          = Nothing++instance Show AtomXml where+    show _ = "atom+xml"++data Css = Css deriving Eq++instance MSubType Css where+    toSubType _ "css" = Just Css+    toSubType _ _     = Nothing++instance Show Css where+    show _ = "css"++data Csv = Csv deriving Eq++instance MSubType Csv where+    toSubType _ "csv" = Just Csv+    toSubType _ _     = Nothing++instance Show Csv where+    show _ = "csv"++data Encrypted = Encrypted deriving Eq++instance MSubType Encrypted where+    toSubType _ "encrypted" = Just Encrypted+    toSubType _ _           = Nothing++instance Show Encrypted where+    show _ = "encrypted"++data FormData = FormData deriving Eq++instance MSubType FormData where+    toSubType _ "form-data" = Just FormData+    toSubType _ _           = Nothing++instance Show FormData where+    show _ = "form-data"++data FormUrlEncoded = FormUrlEncoded deriving Eq++instance MSubType FormUrlEncoded where+    toSubType _ "x-www-form-urlencoded" = Just FormUrlEncoded+    toSubType _ _                       = Nothing++instance Show FormUrlEncoded where+    show _ = "x-www-form-urlencoded"++data Gif = Gif deriving Eq++instance MSubType Gif where+    toSubType _ "gif" = Just Gif+    toSubType _ _     = Nothing++instance Show Gif where+    show _ = "gif"++data Gzip = Gzip deriving Eq++instance MSubType Gzip where+    toSubType _ "gzip" = Just Gzip+    toSubType _ _      = Nothing++instance Show Gzip where+    show _ = "gzip"++data Javascript = Javascript deriving Eq++instance MSubType Javascript where+    toSubType _ "javascript" = Just Javascript+    toSubType _ _            = Nothing++instance Show Javascript where+    show _ = "javascript"++data Jpeg = Jpeg deriving Eq++instance MSubType Jpeg where+    toSubType _ "jpeg" = Just Jpeg+    toSubType _ _      = Nothing++instance Show Jpeg where+    show _ = "jpeg"++data Json = Json deriving Eq++instance MSubType Json where+    toSubType _ "json" = Just Json+    toSubType _ _      = Nothing++instance Show Json where+    show _ = "json"++data Mixed = Mixed deriving Eq++instance MSubType Mixed where+    toSubType _ "mixed" = Just Mixed+    toSubType _ _       = Nothing++instance Show Mixed where+    show _ = "mixed"++data Mp4 = Mp4 deriving Eq++instance MSubType Mp4 where+    toSubType _ "mp4" = Just Mp4+    toSubType _ _     = Nothing++instance Show Mp4 where+    show _ = "mp4"++data Mpeg = Mpeg deriving Eq++instance MSubType Mpeg where+    toSubType _ "mpeg" = Just Mpeg+    toSubType _ _      = Nothing++instance Show Mpeg where+    show _ = "mpeg"++data OctetStream = OctetStream deriving Eq++instance MSubType OctetStream where+    toSubType _ "octet-stream" = Just OctetStream+    toSubType _ _              = Nothing++instance Show OctetStream where+    show _ = "octet-stream"++data Ogg = Ogg deriving Eq++instance MSubType Ogg where+    toSubType _ "ogg" = Just Ogg+    toSubType _ _     = Nothing++instance Show Ogg where+    show _ = "ogg"++data Partial = Partial deriving Eq++instance MSubType Partial where+    toSubType _ "partial" = Just Partial+    toSubType _ _         = Nothing++instance Show Partial where+    show _ = "partial"++data Pkcs12 = Pkcs12 deriving Eq++instance MSubType Pkcs12 where+    toSubType _ "x-pkcs12" = Just Pkcs12+    toSubType _ _          = Nothing++instance Show Pkcs12 where+    show _ = "x-pkcs12"++data Pkcs7Cert = Pkcs7Cert deriving Eq++instance MSubType Pkcs7Cert where+    toSubType _ "x-pkcs7-certificates" = Just Pkcs7Cert+    toSubType _ _                      = Nothing++instance Show Pkcs7Cert where+    show _ = "x-pkcs7-certificates"++data Pkcs7Sig = Pkcs7Sig deriving Eq++instance MSubType Pkcs7Sig where+    toSubType _ "x-pkcs7-signature" = Just Pkcs7Sig+    toSubType _ _                   = Nothing++instance Show Pkcs7Sig where+    show _ = "x-pkcs7-signature"++data Pkcs7Mime = Pkcs7Mime deriving Eq++instance MSubType Pkcs7Mime where+    toSubType _ "x-pkcs7-mime" = Just Pkcs7Mime+    toSubType _ _              = Nothing++instance Show Pkcs7Mime where+    show _ = "x-pkcs7-mime"++data Pkcs7CertRqRs = Pkcs7CertRqRs deriving Eq++instance MSubType Pkcs7CertRqRs where+    toSubType _ "x-pkcs7-certreqresp" = Just Pkcs7CertRqRs+    toSubType _ _                     = Nothing++instance Show Pkcs7CertRqRs where+    show _ = "x-pkcs7-certreqresp"++data Plain = Plain deriving Eq++instance MSubType Plain where+    toSubType _ "plain" = Just Plain+    toSubType _ _       = Nothing++instance Show Plain where+    show _ = "plain"++data Png = Png deriving Eq++instance MSubType Png where+    toSubType _ "png" = Just Png+    toSubType _ _     = Nothing++instance Show Png where+    show _ = "png"++data Postscript = Postscript deriving Eq++instance MSubType Postscript where+    toSubType _ "postscript" = Just Postscript+    toSubType _ _            = Nothing++instance Show Postscript where+    show _ = "postscript"++data Protobuf = Protobuf deriving Eq++instance MSubType Protobuf where+    toSubType _ "x-protobuf" = Just Protobuf+    toSubType _ _            = Nothing++instance Show Protobuf where+    show _ = "x-protobuf"++data RdfXml = RdfXml deriving Eq++instance MSubType RdfXml where+    toSubType _ "rdf+xml" = Just RdfXml+    toSubType _ _         = Nothing++instance Show RdfXml where+    show _ = "rdf+xml"++data RssXml = RssXml deriving Eq++instance MSubType RssXml where+    toSubType _ "rss+xml" = Just RssXml+    toSubType _ _         = Nothing++instance Show RssXml where+    show _ = "rss+xml"++data Tar = Tar deriving Eq++instance MSubType Tar where+    toSubType _ "tar" = Just Tar+    toSubType _ _     = Nothing++instance Show Tar where+    show _ = "tar"++data Tiff = Tiff deriving Eq++instance MSubType Tiff where+    toSubType _ "tiff" = Just Tiff+    toSubType _ _      = Nothing++instance Show Tiff where+    show _ = "tiff"++data Thrift = Thrift deriving Eq++instance MSubType Thrift where+    toSubType _ "x-thrift" = Just Thrift+    toSubType _ _          = Nothing++instance Show Thrift where+    show _ = "x-thrift"++data Vorbis = Vorbis deriving Eq++instance MSubType Vorbis where+    toSubType _ "vorbis" = Just Vorbis+    toSubType _ _        = Nothing++instance Show Vorbis where+    show _ = "vorbis"++data Webm = Webm deriving Eq++instance MSubType Webm where+    toSubType _ "webm" = Just Webm+    toSubType _ _      = Nothing++instance Show Webm where+    show _ = "webm"++data XhtmlXml = XhtmlXml deriving Eq++instance MSubType XhtmlXml where+    toSubType _ "xhtml+xml" = Just XhtmlXml+    toSubType _ _           = Nothing++instance Show XhtmlXml where+    show _ = "xhtml+xml"++data Xml = Xml deriving Eq++instance MSubType Xml where+    toSubType _ "xml" = Just Xml+    toSubType _ _     = Nothing++instance Show Xml where+    show _ = "xml"++-- | media-type and sub-type \"*\".+data All = All deriving Eq++instance MType All where+    toType _ "*" = Just All+    toType _ _   = Nothing++instance MSubType All where+    toSubType _ "*" = Just All+    toSubType _ _   = Nothing++instance Show All where+    show _ = "*"+
+ src/Snap/Predicate/MediaType/Internal.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+module Snap.Predicate.MediaType.Internal where++import Control.Monad+import Control.Monad.State.Strict+import Data.ByteString (ByteString)+import Data.List (sortBy)+import Data.Maybe+import Snap.Core (Request)+import Snap.Predicate.Internal+import Snap.Predicate.MediaType+import qualified Data.Predicate.Env           as E+import qualified Snap.Predicate.Parser.Accept as A++mediaType :: (MType t, MSubType s) => Bool -> t -> s -> [A.MediaType] -> Maybe (MediaType t s)+mediaType fuzzy t s = safeHead . mapMaybe (\m -> do+    t' <- if fuzzy && A.medType    m == "*" then Just t else toType t    (A.medType m)+    s' <- if fuzzy && A.medSubtype m == "*" then Just s else toSubType s (A.medSubtype m)+    guard (t == t' && s == s')+    return $ MediaType t s (A.medQuality m) (A.medParams m))++readMediaTypes :: (MonadState m, StateType m ~ E.Env) => ByteString -> Request -> m [A.MediaType]+readMediaTypes k r = do+    let mtypes = sortBy q . concatMap A.parseMediaTypes $ headers k r+    E.insert k mtypes+    return mtypes+  where+    q a b = A.medQuality b `compare` A.medQuality a
+ src/Snap/Predicate/Param.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Snap.Predicate.Param+  ( Parameter (..)+  , Param     (..)+  , ParamOpt  (..)+  , ParamDef  (..)+  , HasParam  (..)+  )+where++import Data.ByteString (ByteString)+import Data.Map (member)+import Data.Monoid+import Data.Typeable+import Data.Predicate+import Snap.Core+import Snap.Predicate.Error+import Snap.Predicate.Internal+import Snap.Util.Readable++-- | The most generic request parameter predicate provided.+-- It will get all request parameter values of '_name' and pass them on to+-- the conversion function '_read', which might either yield an error+-- message or a value. If the parameter is not present, an optional default may be+-- returned instead, if nothing is provided, the error message will be used+-- when construction the 400 status.+data Parameter a = Parameter+  { _pName    :: !ByteString                         -- ^ request parameter name+  , _pRead    :: [ByteString] -> Either ByteString a -- ^ conversion function+  , _pDefault :: !(Maybe a)                          -- ^ (optional) default value+  }++instance Typeable a => Predicate (Parameter a) Request where+    type FVal (Parameter a)     = Error+    type TVal (Parameter a)     = a+    apply (Parameter nme f def) =+        rqApply RqPred+          { _rqName      = nme+          , _rqRead      = f+          , _rqDef       = def+          , _rqCachePref = "parameter:"+          , _rqVals      = params nme+          , _rqError     = Just $ err 400 ("Missing parameter '" <> nme <> "'.")+          }++instance Show (Parameter a) where+    show p = "Parameter: " ++ show (_pName p)++-- | Specialisation of 'Parameter' which returns the first request+-- parameter which could be converted to the target type.+-- Relies on 'Readable' type-class for the actual conversion.+data Param a = Param ByteString++instance (Typeable a, Readable a) => Predicate (Param a) Request where+    type FVal (Param a) = Error+    type TVal (Param a) = a+    apply (Param x)     = apply (Parameter x readValues Nothing)++instance Show (Param a) where+    show (Param x) = "Param: " ++ show x++-- | Specialisation of 'Parameter' which returns the first request+-- parameter which could be converted to the target type.+-- If the parameter is not present, the provided default will be used.+-- Relies on 'Readable' type-class for the actual conversion.+data ParamDef a = ParamDef ByteString a++instance (Typeable a, Readable a) => Predicate (ParamDef a) Request where+    type FVal (ParamDef a) = Error+    type TVal (ParamDef a) = a+    apply (ParamDef x d)   = apply (Parameter x readValues (Just d))++instance Show a => Show (ParamDef a) where+    show (ParamDef x d) = "ParamDef: " ++ show x ++ " [" ++ show d ++ "]"++-- | Predicate which returns the first request parameter which could be+-- converted to the target type wrapped in a Maybe.+-- If the parameter is not present, 'Nothing' will be returned.+-- Relies on 'Readable' type-class for the actual conversion.+data ParamOpt a = ParamOpt ByteString++instance (Typeable a, Readable a) => Predicate (ParamOpt a) Request where+    type FVal (ParamOpt a) = Error+    type TVal (ParamOpt a) = Maybe a+    apply (ParamOpt x)     =+        rqApplyMaybe RqPred+          { _rqName      = x+          , _rqRead      = readValues+          , _rqDef       = Nothing+          , _rqCachePref = "paramopt:"+          , _rqVals      = params x+          , _rqError     = Nothing+          }++instance Show (ParamOpt a) where+    show (ParamOpt x) = "ParamOpt: " ++ show x++-- | Predicate which is true if the request has a parameter with the+-- given name.+data HasParam = HasParam ByteString++instance Predicate HasParam Request where+    type FVal HasParam   = Error+    type TVal HasParam   = ()+    apply (HasParam x) r = return $+        if member x (rqParams r)+            then T 0 ()+            else F (err 400 ("Missing parameter '" <> x <> "'."))++instance Show HasParam where+    show (HasParam x) = "HasParam: " ++ show x
+ src/Snap/Predicate/Parser/Accept.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}+module Snap.Predicate.Parser.Accept+  ( MediaType (..)+  , parseMediaTypes+  )+where++import Control.Applicative+import Data.Attoparsec+import Data.Attoparsec.Text (double)+import Data.ByteString (ByteString)+import Data.Text.Encoding+import Data.Typeable+import Snap.Predicate.Parser.Shared+import qualified Data.Attoparsec.Text as T++data MediaType = MediaType+  { medType    :: !ByteString+  , medSubtype :: !ByteString+  , medQuality :: !Double+  , medParams  :: ![(ByteString, ByteString)]+  } deriving (Eq, Show, Typeable)++parseMediaTypes :: ByteString -> [MediaType]+parseMediaTypes = either (const []) id . parseOnly mediaTypes++mediaTypes :: Parser [MediaType]+mediaTypes = mediaType `sepBy` chr ','++mediaType :: Parser MediaType+mediaType = toMediaType <$> trim typ <*> (chr '/' *> trim subtyp) <*> params+  where+    toMediaType t s p =+        case lookup "q" p >>= toDouble of+            Just q  -> MediaType t s q (filter ((/= "q") . fst) p)+            Nothing -> MediaType t s 1.0 p++params :: Parser [(ByteString, ByteString)]+params = (trim (chr ';') *> (element `sepBy` trim (chr ';'))) <|> return []+  where+    element = (,) <$> trim key <*> (chr '=' *> trim val)++typ, subtyp, key, val :: Parser ByteString+typ    = takeTill (oneof "/ ")+subtyp = takeTill (oneof ",; ")++key = do+    c <- peekWord8+    if c == Just (w ',')+        then fail "comma"+        else takeTill (oneof "= ")++val = takeTill (oneof ",; ")++toDouble :: ByteString -> Maybe Double+toDouble bs = do+    txt <- toMaybe (decodeUtf8' bs)+    toMaybe (T.parseOnly double txt)+  where+    toMaybe (Right x) = Just x+    toMaybe (Left  _) = Nothing
+ src/Snap/Predicate/Parser/Shared.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Snap.Predicate.Parser.Shared where++import Control.Applicative+import Data.Attoparsec+import Data.ByteString (ByteString)+import Data.Char (ord)+import Data.Word+import qualified Data.ByteString as S++spaces :: Parser ()+spaces = skipWhile (== w ' ')++trim :: Parser a -> Parser a+trim p = spaces *> p <* spaces++oneof :: ByteString -> Word8 -> Bool+oneof s c = S.any (== c) s++chr :: Char -> Parser Word8+chr = word8 . w++w :: Char -> Word8+w = fromIntegral . ord
+ src/Snap/Predicate/Tutorial.hs view
@@ -0,0 +1,185 @@+module Snap.Predicate.Tutorial+  ( -- * Motivation+    -- $motivation++    -- * Introduction+    -- $introduction++    -- * Example Predicate+    -- $example++    -- * Routes+    -- $routes+  )+where++{- $motivation++The purpose of the @snap-predicates@ package is to facilitate the+convenient definition of safe Snap handlers. Here safety+means that a handler can declare all pre-conditions which must be+fulfilled such that the handler can produce a successful response.+It is then statically guaranteed that the handler will not be+invoked if any of these pre-conditions fails.++-}++{- $introduction++The @snap-predicates@ package defines a 'Data.Predicate.Boolean' type+which carries \-\- in addition to actual truth values 'Data.Predicate.T'+and 'Data.Predicate.F' \-\- meta-data for each case:++@+data 'Data.Predicate.Boolean' f t =+    'Data.Predicate.F' (Maybe f)+  | 'Data.Predicate.T' 'Data.Predicate.Delta' t+  deriving (Eq, Show)+@++'Data.Predicate.Delta' can in most instances be ignored, i.e. set to 0.+It's purpose is as a measure of distance for those predicates which evaluate+to 'Data.Predicate.T' but some may be \"closer\" in some way than others. An+example is for instance HTTP content-negotiations (cf. 'Snap.Predicate.Accept.Accept')++Further there is a type-class 'Data.Predicate.Predicate' defined which+contains an evaluation function 'Data.Predicate.apply', where the+predicate instance is applied to some value, yielding 'Data.Predicate.T'+or 'Data.Predicate.F'.++@+class 'Data.Predicate.Predicate' p a where+    type 'Data.Predicate.FVal' p+    type 'Data.Predicate.TVal' p+    apply :: p -> a -> 'Control.Monad.State.Strict.State' 'Data.Predicate.Env' (Boolean ('Data.Predicate.FVal' p)) ('Data.Predicate.TVal' p)+@++All predicates are instances of this type-class, which does not+specify the type against which the predicate is evaluated, nor the types+of actual meta-data for the true/false case of the Boolean returned.+Snap related predicates are normally defined against 'Snap.Core.Request'+and in case they fail, they return a status code and an optional message.++Predicates may utilise the stateful 'Data.Predicate.Env.Env' to cache intermediate+results accross multiple evaluations, i.e. a resource may be declared multiple+times with different sets of predicates which means that in case a predicate+is part of more than one set it is evaluated multiple times for the same+input data. As an optimisation it may be beneficial to store intermediate+results in 'Data.Predicate.Env.Env' and re-use them later (cf. the implementation+of 'Snap.Predicate.Accept.Accept').++Besides these type definitions, there are some ways to connect two+'Data.Predicate.Predicate's to form a new one as the logical @OR@ or the+logical @AND@ of its parts. These are:++  * 'Data.Predicate.:|:' and 'Data.Predicate.:||:' as logical @OR@s++  * 'Data.Predicate.:&:' as logical @AND@++Besides evaluating to 'Data.Predicate.T' or 'Data.Predicate.F' depending+on the truth values of its parts, these connectives also propagate the+meta-data and 'Data.Predicate.Delta' appropriately.++If 'Data.Predicate.:&:' evaluates to 'Data.Predicate.T' it has to combine+the meta-data of both predicates, and it uses the product type+'Data.Predicate.:*:' for this. This type also has a right-associative+data constructor using the same symbol, so one can combine many predicates+without having to nest the meta-data pairs.++In the @OR@ case, the two predicates have potentially meta-data of+different types, so we use a sum type 'Either' whenever we combine+two predicates with 'Data.Predicate.:||:'. For convenience a type-alias+'Data.Predicate.:+:' is defined for 'Either', which allows simple infix+notation. However, for the common case where both predicates have+meta-data of the same type, there is often no need to distinguish which+@OR@-branch was true. In this case, the 'Data.Predicate.:|:' combinator+can be used.++Finally there are 'Data.Predicate.Const' and 'Data.Predicate.Fail' to+always evaluate to 'Data.Predicate.T' or 'Data.Predicate.F' respectively.++As an example of how these operators are used, see below in section \"Routes\".+-}++{- $example++@+data Param = Param 'Data.ByteString.ByteString' deriving Eq++instance 'Data.Predicate.Predicate' Param 'Snap.Core.Request' where+    type 'Data.Predicate.FVal' Param = 'Snap.Predicate.Error'+    type 'Data.Predicate.TVal' Param = ByteString+    apply (Param x) r =+        case params r x of+            []    -> return (F ('Snap.Predicate.Error' 400 (Just $ \"Expected parameter '\" \<\> x \<\> \"'.\")))+            (v:_) -> return (T [] v)+@++This is a simple example looking for the existence of a 'Snap.Core.Request' parameter+with the given name. In the success case, the parameter value is returned.++As mentioned before, Snap predicates usually fix the type @a@ from+'Data.Predicate.Predicate' above to 'Snap.Core.Request'. The associated+types 'Data.Predicate.FVal' and 'Data.Predicate.TVal' denote the meta-data+types of the predicate. In this example, the meta-date type is 'Data.ByteString.ByteString'.+The 'Data.Predicate.F'-case is 'Snap.Predicate.Error' which contains a status+code and an optional message.++-}++{- $routes++So how are 'Data.Predicate.Predicate's used in some Snap application?+One way is to just evaluate them against a given request inside a snap handler, e.g.++@+someHandler :: 'Snap.Core.Snap' ()+someHandler = do+    req <- 'Snap.Core.getRequest'+    case 'Data.Predicate.eval' ('Snap.Predicate.Accept.Accept' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Json' 'Data.Predicate.:&:' 'Snap.Predicate.Param.Param' \"baz\") req of+        'Data.Predicate.T' (_ 'Data.Predicate.:*:' bazValue)      -> ...+        'Data.Predicate.F' (Just ('Snap.Predicate.Error' st msg)) -> ...+        'Data.Predicate.F' Nothing               -> ...+@++However another possibility is to augment route definitions with the+'Snap.Routes.Routes' monad to use them with 'Snap.Core.route', e.g.++@+sitemap :: 'Snap.Routes.Routes' Snap ()+sitemap = do+    'Snap.Routes.get'  \"\/a\" handlerA $ 'Snap.Predicate.Accept.Accept' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Json' 'Data.Predicate.:&:' ('Snap.Predicate.Param' \"name\" 'Data.Predicate.:|:' 'Snap.Predicate.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicate.Param' \"foo\"+    'Snap.Routes.get'  \"\/b\" handlerB $ 'Snap.Predicate.Accept.Accept' 'Snap.Predicate.MediaType.Text' 'Snap.Predicate.MediaType.Plain' 'Data.Predicate.:&:' ('Snap.Predicate.Param' \"name\" 'Data.Predicate.:||:' 'Snap.Predicate.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicate.Param' \"foo\"+    'Snap.Routes.get'  \"\/c\" handlerC $ 'Data.Predicate.Fail' ('Snap.Predicate.Error' 410 (Just \"Gone.\"))+    'Snap.Routes.post' \"\/d\" handlerD $ 'Snap.Predicate.Accept.Accept' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Protobuf'+    'Snap.Routes.post' \"\/e\" handlerE $ 'Snap.Predicate.Accept.Accept' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Xml'+@++The handlers then encode their pre-conditions in their type-signature:++@+handlerA :: 'Snap.Predicate.MediaType.MediaType' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Json' 'Data.Predicate.:*:' ByteString 'Data.Predicate.:*:' ByteString -> Snap ()+handlerB :: 'Snap.Predicate.MediaType.MediaType' 'Snap.Predicate.MediaType.Text' 'Snap.Predicate.MediaType.Plain' 'Data.Predicate.:*:' (ByteString 'Data.Predicate.:+:' ByteString) 'Data.Predicate.:*:' ByteString -> Snap ()+handlerC :: 'Snap.Predicate.MediaType.MediaType' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Json' 'Data.Predicate.:*:' Char -> Snap ()+handlerD :: 'Snap.Predicate.MediaType.MediaType' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Protobuf' -> Snap ()+handlerE :: 'Snap.Predicate.MediaType.MediaType' 'Snap.Predicate.MediaType.Application' 'Snap.Predicate.MediaType.Xml' -> Snap ()+@++The type-declaration of a handler has to match the corresponding predicate,+i.e. the type of the predicate's 'Data.Predicate.T' meta-data value:++@+('Snap.Core.MonadSnap' m, 'Data.Predicate.Predicate' p 'Snap.Core.Request') => 'Data.Predicate.TVal' p -> m ()+@++One thing to note is that 'Data.Predicate.Fail' works with+all 'Data.Predicate.T' meta-data types which is safe because the handler is never+invoked, or 'Data.Predicate.Fail' is used in some logical disjunction.++Given the route and handler definitions above, one can then integrate+with Snap via 'Snap.Routes.expandRoutes', which turns the+'Snap.Routes.Routes' monad into a list of+@'Snap.Core.MonadSnap' m => [(ByteString, m ())]@.+Additionally routes can be turned into Strings via 'Snap.Routes.showRoutes'.++-}
+ src/Snap/Predicate/Types.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Snap.Predicate.Types ( CSV, list ) where++import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import Data.Maybe+import Data.Monoid+import Data.Typeable+import Snap.Util.Readable+import qualified Data.ByteString.Char8 as C++newtype CSV a = CSV { list :: [a] } deriving+  ( Eq+  , Ord+  , Read+  , Show+  , Functor+  , Monad+  , MonadPlus+  , Applicative+  , Alternative+  , Monoid+  , Typeable+  )++instance Readable a => Readable (CSV a) where+    fromBS s+      | C.null s  = return empty+      | otherwise =+          let cs = map (fromBS . trim) (C.split ',' s)+              xs = catMaybes cs+          in if length cs /= length xs+                 then fail "no parse"+                 else return (CSV xs)++trim :: ByteString -> ByteString+trim = fst . C.spanEnd (== ' ') . C.dropWhile (== ' ')
− src/Snap/Predicates.hs 
@@ -1,14 +0,0 @@-module Snap.Predicates-  ( module Snap.Predicates.Error-  , module Snap.Predicates.Accept-  , module Snap.Predicates.Content-  , module Snap.Predicates.MediaTypes-  , module Snap.Predicates.Params-  )-where--import Snap.Predicates.Error-import Snap.Predicates.Accept-import Snap.Predicates.Content-import Snap.Predicates.MediaTypes-import Snap.Predicates.Params
− src/Snap/Predicates/Accept.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Snap.Predicates.Accept-  ( Accept (..)-  , module Snap.Predicates.MediaTypes-  )-where--import Data.Monoid hiding (All)-import Data.String-import Data.Predicate-import Snap.Core hiding (headers)-import Snap.Predicates.Error-import Snap.Predicates.MediaTypes-import Snap.Predicates.MediaTypes.Internal-import qualified Data.Predicate.Env as E---- | A 'Predicate' against the 'Request's \"Accept\" header.-data Accept t s = Accept t s deriving Eq--instance (MType t, MSubType s) => Predicate (Accept t s) Request where-    type FVal (Accept t s) = Error-    type TVal (Accept t s) = MediaType t s-    apply (Accept x y) r   = do-        mtypes <- E.lookup "accept" >>= maybe (readMediaTypes "accept" r) return-        if null mtypes-            then return (T 0 (MediaType x y 1.0 []))-            else case mediaType True x y mtypes of-               Just m  -> return (T (1.0 - _quality m) m)-               Nothing -> return (F (err 406 message))-      where-        message = "Expected 'Accept: "-                    <> fromString (show x)-                    <> "/"-                    <> fromString (show y)-                    <> "'."--instance (Show t, Show s) => Show (Accept t s) where-    show (Accept t s) = "Accept: " ++ show t ++ "/" ++ show s
− src/Snap/Predicates/Content.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Snap.Predicates.Content-  ( Content-  , ContentType (..)-  , module Snap.Predicates.MediaTypes-  )-where--import Data.Monoid hiding (All)-import Data.String-import Data.Predicate-import Snap.Core hiding (headers)-import Snap.Predicates.Error-import Snap.Predicates.MediaTypes-import Snap.Predicates.MediaTypes.Internal-import qualified Data.Predicate.Env as E--type Content x y = MediaType x y---- | A 'Predicate' against the 'Request's \"Content-Type\" header.-data ContentType t s = ContentType t s deriving Eq--instance (MType t, MSubType s) => Predicate (ContentType t s) Request where-    type FVal (ContentType t s) = Error-    type TVal (ContentType t s) = MediaType t s-    apply (ContentType x y) r   = do-        mtypes <- E.lookup "content-type" >>= maybe (readMediaTypes "content-type" r) return-        case mediaType False x y mtypes of-               Just m  -> return (T 0 m)-               Nothing -> return (F (err 415 message))-      where-        message = "Expected 'Content-Type: "-                    <> fromString (show x)-                    <> "/"-                    <> fromString (show y)-                    <> "'."--instance (Show t, Show s) => Show (ContentType t s) where-    show (ContentType t s) = "ContentType: " ++ show t ++ "/" ++ show s
− src/Snap/Predicates/Error.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Snap.Predicates.Error where--import Data.ByteString (ByteString)-import Data.Word---- | The error type used as 'F' meta-data in all snap predicates.-data Error = Error-  { _status  :: !Word               -- ^ (HTTP) status code-  , _message :: !(Maybe ByteString) -- ^ optional status message-  } deriving (Eq, Show)---- | Convenience function to construct 'Error' values from--- status code and status message.-err :: Word -> ByteString -> Error-err s = Error s . Just
− src/Snap/Predicates/Internal.hs 
@@ -1,21 +0,0 @@-module Snap.Predicates.Internal-  ( headers-  , params-  , safeHead-  )-where--import Snap.Core hiding (headers)-import Data.ByteString (ByteString)-import Data.CaseInsensitive (mk)-import qualified Data.Map.Strict as M--headers :: Request -> ByteString -> [ByteString]-headers rq name = maybe [] id . getHeaders (mk name) $ rq--params :: Request -> ByteString -> [ByteString]-params rq name = maybe [] id . M.lookup name . rqParams $ rq--safeHead :: [a] -> Maybe a-safeHead []    = Nothing-safeHead (h:_) = Just h
− src/Snap/Predicates/MediaTypes.hs 
@@ -1,430 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns      #-}-module Snap.Predicates.MediaTypes-  ( -- * Types-    MType (..)-  , MSubType (..)-  , MediaType (..)--  -- * Media-Types-  , Type (..)-  , All (..)-  , Application (..)-  , Audio (..)-  , Image (..)-  , Message (..)-  , Multipart (..)-  , Text (..)-  , Video (..)--  -- * Media-Sub-Types-  , SubType (..)-  , AtomXml (..)-  , Css (..)-  , Csv (..)-  , Encrypted (..)-  , FormData (..)-  , Gif (..)-  , Gzip (..)-  , Javascript (..)-  , Jpeg (..)-  , Json (..)-  , Mixed (..)-  , Mp4 (..)-  , Mpeg (..)-  , OctetStream (..)-  , Ogg (..)-  , Partial (..)-  , Plain (..)-  , Png (..)-  , Postscript (..)-  , Protobuf (..)-  , RdfXml (..)-  , RssXml (..)-  , Tar (..)-  , Tiff (..)-  , Thrift (..)-  , Vorbis (..)-  , Webm (..)-  , XhtmlXml (..)-  , Xml (..)-  )-where--import Data.ByteString (ByteString)---- | Type-class for converting a 'ByteString' to a media-type.-class (Show a, Eq a) => MType a where-    toType :: a -> ByteString -> Maybe a---- | Type-class for converting a 'ByteString' to a media-subtype.-class (Show a, Eq a) => MSubType a where-    toSubType :: a -> ByteString -> Maybe a---- | The Media-type representation.-data MediaType t s = MediaType-  { _type    :: !t-  , _subtype :: !s-  , _quality :: !Double-  , _params  :: ![(ByteString, ByteString)]-  } deriving (Eq, Show)---- Media-Types:---- | Generic media-type.-data Type = Type ByteString deriving Eq--instance MType Type where-    toType o@(Type t) s = if t == s then Just o else Nothing--instance Show Type where-    show (Type t) = show t--data Application = Application deriving Eq--instance MType Application where-    toType _ "application" = Just Application-    toType _ _             = Nothing--instance Show Application where-    show _ = "application"--data Audio = Audio deriving Eq--instance MType Audio where-    toType _ "audio" = Just Audio-    toType _ _       = Nothing--instance Show Audio where-    show _ = "audio"--data Image = Image deriving Eq--instance MType Image where-    toType _ "image" = Just Image-    toType _ _       = Nothing--instance Show Image where-    show _ = "image"--data Message = Message deriving Eq--instance MType Message where-    toType _ "message" = Just Message-    toType _ _         = Nothing--instance Show Message where-    show _ = "message"--data Multipart = Multipart deriving Eq--instance MType Multipart where-    toType _ "multipart" = Just Multipart-    toType _ _           = Nothing--instance Show Multipart where-    show _ = "multipart"--data Text = Text deriving Eq--instance MType Text where-    toType _ "text" = Just Text-    toType _ _      = Nothing--instance Show Text where-    show _ = "text"--data Video = Video deriving Eq--instance MType Video where-    toType _ "video" = Just Video-    toType _ _       = Nothing--instance Show Video where-    show _ = "video"---- Media-Subtypes:---- | Generic media-subtype.-data SubType = SubType ByteString deriving Eq--instance MSubType SubType where-    toSubType o@(SubType t) s = if t == s then Just o else Nothing--instance Show SubType where-    show (SubType t) = show t--data AtomXml = AtomXml deriving Eq--instance MSubType AtomXml where-    toSubType _ "atom+xml" = Just AtomXml-    toSubType _ _          = Nothing--instance Show AtomXml where-    show _ = "atom+xml"--data Css = Css deriving Eq--instance MSubType Css where-    toSubType _ "css" = Just Css-    toSubType _ _     = Nothing--instance Show Css where-    show _ = "css"--data Csv = Csv deriving Eq--instance MSubType Csv where-    toSubType _ "csv" = Just Csv-    toSubType _ _     = Nothing--instance Show Csv where-    show _ = "csv"--data Encrypted = Encrypted deriving Eq--instance MSubType Encrypted where-    toSubType _ "encrypted" = Just Encrypted-    toSubType _ _           = Nothing--instance Show Encrypted where-    show _ = "encrypted"--data FormData = FormData deriving Eq--instance MSubType FormData where-    toSubType _ "form-data" = Just FormData-    toSubType _ _           = Nothing--instance Show FormData where-    show _ = "form-data"--data Gif = Gif deriving Eq--instance MSubType Gif where-    toSubType _ "gif" = Just Gif-    toSubType _ _     = Nothing--instance Show Gif where-    show _ = "gif"--data Gzip = Gzip deriving Eq--instance MSubType Gzip where-    toSubType _ "gzip" = Just Gzip-    toSubType _ _      = Nothing--instance Show Gzip where-    show _ = "gzip"--data Javascript = Javascript deriving Eq--instance MSubType Javascript where-    toSubType _ "javascript" = Just Javascript-    toSubType _ _            = Nothing--instance Show Javascript where-    show _ = "javascript"--data Jpeg = Jpeg deriving Eq--instance MSubType Jpeg where-    toSubType _ "jpeg" = Just Jpeg-    toSubType _ _      = Nothing--instance Show Jpeg where-    show _ = "jpeg"--data Json = Json deriving Eq--instance MSubType Json where-    toSubType _ "json" = Just Json-    toSubType _ _      = Nothing--instance Show Json where-    show _ = "json"--data Mixed = Mixed deriving Eq--instance MSubType Mixed where-    toSubType _ "mixed" = Just Mixed-    toSubType _ _       = Nothing--instance Show Mixed where-    show _ = "mixed"--data Mp4 = Mp4 deriving Eq--instance MSubType Mp4 where-    toSubType _ "mp4" = Just Mp4-    toSubType _ _     = Nothing--instance Show Mp4 where-    show _ = "mp4"--data Mpeg = Mpeg deriving Eq--instance MSubType Mpeg where-    toSubType _ "mpeg" = Just Mpeg-    toSubType _ _      = Nothing--instance Show Mpeg where-    show _ = "mpeg"--data OctetStream = OctetStream deriving Eq--instance MSubType OctetStream where-    toSubType _ "octet-stream" = Just OctetStream-    toSubType _ _              = Nothing--instance Show OctetStream where-    show _ = "octet-stream"--data Ogg = Ogg deriving Eq--instance MSubType Ogg where-    toSubType _ "ogg" = Just Ogg-    toSubType _ _     = Nothing--instance Show Ogg where-    show _ = "ogg"--data Partial = Partial deriving Eq--instance MSubType Partial where-    toSubType _ "partial" = Just Partial-    toSubType _ _         = Nothing--instance Show Partial where-    show _ = "partial"--data Plain = Plain deriving Eq--instance MSubType Plain where-    toSubType _ "plain" = Just Plain-    toSubType _ _       = Nothing--instance Show Plain where-    show _ = "plain"--data Png = Png deriving Eq--instance MSubType Png where-    toSubType _ "png" = Just Png-    toSubType _ _     = Nothing--instance Show Png where-    show _ = "png"--data Postscript = Postscript deriving Eq--instance MSubType Postscript where-    toSubType _ "postscript" = Just Postscript-    toSubType _ _            = Nothing--instance Show Postscript where-    show _ = "postscript"--data Protobuf = Protobuf deriving Eq--instance MSubType Protobuf where-    toSubType _ "x-protobuf" = Just Protobuf-    toSubType _ _            = Nothing--instance Show Protobuf where-    show _ = "x-protobuf"--data RdfXml = RdfXml deriving Eq--instance MSubType RdfXml where-    toSubType _ "rdf+xml" = Just RdfXml-    toSubType _ _         = Nothing--instance Show RdfXml where-    show _ = "rdf+xml"--data RssXml = RssXml deriving Eq--instance MSubType RssXml where-    toSubType _ "rss+xml" = Just RssXml-    toSubType _ _         = Nothing--instance Show RssXml where-    show _ = "rss+xml"--data Tar = Tar deriving Eq--instance MSubType Tar where-    toSubType _ "tar" = Just Tar-    toSubType _ _     = Nothing--instance Show Tar where-    show _ = "tar"--data Tiff = Tiff deriving Eq--instance MSubType Tiff where-    toSubType _ "tiff" = Just Tiff-    toSubType _ _      = Nothing--instance Show Tiff where-    show _ = "tiff"--data Thrift = Thrift deriving Eq--instance MSubType Thrift where-    toSubType _ "x-thrift" = Just Thrift-    toSubType _ _          = Nothing--instance Show Thrift where-    show _ = "x-thrift"--data Vorbis = Vorbis deriving Eq--instance MSubType Vorbis where-    toSubType _ "vorbis" = Just Vorbis-    toSubType _ _        = Nothing--instance Show Vorbis where-    show _ = "vorbis"--data Webm = Webm deriving Eq--instance MSubType Webm where-    toSubType _ "webm" = Just Webm-    toSubType _ _      = Nothing--instance Show Webm where-    show _ = "webm"--data XhtmlXml = XhtmlXml deriving Eq--instance MSubType XhtmlXml where-    toSubType _ "xhtml+xml" = Just XhtmlXml-    toSubType _ _           = Nothing--instance Show XhtmlXml where-    show _ = "xhtml+xml"--data Xml = Xml deriving Eq--instance MSubType Xml where-    toSubType _ "xml" = Just Xml-    toSubType _ _     = Nothing--instance Show Xml where-    show _ = "xml"---- | media-type and sub-type \"*\".-data All = All deriving Eq--instance MType All where-    toType _ "*" = Just All-    toType _ _   = Nothing--instance MSubType All where-    toSubType _ "*" = Just All-    toSubType _ _   = Nothing--instance Show All where-    show _ = "*"
− src/Snap/Predicates/MediaTypes/Internal.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}-module Snap.Predicates.MediaTypes.Internal where--import Control.Monad-import Control.Monad.State.Strict-import Data.ByteString (ByteString)-import Data.List (sortBy)-import Data.Maybe-import Snap.Core (Request)-import Snap.Predicates.Internal-import Snap.Predicates.MediaTypes-import qualified Data.Predicate.Env as E-import qualified Snap.Predicates.Parsers.Accept as A--mediaType :: (MType t, MSubType s) => Bool -> t -> s -> [A.MediaType] -> Maybe (MediaType t s)-mediaType fuzzy t s = safeHead . mapMaybe (\m -> do-    t' <- if fuzzy && A.medType    m == "*" then Just t else toType t    (A.medType m)-    s' <- if fuzzy && A.medSubtype m == "*" then Just s else toSubType s (A.medSubtype m)-    guard (t == t' && s == s')-    return $ MediaType t s (A.medQuality m) (A.medParams m))--readMediaTypes :: (MonadState m, StateType m ~ E.Env) => ByteString -> Request -> m [A.MediaType]-readMediaTypes k r = do-    let mtypes = sortBy q . concat . map A.parseMediaTypes $ headers r k-    E.insert k mtypes-    return mtypes-  where-    q a b = A.medQuality b `compare` A.medQuality a
− src/Snap/Predicates/Params.hs 
@@ -1,107 +0,0 @@-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Snap.Predicates.Params-  ( Parameter (..)-  , Param (..)-  , ParamOpt (..)-  , ParamDef (..)-  )-where--import Data.ByteString (ByteString)-import Data.ByteString.Readable-import Data.Either-import Data.Monoid-import Data.String-import Data.Typeable-import Data.Predicate-import Snap.Core hiding (headers)-import Snap.Predicates.Error-import Snap.Predicates.Internal-import qualified Data.Predicate.Env as E-import qualified Data.ByteString as S---- | The most generic request parameter predicate provided.--- It will get all request parameter values of '_name' and pass them on to--- the conversion function '_read', which might either yield an error--- message or a value. In case of error, an optional default may be--- returned instead, if nothing is provided, the error message will be used--- when construction the 400 status.-data Parameter a = Parameter-  { _name    :: !ByteString                         -- ^ request parameter name-  , _read    :: [ByteString] -> Either ByteString a -- ^ conversion function-  , _default :: !(Maybe a)                          -- ^ (optional) default value-  }--instance Typeable a => Predicate (Parameter a) Request where-    type FVal (Parameter a) = Error-    type TVal (Parameter a) = a-    apply (Parameter nme f def) r =-        E.lookup (key nme) >>= maybe work result-      where-        work = case params r nme of-            [] -> maybe (return (F (err 400 ("Missing parameter '" <> nme <> "'."))))-                        (return . (T 0))-                        def-            vs -> do-                let x = f vs-                E.insert (key nme) x-                case x of-                    Left msg -> return $ maybe (F (err 400 msg)) (T 0) def-                    Right  v -> return $ T 0 v--        result (Left msg) = return (F (err 400 msg))-        result (Right  v) = return (T 0 v)--        key name = "parameter:" <> name <> ":" <> (fromString . show . typeOf $ def)--instance Show (Parameter a) where-    show p = "Parameter: " ++ show (_name p)---- | Specialisation of 'Parameter' which returns the first request--- which could be converted to the target type.-data Param a = Param ByteString--instance (Typeable a, Readable a) => Predicate (Param a) Request where-    type FVal (Param a) = Error-    type TVal (Param a) = a-    apply (Param x)     = apply (Parameter x f Nothing)-      where-        f vs = let (es, xs) = partitionEithers $ map fromByteString vs-               in if null xs-                      then Left (S.intercalate "\n" es)-                      else Right (head xs)--instance Show (Param a) where-    show (Param x) = "Param: " ++ show x---- | Like 'Param', but denoting an optional parameter, i.e. if the--- parameter is not present or can not be converted to the target type, the--- predicate will still succeed.-data ParamOpt a = ParamOpt ByteString--instance (Typeable a, Readable a) => Predicate (ParamOpt a) Request where-    type FVal (ParamOpt a) = Error-    type TVal (ParamOpt a) = Maybe a-    apply (ParamOpt x)     = apply (Parameter x f (Just Nothing))-      where-        f vs = let xs = rights $ map fromByteString vs-               in if null xs then Right Nothing else Right (head xs)--instance Show (ParamOpt a) where-    show (ParamOpt x) = "ParamOpt: " ++ show x---- | Like 'Param', but in case the parameter could not be found, the--- provided default value will be used. ParamDef is provided for--- convenience and nothing else than Param || Const, e.g.--- @ParamDef \"foo\" 0 == Param \"foo\" ':|:' 'Const' 0@.-data ParamDef a = ParamDef ByteString a--instance (Typeable a, Readable a) => Predicate (ParamDef a) Request where-    type FVal (ParamDef a) = Error-    type TVal (ParamDef a) = a-    apply (ParamDef x d)   = apply (Param x :|: Const d)--instance Show a => Show (ParamDef a) where-    show (ParamDef x d) = "ParamDef: " ++ show x ++ " [" ++ show d ++ "]"
− src/Snap/Predicates/Parsers/Accept.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings, BangPatterns, DeriveDataTypeable #-}-module Snap.Predicates.Parsers.Accept-  ( MediaType (..)-  , parseMediaTypes-  )-where--import Control.Applicative-import Data.Attoparsec-import Data.Attoparsec.Text (double)-import Data.ByteString (ByteString)-import Data.Text.Encoding-import Data.Typeable-import Snap.Predicates.Parsers.Shared-import qualified Data.Attoparsec.Text as T--data MediaType = MediaType-  { medType    :: !ByteString-  , medSubtype :: !ByteString-  , medQuality :: !Double-  , medParams  :: ![(ByteString, ByteString)]-  } deriving (Eq, Show, Typeable)--parseMediaTypes :: ByteString -> [MediaType]-parseMediaTypes = either (const []) id . parseOnly mediaTypes--mediaTypes :: Parser [MediaType]-mediaTypes = mediaType `sepBy` chr ','--mediaType :: Parser MediaType-mediaType = toMediaType <$> trim typ <*> (chr '/' *> trim subtyp) <*> params-  where-    toMediaType t s p =-        case lookup "q" p >>= toDouble of-            Just q  -> MediaType t s q (filter ((/= "q") . fst) p)-            Nothing -> MediaType t s 1.0 p--params :: Parser [(ByteString, ByteString)]-params = (trim (chr ';') *> (element `sepBy` trim (chr ';'))) <|> return []-  where-    element = (,) <$> trim key <*> (chr '=' *> trim val)--typ, subtyp, key, val :: Parser ByteString-typ    = takeTill (oneof "/ ")-subtyp = takeTill (oneof ",; ")--key = do-    c <- peekWord8-    if c == Just (w ',')-        then fail "comma"-        else takeTill (oneof "= ")--val = takeTill (oneof ",; ")--toDouble :: ByteString -> Maybe Double-toDouble bs = do-    txt <- toMaybe (decodeUtf8' bs)-    dec <- toMaybe (T.parseOnly double txt)-    return dec-  where-    toMaybe (Right x) = Just x-    toMaybe (Left  _) = Nothing
− src/Snap/Predicates/Parsers/Shared.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}-module Snap.Predicates.Parsers.Shared where--import Control.Applicative-import Data.Attoparsec-import Data.ByteString (ByteString)-import Data.Char (ord)-import Data.Word-import qualified Data.ByteString as S--spaces :: Parser ()-spaces = skipWhile (== w ' ')--trim :: Parser a -> Parser a-trim p = spaces *> p <* spaces--oneof :: ByteString -> Word8 -> Bool-oneof = flip elem . S.unpack--chr :: Char -> Parser Word8-chr = word8 . w--w :: Char -> Word8-w = fromIntegral . ord
− src/Snap/Predicates/Tutorial.hs 
@@ -1,185 +0,0 @@-module Snap.Predicates.Tutorial-  ( -- * Motivation-    -- $motivation--    -- * Introduction-    -- $introduction--    -- * Example Predicate-    -- $example--    -- * Routes-    -- $routes-  )-where--{- $motivation--The purpose of the @snap-predicates@ package is to facilitate the-convenient definition of safe Snap handlers. Here safety-means that a handler can declare all pre-conditions which must be-fulfilled such that the handler can produce a successful response.-It is then statically guaranteed that the handler will not be-invoked if any of these pre-conditions fails.---}--{- $introduction--The @snap-predicates@ package defines a 'Data.Predicate.Boolean' type-which carries \-\- in addition to actual truth values 'Data.Predicate.T'-and 'Data.Predicate.F' \-\- meta-data for each case:--@-data 'Data.Predicate.Boolean' f t =-    'Data.Predicate.F' (Maybe f)-  | 'Data.Predicate.T' 'Data.Predicate.Delta' t-  deriving (Eq, Show)-@--'Data.Predicate.Delta' can in most instances be ignored, i.e. set to 0.-It's purpose is as a measure of distance for those predicates which evaluate-to 'Data.Predicate.T' but some may be \"closer\" in some way than others. An-example is for instance HTTP content-negotiations (cf. 'Snap.Predicates.MediaTypes.Accept')--Further there is a type-class 'Data.Predicate.Predicate' defined which-contains an evaluation function 'Data.Predicate.apply', where the-predicate instance is applied to some value, yielding 'Data.Predicate.T'-or 'Data.Predicate.F'.--@-class 'Data.Predicate.Predicate' p a where-    type 'Data.Predicate.FVal' p-    type 'Data.Predicate.TVal' p-    apply :: p -> a -> 'Control.Monad.State.Strict.State' 'Data.Predicate.Env' (Boolean ('Data.Predicate.FVal' p)) ('Data.Predicate.TVal' p)-@--All predicates are instances of this type-class, which does not-specify the type against which the predicate is evaluated, nor the types-of actual meta-data for the true/false case of the Boolean returned.-Snap related predicates are normally defined against 'Snap.Core.Request'-and in case they fail, they return a status code and an optional message.--Predicates may utilise the stateful 'Data.Predicate.Env.Env' to cache intermediate-results accross multiple evaluations, i.e. a resource may be declared multiple-times with different sets of predicates which means that in case a predicate-is part of more than one set it is evaluated multiple times for the same-input data. As an optimisation it may be beneficial to store intermediate-results in 'Data.Predicate.Env.Env' and re-use them later (cf. the implementation-of 'Snap.Predicates.MediaTypes.Accept').--Besides these type definitions, there are some ways to connect two-'Data.Predicate.Predicate's to form a new one as the logical @OR@ or the-logical @AND@ of its parts. These are:--  * 'Data.Predicate.:|:' and 'Data.Predicate.:||:' as logical @OR@s--  * 'Data.Predicate.:&:' as logical @AND@--Besides evaluating to 'Data.Predicate.T' or 'Data.Predicate.F' depending-on the truth values of its parts, these connectives also propagate the-meta-data and 'Data.Predicate.Delta' appropriately.--If 'Data.Predicate.:&:' evaluates to 'Data.Predicate.T' it has to combine-the meta-data of both predicates, and it uses the product type-'Data.Predicate.:*:' for this. This type also has a right-associative-data constructor using the same symbol, so one can combine many predicates-without having to nest the meta-data pairs.--In the @OR@ case, the two predicates have potentially meta-data of-different types, so we use a sum type 'Either' whenever we combine-two predicates with 'Data.Predicate.:||:'. For convenience a type-alias-'Data.Predicate.:+:' is defined for 'Either', which allows simple infix-notation. However, for the common case where both predicates have-meta-data of the same type, there is often no need to distinguish which-@OR@-branch was true. In this case, the 'Data.Predicate.:|:' combinator-can be used.--Finally there are 'Data.Predicate.Const' and 'Data.Predicate.Fail' to-always evaluate to 'Data.Predicate.T' or 'Data.Predicate.F' respectively.--As an example of how these operators are used, see below in section \"Routes\".--}--{- $example--@-data 'Snap.Predicates.Params.Param' = Param 'Data.ByteString.ByteString' deriving Eq--instance 'Data.Predicate.Predicate' Param 'Snap.Core.Request' where-    type 'Data.Predicate.FVal' Param = 'Snap.Predicates.Error'-    type 'Data.Predicate.TVal' Param = ByteString-    apply (Param x) r =-        case params r x of-            []    -> return (F ('Snap.Predicates.Error' 400 (Just $ \"Expected parameter '\" \<\> x \<\> \"'.\")))-            (v:_) -> return (T [] v)-@--This is a simple example looking for the existence of a 'Snap.Core.Request' parameter-with the given name. In the success case, the parameter value is returned.--As mentioned before, Snap predicates usually fix the type @a@ from-'Data.Predicate.Predicate' above to 'Snap.Core.Request'. The associated-types 'Data.Predicate.FVal' and 'Data.Predicate.TVal' denote the meta-data-types of the predicate. In this example, the meta-date type is 'Data.ByteString.ByteString'.-The 'Data.Predicate.F'-case is 'Snap.Predicates.Error' which contains a status-code and an optional message.---}--{- $routes--So how are 'Data.Predicate.Predicate's used in some Snap application?-One way is to just evaluate them against a given request inside a snap handler, e.g.--@-someHandler :: 'Snap.Core.Snap' ()-someHandler = do-    req <- 'Snap.Core.getRequest'-    case 'Data.Predicate.eval' ('Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:&:' 'Snap.Predicates.Params.Param' \"baz\") req of-        'Data.Predicate.T' (_ 'Data.Predicate.:*:' bazValue)      -> ...-        'Data.Predicate.F' (Just ('Snap.Predicates.Error' st msg)) -> ...-        'Data.Predicate.F' Nothing               -> ...-@--However another possibility is to augment route definitions with the-'Snap.Routes.Routes' monad to use them with 'Snap.Core.route', e.g.--@-sitemap :: 'Snap.Routes.Routes' Snap ()-sitemap = do-    'Snap.Routes.get'  \"\/a\" handlerA $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:|:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"-    'Snap.Routes.get'  \"\/b\" handlerB $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Text' 'Snap.Predicates.MediaTypes.Plain' 'Data.Predicate.:&:' ('Snap.Predicates.Param' \"name\" 'Data.Predicate.:||:' 'Snap.Predicates.Param' \"nick\") 'Data.Predicate.:&:' 'Snap.Predicates.Param' \"foo\"-    'Snap.Routes.get'  \"\/c\" handlerC $ 'Data.Predicate.Fail' ('Snap.Predicates.Error' 410 (Just \"Gone.\"))-    'Snap.Routes.post' \"\/d\" handlerD $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Protobuf'-    'Snap.Routes.post' \"\/e\" handlerE $ 'Snap.Predicates.MediaTypes.Accept' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Xml'-@--The handlers then encode their pre-conditions in their type-signature:--@-handlerA :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:*:' ByteString 'Data.Predicate.:*:' ByteString -> Snap ()-handlerB :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Text' 'Snap.Predicates.MediaTypes.Plain' 'Data.Predicate.:*:' (ByteString 'Data.Predicate.:+:' ByteString) 'Data.Predicate.:*:' ByteString -> Snap ()-handlerC :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Json' 'Data.Predicate.:*:' Char -> Snap ()-handlerD :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Protobuf' -> Snap ()-handlerE :: 'Snap.Predicates.MediaTypes.MediaType' 'Snap.Predicates.MediaTypes.Application' 'Snap.Predicates.MediaTypes.Xml' -> Snap ()-@--The type-declaration of a handler has to match the corresponding predicate,-i.e. the type of the predicate's 'Data.Predicate.T' meta-data value:--@-('Snap.Core.MonadSnap' m, 'Data.Predicate.Predicate' p 'Snap.Core.Request') => 'Data.Predicate.TVal' p -> m ()-@--One thing to note is that 'Data.Predicate.Fail' works with-all 'Data.Predicate.T' meta-data types which is safe because the handler is never-invoked, or 'Data.Predicate.Fail' is used in some logical disjunction.--Given the route and handler definitions above, one can then integrate-with Snap via 'Snap.Routes.expandRoutes', which turns the-'Snap.Routes.Routes' monad into a list of-@'Snap.Core.MonadSnap' m => [(ByteString, m ())]@.-Additionally routes can be turned into Strings via 'Snap.Routes.showRoutes'.---}
+ src/Snap/Route.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleContexts  #-}+module Snap.Route+  ( Routes+  , showRoutes+  , expandRoutes+  , addRoute+  , get+  , get_+  , Snap.Route.head+  , head_+  , post+  , post_+  , put+  , put_+  , delete+  , delete_+  , trace+  , trace_+  , options+  , options_+  , connect+  , connect_+  )+where++import Control.Applicative hiding (Const)+import Control.Monad+import Control.Monad.State.Strict hiding (get, put)+import Data.ByteString (ByteString)+import Data.Either+import Data.Function+import Data.List hiding (head, delete)+import Data.Predicate+import Data.Predicate.Env (Env)+import Snap.Core+import Snap.Predicate+import qualified Data.List as L+import qualified Data.Predicate.Env as E+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C++data Pack m where+    Pack :: (Show p, Predicate p Request, FVal p ~ Error)+         => p+         -> (TVal p -> m ())+         -> Pack m++data Route m = Route+  { _method  :: !Method+  , _path    :: !ByteString+  , _pred    :: !(Pack m)+  }++-- | The Routes monad is used to add routing declarations via 'addRoute' or+-- one of 'get', 'post', etc.+-- Routing declarations can then be turned into the ordinary snap format,+-- i.e. @MonadSnap m => [(ByteString, m a)]@ or into strings.+newtype Routes m a = Routes+  { _unroutes :: State [Route m] a }++instance Monad (Routes m) where+    return  = Routes . return+    m >>= f = Routes $ _unroutes m >>= _unroutes . f++-- | Add a route for some 'Method' and path (potentially with variable+-- captures), and constrained the some 'Predicate'.+addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)+         => Method+         -> ByteString        -- ^ path+         -> (TVal p -> m ())  -- ^ handler+         -> p                 -- ^ 'Predicate'+         -> Routes m ()+addRoute m r x p = Routes $ modify (Route m r (Pack p x):)++-- | Specialisation of 'addRoute' for a specific HTTP 'Method'.+get, head, post, put, delete, trace, options, connect ::+    (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)+    => ByteString        -- ^ path+    -> (TVal p -> m ())  -- ^ handler+    -> p                 -- ^ 'Predicate'+    -> Routes m ()+get     = addRoute GET+head    = addRoute HEAD+post    = addRoute POST+put     = addRoute PUT+delete  = addRoute DELETE+trace   = addRoute TRACE+options = addRoute OPTIONS+connect = addRoute CONNECT++-- | Specialisation of 'addRoute' for a specific HTTP 'Method' taking+-- no 'Predicate' into consideration.+get_, head_, post_, put_, delete_, trace_, options_, connect_ ::+    (MonadSnap m)+    => ByteString    -- ^ path+    -> (() -> m ())  -- ^ handler+    -> Routes m ()+get_     p h = addRoute GET     p h (Const ())+head_    p h = addRoute HEAD    p h (Const ())+post_    p h = addRoute POST    p h (Const ())+put_     p h = addRoute PUT     p h (Const ())+delete_  p h = addRoute DELETE  p h (Const ())+trace_   p h = addRoute TRACE   p h (Const ())+options_ p h = addRoute OPTIONS p h (Const ())+connect_ p h = addRoute CONNECT p h (Const ())++-- | Turn route definitions into a list of 'String's.+showRoutes :: Routes m () -> [String]+showRoutes (Routes routes) =+    flip map (concat . normalise $ execState routes []) $ \x ->+        case _pred x of+            Pack p _ -> shows (_method x)+                      . (' ':)+                      . shows (_path x)+                      . (' ':)+                      . shows p $ ""++-- | Turn route definitions into \"snapable\" format, i.e.+-- Routes are grouped per path and selection evaluates routes+-- against the given Snap 'Request'.+expandRoutes :: MonadSnap m => Routes m () -> [(ByteString, m ())]+expandRoutes (Routes routes) =+    map (\g -> (_path (L.head g), select g)) (normalise $ execState routes [])++-- | Group routes by path.+normalise :: [Route m] -> [[Route m]]+normalise rr =+    let rg    = grouped . sorted $ rr+        paths = map (namelessPath . L.head) rg+        ambig = paths \\ nub paths+    in if null ambig then rg else error (ambiguityMessage ambig)+  where+    sorted :: [Route m] -> [Route m]+    sorted = sortBy (compare `on` _path)++    grouped :: [Route m] -> [[Route m]]+    grouped = groupBy ((==) `on` _path)++    namelessPath :: Route m -> ByteString+    namelessPath =+        let colon = 0x3A+            slash = 0x2F+            fun s = if s /= "" && S.head s == colon then "<>" else s+        in S.intercalate "/" . map fun . S.split slash . _path++    ambiguityMessage a =+        "Paths differing only in variable names are not supported.\n"  +++        "Problematic paths (with variable positions denoted by <>):\n" +++        show a++data Handler m = Handler+  { _delta   :: !Delta+  , _handler :: !(m ())+  }++-- The handler selection proceeds as follows:+-- (1) Consider only handlers with matching methods, or else return 405.+-- (2) Evaluate 'Route' predicates.+-- (3) Pick the first one which is 'Good', or else respond with status+--     and message of the first one.+select :: MonadSnap m => [Route m] -> m ()+select g = do+    ms <- filterM byMethod g+    if null ms+        then do+            respond (Error 405 Nothing)+            modifyResponse (setHeader "Allow" validMethods)+        else evalAll ms+  where+    byMethod :: MonadSnap m => Route m -> m Bool+    byMethod x = (_method x ==) <$> getsRequest rqMethod++    validMethods :: ByteString+    validMethods = S.intercalate "," $ nub (C.pack . show . _method <$> g)++    evalAll :: MonadSnap m => [Route m] -> m ()+    evalAll rs = do+        req <- getRequest+        let (n, y) = partitionEithers . snd $ foldl' (evalSingle req) (E.empty, []) rs+        if null y+            then respond (L.head n)+            else closest y++    evalSingle :: MonadSnap m => Request -> (Env, [Either Error (Handler m)]) -> Route m -> (Env, [Either Error (Handler m)])+    evalSingle rq (e, rs) r =+        case _pred r of+            Pack p h ->+                case runState (apply p rq) e of+                    (F   m, e') -> (e', Left m : rs)+                    (T d v, e') -> (e', Right (Handler d (h v)) : rs)++    closest :: MonadSnap m => [Handler m] -> m ()+    closest = foldl' (<|>) pass+            . map _handler+            . sortBy (compare `on` _delta)++respond :: MonadSnap m => Error -> m ()+respond e = do+    putResponse . clearContentLength+                . setResponseCode (fromIntegral . _status $ e)+                $ emptyResponse+    maybe (return ()) writeBS (_message e)
− src/Snap/Routes.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE TypeOperators     #-}-{-# LANGUAGE FlexibleContexts  #-}-module Snap.Routes-  ( Routes-  , showRoutes-  , expandRoutes-  , addRoute-  , get-  , get_-  , Snap.Routes.head-  , head_-  , post-  , post_-  , put-  , put_-  , delete-  , delete_-  , trace-  , trace_-  , options-  , options_-  , connect-  , connect_-  )-where--import Control.Applicative hiding (Const)-import Control.Monad-import Control.Monad.State.Strict hiding (get, put)-import Data.ByteString (ByteString)-import Data.Either-import Data.List hiding (head, delete)-import Data.Predicate-import Data.Predicate.Env (Env)-import Snap.Core-import Snap.Predicates-import qualified Data.List as L-import qualified Data.Predicate.Env as E-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as C--data Pack m where-    Pack :: (Show p, Predicate p Request, FVal p ~ Error)-         => p-         -> (TVal p -> m ())-         -> Pack m--data Route m = Route-  { _method  :: !Method-  , _path    :: !ByteString-  , _pred    :: !(Pack m)-  }---- | The Routes monad is used to add routing declarations via 'addRoute' or--- one of 'get', 'post', etc.--- Routing declarations can then be turned into the ordinary snap format,--- i.e. @MonadSnap m => [(ByteString, m a)]@ or into strings.-newtype Routes m a = Routes-  { _unroutes :: State [Route m] a }--instance Monad (Routes m) where-    return  = Routes . return-    m >>= f = Routes $ _unroutes m >>= _unroutes . f---- | Add a route for some 'Method' and path (potentially with variable--- captures), and constrained the some 'Predicate'.-addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)-         => Method-         -> ByteString        -- ^ path-         -> (TVal p -> m ())  -- ^ handler-         -> p                 -- ^ 'Predicate'-         -> Routes m ()-addRoute m r x p = Routes $ modify ((Route m r (Pack p x)):)---- | Specialisation of 'addRoute' for a specific HTTP 'Method'.-get, head, post, put, delete, trace, options, connect ::-    (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)-    => ByteString        -- ^ path-    -> (TVal p -> m ())  -- ^ handler-    -> p                 -- ^ 'Predicate'-    -> Routes m ()-get     = addRoute GET-head    = addRoute HEAD-post    = addRoute POST-put     = addRoute PUT-delete  = addRoute DELETE-trace   = addRoute TRACE-options = addRoute OPTIONS-connect = addRoute CONNECT---- | Specialisation of 'addRoute' for a specific HTTP 'Method' taking--- no 'Predicate' into consideration.-get_, head_, post_, put_, delete_, trace_, options_, connect_ ::-    (MonadSnap m)-    => ByteString    -- ^ path-    -> (() -> m ())  -- ^ handler-    -> Routes m ()-get_     p h = addRoute GET     p h (Const ())-head_    p h = addRoute HEAD    p h (Const ())-post_    p h = addRoute POST    p h (Const ())-put_     p h = addRoute PUT     p h (Const ())-delete_  p h = addRoute DELETE  p h (Const ())-trace_   p h = addRoute TRACE   p h (Const ())-options_ p h = addRoute OPTIONS p h (Const ())-connect_ p h = addRoute CONNECT p h (Const ())---- | Turn route definitions into a list of 'String's.-showRoutes :: Routes m () -> [String]-showRoutes (Routes routes) =-    flip map (concat . normalise $ execState routes []) $ \x ->-        case _pred x of-            Pack p _ -> shows (_method x)-                      . (' ':)-                      . shows (_path x)-                      . (' ':)-                      . shows p $ ""---- | Turn route definitions into \"snapable\" format, i.e.--- Routes are grouped per path and selection evaluates routes--- against the given Snap 'Request'.-expandRoutes :: MonadSnap m => Routes m () -> [(ByteString, m ())]-expandRoutes (Routes routes) =-    map (\g -> (_path (L.head g), select g)) (normalise $ execState routes [])---- | Group routes by path.-normalise :: [Route m] -> [[Route m]]-normalise rr =-    let rg    = grouped . sorted $ rr-        paths = map (namelessPath . L.head) rg-        ambig = paths \\ nub paths-    in if null ambig then rg else error (ambiguityMessage ambig)-  where-    sorted :: [Route m] -> [Route m]-    sorted = sortBy (\a b -> _path a `compare` _path b)--    grouped :: [Route m] -> [[Route m]]-    grouped = groupBy (\a b -> _path a == _path b)--    namelessPath :: Route m -> ByteString-    namelessPath =-        let colon = 0x3A-            slash = 0x2F-            fun s = if s /= "" && S.head s == colon then "<>" else s-        in S.intercalate "/" . map fun . S.split slash . _path--    ambiguityMessage a =-        "Paths differing only in variable names are not supported.\n"  ++-        "Problematic paths (with variable positions denoted by <>):\n" ++-        (show a)--data Handler m = Handler-  { _delta   :: !Delta-  , _handler :: !(m ())-  }---- The handler selection proceeds as follows:--- (1) Consider only handlers with matching methods, or else return 405.--- (2) Evaluate 'Route' predicates.--- (3) Pick the first one which is 'Good', or else respond with status---     and message of the first one.-select :: MonadSnap m => [Route m] -> m ()-select g = do-    ms <- filterM byMethod g-    if null ms-        then do-            respond (Error 405 Nothing)-            modifyResponse (setHeader "Allow" validMethods)-        else evalAll ms-  where-    byMethod :: MonadSnap m => Route m -> m Bool-    byMethod x = (_method x ==) <$> getsRequest rqMethod--    validMethods :: ByteString-    validMethods = S.intercalate "," $ nub (C.pack . show . _method <$> g)--    evalAll :: MonadSnap m => [Route m] -> m ()-    evalAll rs = do-        req <- getRequest-        let (n, y) = partitionEithers . snd $ foldl' (evalSingle req) (E.empty, []) rs-        if null y-            then respond (L.head n)-            else closest y--    evalSingle :: MonadSnap m => Request -> (Env, [Either Error (Handler m)]) -> Route m -> (Env, [Either Error (Handler m)])-    evalSingle rq (e, rs) r =-        case _pred r of-            Pack p h ->-                case runState (apply p rq) e of-                    (F   m, e') -> (e', Left m : rs)-                    (T d v, e') -> (e', Right (Handler d (h v)) : rs)--    closest :: MonadSnap m => [Handler m] -> m ()-    closest = foldl' (<|>) pass-            . map _handler-            . sortBy (\a b -> _delta a `compare` _delta b)--respond :: MonadSnap m => Error -> m ()-respond e = do-    putResponse . clearContentLength-                . setResponseCode (fromIntegral . _status $ e)-                $ emptyResponse-    maybe (return ()) writeBS (_message e)
test/TestSuite.hs view
@@ -2,14 +2,14 @@  import Test.Framework (defaultMain, testGroup) import qualified Tests.Data.Predicate as Predicate-import qualified Tests.Snap.Predicates as SnapPredicates-import qualified Tests.Snap.Routes as SnapRoutes+import qualified Tests.Snap.Predicate as SnapPredicate+import qualified Tests.Snap.Route     as SnapRoute  main :: IO () main = defaultMain tests   where     tests =-        [ testGroup "Tests.Data.Predicate"  Predicate.tests-        , testGroup "Tests.Snap.Predicates" SnapPredicates.tests-        , testGroup "Tests.Snap.Routes"     SnapRoutes.tests+        [ testGroup "Tests.Data.Predicate" Predicate.tests+        , testGroup "Tests.Snap.Predicate" SnapPredicate.tests+        , testGroup "Tests.Snap.Route"     SnapRoute.tests         ]
+ test/Tests/Snap/Predicate.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeFamilies #-}+module Tests.Snap.Predicate (tests) where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Data.ByteString (ByteString)+import Data.Predicate+import Snap.Predicate+import Snap.Test+import qualified Data.Map.Strict as M++tests :: [Test]+tests =+    [ testAccept+    , testParam+    , testParamOpt+    , testAcceptJson+    , testAcceptThrift+    ]++testAccept :: Test+testAccept = testCase "Accept Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "x/y"+    let predicate = Accept (Type "x") (SubType "y")+    let true = T 0 $ MediaType (Type "x") (SubType "y") 1.0 []+    assertEqual "Matching Accept" true (eval predicate rq0)++    rq1 <- buildRequest $ addHeader "Accept" "u/v"+    assertEqual "Status Code 406"+        (F (err 406 ("Expected 'Accept: \"x\"/\"y\"'.")))+        (eval predicate rq1)++testAcceptJson :: Test+testAcceptJson = testCase "AcceptJson Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "application/json"+    let predicate = Accept Application Json+    let true = T 0 $ MediaType Application Json 1.0 []+    assertEqual "Matching AcceptJson" true (eval predicate rq0)++    rq1 <- buildRequest $ addHeader "Accept" "foo/bar"+    assertEqual "Status Code 406"+        (F (err 406 ("Expected 'Accept: application/json'.")))+        (eval predicate rq1)++testAcceptThrift :: Test+testAcceptThrift = testCase "AcceptThrift Predicate" $ do+    rq0 <- buildRequest $ addHeader "Accept" "application/x-thrift"+    let predicate = Accept Application Thrift+    let true = T 0 $ MediaType Application Thrift 1.0 []+    assertEqual "Matching AcceptThrift" true (eval predicate rq0)++    rq1 <- buildRequest $ addHeader "Accept" "application/json"+    assertEqual "Status Code 406"+        (F (err 406 ("Expected 'Accept: application/x-thrift'.")))+        (eval predicate rq1)++testParam :: Test+testParam = testCase "Param Predicate" $ do+    rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])+    assertEqual "Matching Param" (T 0 "y") (eval (Param "x" :: Param ByteString) rq0)++    rq1 <- buildRequest $ get "/" M.empty+    assertEqual "Status Code 400"+        (F (err 400 ("Missing parameter 'x'.")))+        (eval (Param "x" :: Param ByteString) rq1)++testParamOpt :: Test+testParamOpt = testCase "ParamOpt Predicate" $ do+    rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])+    assertEqual "Matching Param 1" (T 0 (Just "y")) (eval (ParamOpt "x" :: ParamOpt ByteString) rq0)++    rq1 <- buildRequest $ get "/" M.empty+    assertEqual "Matching Param 2" (T 0 Nothing) (eval (ParamOpt "x" :: ParamOpt ByteString) rq1)
− test/Tests/Snap/Predicates.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeFamilies #-}-module Tests.Snap.Predicates (tests) where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)-import Data.ByteString (ByteString)-import Data.Predicate-import Snap.Predicates-import Snap.Test-import qualified Data.Map.Strict as M--tests :: [Test]-tests =-    [ testAccept-    , testParam-    , testParamOpt-    , testAcceptJson-    , testAcceptThrift-    ]--testAccept :: Test-testAccept = testCase "Accept Predicate" $ do-    rq0 <- buildRequest $ addHeader "Accept" "x/y"-    let predicate = Accept (Type "x") (SubType "y")-    let true = T 0 $ MediaType (Type "x") (SubType "y") 1.0 []-    assertEqual "Matching Accept" true (eval predicate rq0)--    rq1 <- buildRequest $ addHeader "Accept" "u/v"-    assertEqual "Status Code 406"-        (F (err 406 ("Expected 'Accept: \"x\"/\"y\"'.")))-        (eval predicate rq1)--testAcceptJson :: Test-testAcceptJson = testCase "AcceptJson Predicate" $ do-    rq0 <- buildRequest $ addHeader "Accept" "application/json"-    let predicate = Accept Application Json-    let true = T 0 $ MediaType Application Json 1.0 []-    assertEqual "Matching AcceptJson" true (eval predicate rq0)--    rq1 <- buildRequest $ addHeader "Accept" "foo/bar"-    assertEqual "Status Code 406"-        (F (err 406 ("Expected 'Accept: application/json'.")))-        (eval predicate rq1)--testAcceptThrift :: Test-testAcceptThrift = testCase "AcceptThrift Predicate" $ do-    rq0 <- buildRequest $ addHeader "Accept" "application/x-thrift"-    let predicate = Accept Application Thrift-    let true = T 0 $ MediaType Application Thrift 1.0 []-    assertEqual "Matching AcceptThrift" true (eval predicate rq0)--    rq1 <- buildRequest $ addHeader "Accept" "application/json"-    assertEqual "Status Code 406"-        (F (err 406 ("Expected 'Accept: application/x-thrift'.")))-        (eval predicate rq1)--testParam :: Test-testParam = testCase "Param Predicate" $ do-    rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])-    assertEqual "Matching Param" (T 0 "y") (eval (Param "x" :: Param ByteString) rq0)--    rq1 <- buildRequest $ get "/" M.empty-    assertEqual "Status Code 400"-        (F (err 400 ("Missing parameter 'x'.")))-        (eval (Param "x" :: Param ByteString) rq1)--testParamOpt :: Test-testParamOpt = testCase "ParamOpt Predicate" $ do-    rq0 <- buildRequest $ get "/" (M.fromList [("x", ["y", "z"])])-    assertEqual "Matching Param 1" (T 0 (Just "y")) (eval (ParamOpt "x" :: ParamOpt ByteString) rq0)--    rq1 <- buildRequest $ get "/" M.empty-    assertEqual "Matching Param 2" (T 0 Nothing) (eval (ParamOpt "x" :: ParamOpt ByteString) rq1)
+ test/Tests/Snap/Route.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings, TypeOperators #-}+module Tests.Snap.Route (tests) where++import Control.Applicative hiding (Const)+import Control.Monad.IO.Class+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Data.ByteString (ByteString)+import Data.Predicate+import Data.String+import Snap.Core+import Snap.Predicate hiding (Text)+import Snap.Predicate.Types+import Snap.Route+import qualified Snap.Test       as T+import qualified Data.Map.Strict as M+import qualified Data.Text       as Text++tests :: [Test]+tests =+    [ testSitemap+    , testMedia+    ]++testSitemap :: Test+testSitemap = testCase "Sitemap" $ do+    let routes  = expandRoutes sitemap+    let handler = route routes+    assertEqual "Endpoints" ["/a", "/b", "/c", "/d", "/e", "/f", "/z"] (map fst routes)+    testEndpointA handler+    testEndpointB handler+    testEndpointC handler+    testEndpointD handler+    testEndpointE handler+    testEndpointF handler++sitemap :: Routes Snap ()+sitemap = do+    get "/a" handlerA+        (Accept Application Json :&: (Param "name" :|: Param "nick") :&: Param "foo")++    get "/b" handlerB+        (Param "baz")++    get "/c" handlerC+        (ParamOpt "foo")++    get "/d" handlerD+        (ParamDef "foo" 0)++    get "/e" handlerE+        (HdrDef "foo" 0)++    get "/f" handlerF+        (Param "foo")++    get "/z" handlerZ+        (Fail (err 410 "Gone."))++handlerA :: MediaType Application Json :*: Int :*: ByteString -> Snap ()+handlerA (_ :*: i :*: _) = writeText (fromString . show $ i)++handlerB :: Int -> Snap ()+handlerB baz = writeText (Text.pack . show $ baz)++handlerC :: Maybe Int -> Snap ()+handlerC foo = writeText (Text.pack . show $ foo)++handlerD :: Int -> Snap ()+handlerD foo = writeText (Text.pack . show $ foo)++handlerE :: Int -> Snap ()+handlerE foo = writeText (Text.pack . show $ foo)++handlerF :: CSV Int -> Snap ()+handlerF foo = writeText (Text.pack . show . sum . list $ foo)++handlerZ :: MediaType Application Json -> Snap ()+handlerZ _ = do+    rq <- getRequest+    with (Param "bar" :&: Param "baz") rq $ \(bar :*: baz) -> do+        writeBS bar+        writeBS baz++testEndpointA :: Snap () -> Assertion+testEndpointA m = do+    let rq0 = T.get "/a" M.empty >> T.addHeader "Accept" "foo/bar"+    st0 <- rspStatus <$> T.runHandler rq0 m+    assertEqual "Accept fails" 406 st0++    let rq1 = rq0 >> T.addHeader "Accept" "application/json"+    st1 <- rspStatus <$> T.runHandler rq1 m+    assertEqual "Param fails" 400 st1++    let rq2 = T.get "/a" (M.fromList [("name", ["x"])]) >>+              T.addHeader "Accept" "application/json"+    st2 <- rspStatus <$> T.runHandler rq2 m+    assertEqual "Param fails" 400 st2++    let rq3 = T.get "/a" (M.fromList [("name", ["123"]), ("foo", ["\"y\""])]) >>+              T.addHeader "Accept" "application/json"+    T.runHandler rq3 m >>= T.assertSuccess++testEndpointB :: Snap () -> Assertion+testEndpointB m = do+    rs0 <- T.runHandler (T.get "/b" M.empty) m+    bd0 <- T.getResponseBody rs0+    assertEqual "b. baz 1" 400 (rspStatus rs0)+    assertEqual "b. baz 2" "Missing parameter 'baz'." bd0++    rs1 <- T.runHandler (T.get "/b" $ M.fromList [("baz", ["abc"])]) m+    bd1 <- T.getResponseBody rs1+    assertEqual "b. baz 3" 400 (rspStatus rs1)+    assertEqual "b. baz 4" "no read" bd1++    rs2 <- T.runHandler (T.get "/b" $ M.fromList [("baz", ["abc", "123"])]) m+    bd2 <- T.getResponseBody rs2+    assertEqual "b. baz 5" 200 (rspStatus rs2)+    assertEqual "b. baz 6" "123" bd2++testEndpointC :: Snap () -> Assertion+testEndpointC m = do+    rs0 <- T.runHandler (T.get "/c" M.empty) m+    bd0 <- T.getResponseBody rs0+    assertEqual "c. foo 1" 200 (rspStatus rs0)+    assertEqual "c. foo 2" "Nothing" bd0++    rs1 <- T.runHandler (T.get "/c" $ M.fromList [("foo", ["abc", "123"])]) m+    bd1 <- T.getResponseBody rs1+    assertEqual "c. foo 3" 200 (rspStatus rs1)+    assertEqual "c. foo 4" "Just 123" bd1++    rs2 <- T.runHandler (T.get "/c" $ M.fromList [("foo", ["abc"])]) m+    bd2 <- T.getResponseBody rs2+    assertEqual "c. foo 5" 400 (rspStatus rs2)+    assertEqual "c. foo 6" "no read" bd2++testEndpointD :: Snap () -> Assertion+testEndpointD m = do+    rs0 <- T.runHandler (T.get "/d" M.empty) m+    bd0 <- T.getResponseBody rs0+    assertEqual "d. foo 1" 200 (rspStatus rs0)+    assertEqual "d. foo 2" "0" bd0++    rs1 <- T.runHandler (T.get "/d" $ M.fromList [("foo", ["xxx", "42"])]) m+    bd1 <- T.getResponseBody rs1+    assertEqual "d. foo 3" 200 (rspStatus rs1)+    assertEqual "d. foo 4" "42" bd1++    rs2 <- T.runHandler (T.get "/d" $ M.fromList [("foo", ["yyy"])]) m+    bd2 <- T.getResponseBody rs2+    assertEqual "d. foo 5" 400 (rspStatus rs2)+    assertEqual "d. foo 6" "no read" bd2++testEndpointE :: Snap () -> Assertion+testEndpointE m = do+    rs0 <- T.runHandler (T.get "/e" M.empty) m+    bd0 <- T.getResponseBody rs0+    assertEqual "e. foo 1" 200 (rspStatus rs0)+    assertEqual "e. foo 2" "0" bd0++    rs1 <- T.runHandler (T.get "/e" M.empty >> T.addHeader "foo" "42") m+    bd1 <- T.getResponseBody rs1+    assertEqual "e. foo 3" 200 (rspStatus rs1)+    assertEqual "e. foo 4" "42" bd1++    rs2 <- T.runHandler (T.get "/e" M.empty >> T.addHeader "foo" "abc") m+    bd2 <- T.getResponseBody rs2+    assertEqual "e. foo 5" 400 (rspStatus rs2)+    assertEqual "e. foo 6" "no read" bd2++testEndpointF :: Snap () -> Assertion+testEndpointF m = do+    rs0 <- T.runHandler (T.get "/f" $ M.fromList [("foo", ["1,2,3,4"])]) m+    bd0 <- T.getResponseBody rs0+    assertEqual "e. foo 1" 200 (rspStatus rs0)+    assertEqual "e. foo 2" "10" bd0++-- Media Selection Tests:++testMedia :: Test+testMedia = testCase "Media Selection" $ do+    let [(_, h)] = expandRoutes sitemapMedia+    expectMedia "application/json;q=0.3, application/x-thrift;q=0.7" "application/x-thrift" h+    expectMedia "application/json;q=0.7, application/x-thrift;q=0.3" "application/json" h++sitemapMedia :: Routes Snap ()+sitemapMedia = do+    get "/media" handlerJson   $ Accept Application Json+    get "/media" handlerThrift $ Accept Application Thrift++handlerJson :: MediaType Application Json -> Snap ()+handlerJson _ = writeBS "application/json"++handlerThrift :: MediaType Application Thrift -> Snap ()+handlerThrift _ = writeBS "application/x-thrift"++expectMedia :: ByteString -> ByteString -> Snap () -> Assertion+expectMedia hdr res m = do+    let rq0 = T.get "/media" M.empty >>+              T.addHeader "Accept" hdr+    txt0 <- T.runHandler rq0 m >>= liftIO . T.getResponseBody+    assertEqual "media type" res txt0
− test/Tests/Snap/Routes.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeOperators #-}-module Tests.Snap.Routes (tests) where--import Control.Applicative hiding (Const)-import Control.Monad.IO.Class-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)-import Data.ByteString (ByteString)-import Data.Either-import Data.Predicate-import Data.String-import Data.Text (Text, strip)-import Data.Text.Encoding-import Snap.Core-import Snap.Predicates hiding (Text)-import Snap.Routes-import qualified Snap.Test as T-import qualified Data.Map.Strict as M-import qualified Data.Text as Text--tests :: [Test]-tests =-    [ testSitemap-    , testMedia-    ]--testSitemap :: Test-testSitemap = testCase "Sitemap" $ do-    let routes = expandRoutes sitemap-    assertEqual "Endpoints" ["/a", "/b", "/c", "/d", "/e"] (map fst routes)-    mapM_ (\(r, h) -> h r) (zip (map snd routes) [testEndpointA])--sitemap :: Routes Snap ()-sitemap = do-    get "/a" handlerA $-        Accept Application Json :&: (Param "name" :|: Param "nick") :&: Param "foo"--    get "/b" handlerB $-        Accept Application Json :&: (Param "name" :||: Param "nick") :&: Param "foo"--    get "/c" handlerC $ Fail (err 410 "Gone.")--    post "/d" handlerD $ Accept Application Json :&: Parameter "foo" decode Nothing--    get "/e" handlerE $ (Param "foo" :|: Const 0) :&: ParamOpt "bar"-  where-    decode bs =-        let txt = rights (map decodeUtf8' bs)-        in if null txt-               then Left "UTF-8 decoding error"-               else Right (map strip txt)--handlerA :: MediaType Application Json :*: Int :*: ByteString -> Snap ()-handlerA (_ :*: i :*: _) = writeText (fromString . show $ i)--handlerB :: MediaType Application Json :*: (ByteString :+: ByteString) :*: ByteString -> Snap ()-handlerB (_ :*: name :*: _) =-    case name of-        Left  _ -> return ()-        Right _ -> return ()--handlerC :: MediaType Application Json -> Snap ()-handlerC _ = do-    rq <- getRequest-    with (Param "bar" :&: Param "baz") rq $ \(bar :*: baz) -> do-        writeBS bar-        writeBS baz--handlerD :: MediaType Application Json :*: [Text] -> Snap ()-handlerD (_ :*: txt) = writeText $ Text.intercalate ", " txt--handlerE :: Int :*: Maybe ByteString -> Snap ()-handlerE (foo :*: Just bar) = writeText (Text.pack . show $ foo) >> writeBS bar-handlerE (_   :*: Nothing)  = return ()--testEndpointA :: Snap () -> Assertion-testEndpointA m = do-    let rq0 = T.get "/a" M.empty >> T.addHeader "Accept" "foo/bar"-    st0 <- rspStatus <$> T.runHandler rq0 m-    assertEqual "Accept fails" 406 st0--    let rq1 = rq0 >> T.addHeader "Accept" "application/json"-    st1 <- rspStatus <$> T.runHandler rq1 m-    assertEqual "Param fails" 400 st1--    let rq2 = T.get "/a" (M.fromList [("name", ["x"])]) >>-              T.addHeader "Accept" "application/json"-    st2 <- rspStatus <$> T.runHandler rq2 m-    assertEqual "Param fails" 400 st2--    let rq3 = T.get "/a" (M.fromList [("name", ["123"]), ("foo", ["y"])]) >>-              T.addHeader "Accept" "application/json"-    T.runHandler rq3 m >>= T.assertSuccess---- Media Selection Tests:--testMedia :: Test-testMedia = testCase "Media Selection" $ do-    let [(_, h)] = expandRoutes sitemapMedia-    expectMedia "application/json;q=0.3, application/x-thrift;q=0.7" "application/x-thrift" h-    expectMedia "application/json;q=0.7, application/x-thrift;q=0.3" "application/json" h--sitemapMedia :: Routes Snap ()-sitemapMedia = do-    get "/media" handlerJson   $ Accept Application Json-    get "/media" handlerThrift $ Accept Application Thrift--handlerJson :: MediaType Application Json -> Snap ()-handlerJson _ = writeBS "application/json"--handlerThrift :: MediaType Application Thrift -> Snap ()-handlerThrift _ = writeBS "application/x-thrift"--expectMedia :: ByteString -> ByteString -> Snap () -> Assertion-expectMedia hdr res m = do-    let rq0 = T.get "/media" M.empty >>-              T.addHeader "Accept" hdr-    txt0 <- T.runHandler rq0 m >>= liftIO . T.getResponseBody-    assertEqual "media type" res txt0