{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Predicate
    ( module Data.Predicate
    , request

    , def
    , opt

    , query
    , hasQuery

    , header
    , hasHeader

    , segment
    , hasSegment

    , cookie
    , hasCookie

    , accept
    , contentType

    , fromVault

    , module Network.Wai.Predicate.MediaType
    , module Network.Wai.Predicate.Error
    ) where

import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.ByteString.Conversion
import Data.CaseInsensitive (original)
import Data.List (find)
import Data.Maybe (isNothing)
import Data.Predicate
import Data.Vault.Lazy (Key)
import Data.Word
import Network.HTTP.Types
import Network.Wai.Predicate.Accept
import Network.Wai.Predicate.Content
import Network.Wai.Predicate.Error
import Network.Wai.Predicate.MediaType
import Network.Wai.Predicate.Request
import Network.Wai.Predicate.Utility
import Network.Wai
import Prelude

import qualified Data.Vault.Lazy as Vault

def :: a -> Predicate r Error a -> Predicate r Error a
def :: a -> Predicate r Error a -> Predicate r Error a
def a
a = (Result Error a -> Result Error a)
-> Predicate r Error a -> Predicate r Error a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Result Error a -> Result Error a)
 -> Predicate r Error a -> Predicate r Error a)
-> (Result Error a -> Result Error a)
-> Predicate r Error a
-> Predicate r Error a
forall a b. (a -> b) -> a -> b
$
    (Error -> Result Error a)
-> (Double -> a -> Result Error a)
-> Result Error a
-> Result Error a
forall f a t. (f -> a) -> (Double -> t -> a) -> Result f t -> a
result (\Error
e -> if Bool -> Bool
not (Reason
TypeError Reason -> Error -> Bool
`isReasonOf` Error
e) then a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a else Error -> Result Error a
forall f t. f -> Result f t
Fail Error
e)
           Double -> a -> Result Error a
forall f t. Double -> t -> Result f t
Okay

opt :: Predicate r Error a -> Predicate r Error (Maybe a)
opt :: Predicate r Error a -> Predicate r Error (Maybe a)
opt = (Result Error a -> Result Error (Maybe a))
-> Predicate r Error a -> Predicate r Error (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Result Error a -> Result Error (Maybe a))
 -> Predicate r Error a -> Predicate r Error (Maybe a))
-> (Result Error a -> Result Error (Maybe a))
-> Predicate r Error a
-> Predicate r Error (Maybe a)
forall a b. (a -> b) -> a -> b
$
    (Error -> Result Error (Maybe a))
-> (Double -> a -> Result Error (Maybe a))
-> Result Error a
-> Result Error (Maybe a)
forall f a t. (f -> a) -> (Double -> t -> a) -> Result f t -> a
result (\Error
e -> if Bool -> Bool
not (Reason
TypeError Reason -> Error -> Bool
`isReasonOf` Error
e) then Maybe a -> Result Error (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing else Error -> Result Error (Maybe a)
forall f t. f -> Result f t
Fail Error
e)
           (\Double
d -> Double -> Maybe a -> Result Error (Maybe a)
forall f t. Double -> t -> Result f t
Okay Double
d (Maybe a -> Result Error (Maybe a))
-> (a -> Maybe a) -> a -> Result Error (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)

request :: HasRequest r => Predicate r f Request
request :: Predicate r f Request
request = Request -> Result f Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Result f Request)
-> (r -> Request) -> Predicate r f Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Request
forall a. HasRequest a => a -> Request
getRequest

query :: (HasQuery r, FromByteString a) => ByteString -> Predicate r Error a
query :: ByteString -> Predicate r Error a
query ByteString
k r
r =
    case ByteString -> r -> [ByteString]
forall r. HasQuery r => ByteString -> r -> [ByteString]
lookupQuery ByteString
k r
r of
        [] -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (Error -> Error) -> Error -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"query" (Error -> Result Error a) -> Error -> Result Error a
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable ByteString
k
        [ByteString]
qq -> (ByteString -> Result Error a)
-> (a -> Result Error a) -> Either ByteString a -> Result Error a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (ByteString -> Error) -> ByteString -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"query" (Error -> Error) -> (ByteString -> Error) -> ByteString -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Error
typeError ByteString
k)
                     a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return
                     ([ByteString] -> Either ByteString a
forall a. FromByteString a => [ByteString] -> Either ByteString a
readValues [ByteString]
qq)

hasQuery :: HasQuery r => ByteString -> Predicate r Error ()
hasQuery :: ByteString -> Predicate r Error ()
hasQuery ByteString
k r
r =
    Bool -> Result Error () -> Result Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ByteString -> r -> [ByteString]
forall r. HasQuery r => ByteString -> r -> [ByteString]
lookupQuery ByteString
k r
r)) (Result Error () -> Result Error ())
-> Result Error () -> Result Error ()
forall a b. (a -> b) -> a -> b
$
        (Error -> Result Error ()
forall f t. f -> Result f t
Fail (Error -> Result Error ())
-> (Error -> Error) -> Error -> Result Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"query" (Error -> Result Error ()) -> Error -> Result Error ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable ByteString
k)

header :: (HasHeaders r, FromByteString a) => HeaderName -> Predicate r Error a
header :: HeaderName -> Predicate r Error a
header HeaderName
k r
r =
    case HeaderName -> r -> [ByteString]
forall r. HasHeaders r => HeaderName -> r -> [ByteString]
lookupHeader HeaderName
k r
r of
        [] -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (Error -> Error) -> Error -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"header" (Error -> Result Error a) -> Error -> Result Error a
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable (HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
k)
        [ByteString]
hh -> (ByteString -> Result Error a)
-> (a -> Result Error a) -> Either ByteString a -> Result Error a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (ByteString -> Error) -> ByteString -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"header" (Error -> Error) -> (ByteString -> Error) -> ByteString -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Error
typeError (HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
k))
                     a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return
                     ([ByteString] -> Either ByteString a
forall a. FromByteString a => [ByteString] -> Either ByteString a
readValues [ByteString]
hh)

hasHeader :: HasHeaders r => HeaderName -> Predicate r Error ()
hasHeader :: HeaderName -> Predicate r Error ()
hasHeader HeaderName
k r
r =
    Bool -> Result Error () -> Result Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (HeaderName, ByteString) -> Bool
forall a. Maybe a -> Bool
isNothing (((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
==) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (r -> [(HeaderName, ByteString)]
forall a. HasHeaders a => a -> [(HeaderName, ByteString)]
headers r
r))) (Result Error () -> Result Error ())
-> Result Error () -> Result Error ()
forall a b. (a -> b) -> a -> b
$
        (Error -> Result Error ()
forall f t. f -> Result f t
Fail (Error -> Result Error ())
-> (Error -> Error) -> Error -> Result Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"header" (Error -> Result Error ()) -> Error -> Result Error ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable (HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
k))

segment :: (HasPath r, FromByteString a) => Word -> Predicate r Error a
segment :: Word -> Predicate r Error a
segment Word
i r
r =
    case Word -> r -> Maybe ByteString
forall r. HasPath r => Word -> r -> Maybe ByteString
lookupSegment Word
i r
r of
        Maybe ByteString
Nothing -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a) -> Error -> Result Error a
forall a b. (a -> b) -> a -> b
$
            Error
e400 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& ByteString -> Error -> Error
setMessage ByteString
"Path segment index out of bounds."
                 (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"path"
        Just  ByteString
s -> (ByteString -> Result Error a)
-> (a -> Result Error a) -> Either ByteString a -> Result Error a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ByteString
m -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error
e400 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& ByteString -> Error -> Error
addLabel ByteString
"path" (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reason -> Error -> Error
setReason Reason
TypeError (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setMessage ByteString
m))
                          a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return
                          ([ByteString] -> Either ByteString a
forall a. FromByteString a => [ByteString] -> Either ByteString a
readValues [ByteString
s])

hasSegment :: HasPath r => Word -> Predicate r Error ()
hasSegment :: Word -> Predicate r Error ()
hasSegment Word
i r
r =
    Bool -> Result Error () -> Result Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (Word -> r -> Maybe ByteString
forall r. HasPath r => Word -> r -> Maybe ByteString
lookupSegment Word
i r
r)) (Result Error () -> Result Error ())
-> Result Error () -> Result Error ()
forall a b. (a -> b) -> a -> b
$
        Error -> Result Error ()
forall f t. f -> Result f t
Fail (Error
e400 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& ByteString -> Error -> Error
addLabel ByteString
"path" (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setMessage ByteString
"Path segment index out of bounds.")

cookie :: (HasCookies r, FromByteString a) => ByteString -> Predicate r Error a
cookie :: ByteString -> Predicate r Error a
cookie ByteString
k r
r =
    case ByteString -> r -> [ByteString]
forall r. HasCookies r => ByteString -> r -> [ByteString]
lookupCookie ByteString
k r
r of
        [] -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (Error -> Error) -> Error -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"cookie" (Error -> Result Error a) -> Error -> Result Error a
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable ByteString
k
        [ByteString]
cc -> (ByteString -> Result Error a)
-> (a -> Result Error a) -> Either ByteString a -> Result Error a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a)
-> (ByteString -> Error) -> ByteString -> Result Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"cookie" (Error -> Error) -> (ByteString -> Error) -> ByteString -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Error
typeError ByteString
k)
                     a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return
                     ([ByteString] -> Either ByteString a
forall a. FromByteString a => [ByteString] -> Either ByteString a
readValues [ByteString]
cc)

hasCookie :: HasCookies r => ByteString -> Predicate r Error ()
hasCookie :: ByteString -> Predicate r Error ()
hasCookie ByteString
k r
r =
    Bool -> Result Error () -> Result Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ByteString -> r -> [ByteString]
forall r. HasCookies r => ByteString -> r -> [ByteString]
lookupCookie ByteString
k r
r)) (Result Error () -> Result Error ())
-> Result Error () -> Result Error ()
forall a b. (a -> b) -> a -> b
$
        (Error -> Result Error ()
forall f t. f -> Result f t
Fail (Error -> Result Error ())
-> (Error -> Error) -> Error -> Result Error ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"cookie" (Error -> Result Error ()) -> Error -> Result Error ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error
notAvailable ByteString
k)

fromVault :: HasVault r => Key a -> Predicate r Error a
fromVault :: Key a -> Predicate r Error a
fromVault Key a
k r
r =
    case Key a -> Vault -> Maybe a
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key a
k (r -> Vault
forall a. HasVault a => a -> Vault
requestVault r
r) of
        Just  a
a -> a -> Result Error a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Maybe a
Nothing -> Error -> Result Error a
forall f t. f -> Result f t
Fail (Error -> Result Error a) -> Error -> Result Error a
forall a b. (a -> b) -> a -> b
$
            Error
e500 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Reason -> Error -> Error
setReason Reason
NotAvailable
                 (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setMessage ByteString
"Vault does not contain key."
                 (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
addLabel ByteString
"vault"

-----------------------------------------------------------------------------
-- Internal

notAvailable :: ByteString -> Error
notAvailable :: ByteString -> Error
notAvailable ByteString
k = Error
e400 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Reason -> Error -> Error
setReason Reason
NotAvailable (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setSource ByteString
k
{-# INLINE notAvailable #-}

typeError :: ByteString -> ByteString -> Error
typeError :: ByteString -> ByteString -> Error
typeError ByteString
k ByteString
m = Error
e400 Error -> (Error -> Error) -> Error
forall a b. a -> (a -> b) -> b
& Reason -> Error -> Error
setReason Reason
TypeError (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setSource ByteString
k (Error -> Error) -> (Error -> Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Error -> Error
setMessage ByteString
m
{-# INLINE typeError #-}