wai-predicates 0.5 → 0.6

raw patch · 9 files changed

+158/−82 lines, 9 filesdep ~bytestring-fromPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring-from

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• src/Data/Predicate.hs +0/−29
• src/Network/Wai/Predicate.hs +72/−34
• src/Network/Wai/Predicate/Accept.hs +3/−3
• src/Network/Wai/Predicate/Content.hs +3/−3
• src/Network/Wai/Predicate/Error.hs +57/−5
• src/Network/Wai/Predicate/Utility.hs +5/−1
• test/Tests/Wai/Predicate.hs +9/−5
• wai-predicates.cabal +2/−2

@@ -1,3 +1,10 @@+0.6+-----------------------------------------------------------------------------+- Move `def` and `opt` from `Data.Predicate` to `Network.Wai.Predicate` and+  make both specific to `Predicate r Error t`.+- Remove `mapOkay` and `mapFail`.+- Update `bytestring-from` dependency.+ 0.5 ----------------------------------------------------------------------------- - Update dependencies constraints.

@@ -17,10 +17,6 @@     , (.&.)     , (.|.)     , (|||)-    , opt-    , def-    , mapOkay-    , mapFail     , exec     -- * Result     , module Data.Predicate.Result@@ -108,31 +104,6 @@ -- | Alias of 'orElse'. (|||) :: Predicate a f t -> Predicate a f t' -> Predicate a f (Either t t') (|||) = orElse---- | Like 'fmap', but only maps the @Okay@ metadata to another result.-mapOkay :: (t -> Result f t') -> Predicate a f t -> Predicate a f t'-mapOkay f p a =-    case p a of-        Okay _ x -> f x-        Fail   x -> Fail x---- | Like 'mapOkay', but for the @Fail@ case.-mapFail :: (f -> Result f' t) -> Predicate a f t -> Predicate a f' t-mapFail f p a =-    case p a of-        Fail   x -> f x-        Okay d x -> Okay d x---- | A predicate modifier which makes the given predicate optional,--- i.e. the @Okay@ metadata type becomes a 'Maybe' and in the failure-case--- 'Nothing' is returned.-opt :: Predicate a f t -> Predicate a f (Maybe t)-opt = fmap (result (const $ return Nothing) (\d x -> Okay d (Just x)))---- | A predicate modifier which returns as @Okay@ metadata the provided default--- value if the given predicate fails.-def :: t -> Predicate a f t -> Predicate a f t-def t = fmap (result (const $ return t) Okay)  exec :: Predicate a f t -> a -> (f -> b) -> (t -> b) -> b exec p a g f = case p a of

@@ -8,6 +8,9 @@     ( module Data.Predicate     , request +    , def+    , opt+     , query     , hasQuery @@ -29,12 +32,12 @@     , module Network.Wai.Predicate.Error     ) where +import Control.Monad (when) import Data.ByteString (ByteString) import Data.ByteString.From import Data.CaseInsensitive (original) import Data.List (find)-import Data.Monoid-import Data.Maybe (isJust)+import Data.Maybe (isNothing) import Data.Predicate import Data.Vault.Lazy (Key) import Data.Word@@ -49,55 +52,90 @@  import qualified Data.Vault.Lazy as Vault -request :: (HasRequest r) => Predicate r f Request+def :: a -> Predicate r Error a -> Predicate r Error a+def a = fmap $+    result (\e -> if not (TypeError `isReasonOf` e) then return a else Fail e)+           Okay++opt :: Predicate r Error a -> Predicate r Error (Maybe a)+opt = fmap $+    result (\e -> if not (TypeError `isReasonOf` e) then return Nothing else Fail e)+           (\d -> Okay d . Just)++request :: HasRequest r => Predicate r f Request request = return . getRequest  query :: (HasQuery r, FromByteString a) => ByteString -> Predicate r Error a-query k r = case lookupQuery k r of-    [] -> Fail (err status400 ("Missing query '" <> k <> "'."))-    qq -> either (Fail . err status400) return (readValues qq)+query k r =+    case lookupQuery k r of+        [] -> Fail . addLabel "query" $ notAvailable k+        qq -> either (Fail . addLabel "query" . typeError k)+                     return+                     (readValues qq) -hasQuery :: (HasQuery r) => ByteString -> Predicate r Error ()+hasQuery :: HasQuery r => ByteString -> Predicate r Error () hasQuery k r =-    if null (lookupQuery k r)-        then Fail (err status400 ("Missing query '" <> k <> "'."))-        else return ()+    when (null (lookupQuery k r)) $+        (Fail . addLabel "query" $ notAvailable k)  header :: (HasHeaders r, FromByteString a) => HeaderName -> Predicate r Error a-header k r = case lookupHeader k r of-    [] -> Fail (err status400 ("Missing header '" <> original k <> "'."))-    hh -> either (Fail . err status400) return (readValues hh)+header k r =+    case lookupHeader k r of+        [] -> Fail . addLabel "header" $ notAvailable (original k)+        hh -> either (Fail . addLabel "header" . typeError (original k))+                     return+                     (readValues hh) -hasHeader :: (HasHeaders r) => HeaderName -> Predicate r Error ()+hasHeader :: HasHeaders r => HeaderName -> Predicate r Error () hasHeader k r =-    if isJust $ find ((k ==) . fst) (headers r)-        then return ()-        else Fail (err status400 ("Missing header '" <> original k <> "'."))+    when (isNothing (find ((k ==) . fst) (headers r))) $+        (Fail . addLabel "header" $ notAvailable (original k))  segment :: (HasPath r, FromByteString a) => Word -> Predicate r Error a-segment i r = case lookupSegment i r of-    Nothing -> Fail (err status400 "Path segment index out of bounds.")-    Just  s -> either (Fail . err status400) return (readValues [s])+segment i r =+    case lookupSegment i r of+        Nothing -> Fail $+            e400 & setMessage "Path segment index out of bounds."+                 . addLabel "path"+        Just  s -> either (\m -> Fail (e400 & addLabel "path" . setReason TypeError . setMessage m))+                          return+                          (readValues [s]) -hasSegment :: (HasPath r) => Word -> Predicate r Error ()+hasSegment :: HasPath r => Word -> Predicate r Error () hasSegment i r =-    if isJust $ lookupSegment i r-        then return ()-        else Fail (err status400 "Path segment index out of bounds.")+    when (isNothing (lookupSegment i r)) $+        Fail (e400 & addLabel "path" . setMessage "Path segment index out of bounds.")  cookie :: (HasCookies r, FromByteString a) => ByteString -> Predicate r Error a-cookie k r = case lookupCookie k r of-    [] -> Fail (err status400 ("Missing cookie '" <> k <> "'."))-    cc -> either (Fail . err status400) return (readValues cc)+cookie k r =+    case lookupCookie k r of+        [] -> Fail . addLabel "cookie" $ notAvailable k+        cc -> either (Fail . addLabel "cookie" . typeError k)+                     return+                     (readValues cc) -hasCookie :: (HasCookies r) => ByteString -> Predicate r Error ()+hasCookie :: HasCookies r => ByteString -> Predicate r Error () hasCookie k r =-    if null (lookupCookie k r)-        then Fail (err status400 ("Missing cookie '" <> k <> "'."))-        else return ()+    when (null (lookupCookie k r)) $+        (Fail . addLabel "cookie" $ notAvailable k)  fromVault :: HasVault r => Key a -> Predicate r Error a-fromVault k r = case Vault.lookup k (requestVault r) of-    Nothing -> Fail (err status500 "Vault does not contain key.")-    Just  a -> return a+fromVault k r =+    case Vault.lookup k (requestVault r) of+        Just  a -> return a+        Nothing -> Fail $+            e500 & setReason NotAvailable+                 . setMessage "Vault does not contain key."+                 . addLabel "vault"++-----------------------------------------------------------------------------+-- Internal++notAvailable :: ByteString -> Error+notAvailable k = e400 & setReason NotAvailable . setSource k+{-# INLINE notAvailable #-}++typeError :: ByteString -> ByteString -> Error+typeError k m = e400 & setReason TypeError . setSource k . setMessage m+{-# INLINE typeError #-} 

@@ -17,14 +17,14 @@ import Data.Maybe import Data.Predicate import Data.Singletons.TypeLits (Symbol)-import Network.HTTP.Types import Network.Wai.Predicate.Error import Network.Wai.Predicate.Request import Network.Wai.Predicate.MediaType+import Network.Wai.Predicate.Utility  import qualified Network.Wai.Predicate.Parser.MediaType as M -accept :: (HasHeaders r)+accept :: HasHeaders r        => ByteString        -> ByteString        -> Predicate r Error (Media (t :: Symbol) (s :: Symbol))@@ -34,7 +34,7 @@         then return (Media t s 1.0 [])         else case findMediaType t s mtypes of             m:_ -> Okay (1.0 - mediaQuality m) m-            []  -> Fail (err status406 msg)+            []  -> Fail (e406 & setMessage msg)       where         msg = "Expected 'Accept: " <> t <> "/" <> s <> "'." 

@@ -17,14 +17,14 @@ import Data.Predicate import Data.Singletons.TypeLits (Symbol) import Data.Maybe-import Network.HTTP.Types.Status import Network.Wai.Predicate.Error import Network.Wai.Predicate.MediaType import Network.Wai.Predicate.Request+import Network.Wai.Predicate.Utility  import qualified Network.Wai.Predicate.Parser.MediaType as M -contentType :: (HasHeaders r)+contentType :: HasHeaders r             => ByteString             -> ByteString             -> Predicate r Error (Media (t :: Symbol) (s :: Symbol))@@ -32,7 +32,7 @@     let mtypes = M.readMediaTypes "content-type" r in     case findContentType t s mtypes of         m:_ -> Okay (1.0 - mediaQuality m) m-        []  -> Fail (err status415 msg)+        []  -> Fail (e415 & setMessage msg)   where     msg = "Expected 'Content-Type: " <> t <> "/" <> s <> "'." 

@@ -2,18 +2,70 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -module Network.Wai.Predicate.Error where+module Network.Wai.Predicate.Error+    ( Error+    , Reason (..)+    , err+    , e400+    , e405+    , e406+    , e415+    , e500+    , status+    , message+    , reason+    , source+    , labels+    , setStatus+    , setMessage+    , setReason+    , setSource+    , addLabel+    , isReasonOf+    ) where  import Data.ByteString (ByteString) import Network.HTTP.Types.Status +data Reason+    = NotAvailable+    | TypeError+    deriving (Eq, Show)+ -- | The error type used as meta-data for @Fail@ in all WAI predicates. data Error = Error     { status  :: !Status          -- ^ HTTP status code     , message :: Maybe ByteString -- ^ optional status message+    , reason  :: Maybe Reason     -- ^ optional reason for this error+    , source  :: Maybe ByteString -- ^ optional source of this erro+    , labels  :: [ByteString]     -- ^ optional free-text labels     } deriving (Eq, Show) --- | Convenience function to construct 'Error' values from--- status code and body message.-err :: Status -> ByteString -> Error-err s = Error s . Just+err :: Status -> Error+err s = Error s Nothing Nothing Nothing []++setStatus :: Status -> Error -> Error+setStatus s e = e { status = s }++setMessage :: ByteString -> Error -> Error+setMessage m e = e { message = Just m }++setReason :: Reason -> Error -> Error+setReason r e = e { reason = Just r }++setSource :: ByteString -> Error -> Error+setSource s e = e { source = Just s }++addLabel :: ByteString -> Error -> Error+addLabel l e = e { labels = l : labels e }++isReasonOf :: Reason -> Error -> Bool+isReasonOf r e = maybe False (r ==) (reason e)++e400, e405, e406, e415, e500 :: Error+e400 = err status400+e405 = err status405+e406 = err status406+e415 = err status415+e500 = err status500+

@@ -4,7 +4,7 @@  {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Predicate.Utility (readValues) where+module Network.Wai.Predicate.Utility (readValues, (&)) where  import Data.ByteString (ByteString) import Data.ByteString.From@@ -18,3 +18,7 @@     res (Right x) _         = Right x     res _         (Left  x) = Left (fromString x) +infixl 1 &+(&) :: a -> (a -> b) -> b+a & f = f a+{-# INLINE (&) #-}

@@ -4,9 +4,9 @@ module Tests.Wai.Predicate (tests) where  import Data.ByteString (ByteString)-import Network.HTTP.Types.Status import Network.Wai.Predicate import Network.Wai.Predicate.Request+import Network.Wai.Predicate.Utility import Test.Tasty import Test.Tasty.HUnit import Tests.Wai.Util@@ -29,7 +29,8 @@     Okay 0 (Media "application" "json" 1.0 []) @=? (accept "application" "json") rq0      let rq1 = fromRequest . withHeader "Accept" "foo/bar" $ defRequest "/"-    Fail (err status406 ("Expected 'Accept: application/json'.")) @=? (accept "application" "json") rq1+    Fail (e406 & setMessage "Expected 'Accept: application/json'.")+        @=? (accept "application" "json") rq1  testAcceptThrift :: IO () testAcceptThrift = do@@ -37,7 +38,8 @@     Okay 0 (Media "application" "x-thrift" 1.0 []) @=? (accept "application" "x-thrift") rq0      let rq1 = fromRequest . json $ defRequest "/"-    Fail (err status406 ("Expected 'Accept: application/x-thrift'.")) @=? (accept "application" "x-thrift") rq1+    Fail (e406 & setMessage "Expected 'Accept: application/x-thrift'.")+        @=? (accept "application" "x-thrift") rq1  testAcceptAll :: IO () testAcceptAll = do@@ -51,7 +53,8 @@     Okay 0 (Media "text" "plain" 1.0 []) @=? (contentType "text" "plain") rq0      let rq1 = fromRequest . withHeader "Content-Type" "text/html" $ defRequest "/"-    Fail (err status415 ("Expected 'Content-Type: text/plain'.")) @=? (contentType "text" "plain") rq1+    Fail (e415 & setMessage "Expected 'Content-Type: text/plain'.")+        @=? (contentType "text" "plain") rq1  testContentTypeAll :: IO () testContentTypeAll = do@@ -64,7 +67,8 @@     Okay 0 ("y" :: ByteString) @=? (query "x") rq0      let rq1 = fromRequest $ defRequest "/"-    Fail (err status400 ("Missing query 'x'.")) @=? (query "x" :: Predicate Req Error ByteString) rq1+    Fail (e400 & setReason NotAvailable . setSource "x" . addLabel "query")+        @=? (query "x" :: Predicate Req Error ByteString) rq1  testQueryOpt :: IO () testQueryOpt = do

@@ -1,5 +1,5 @@ name:                wai-predicates-version:             0.5+version:             0.6 synopsis:            WAI request predicates license:             OtherLicense license-file:        LICENSE@@ -56,7 +56,7 @@         attoparsec       >= 0.10   && < 0.12       , base             == 4.*       , bytestring       >= 0.9    && < 0.11-      , bytestring-from  == 0.2.*+      , bytestring-from  >= 0.2    && < 0.4       , cookie           == 0.4.*       , case-insensitive >= 1.1    && < 1.3       , http-types       == 0.8.*