{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Linnet.Endpoints.Cookies
( cookie
, cookieMaybe
) where
import Control.Monad.Catch (MonadThrow, throwM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import Data.Text (append)
import qualified Data.Text.Encoding as TE
import Linnet.Decode
import Linnet.Endpoint
import Linnet.Endpoints.Entity
import Linnet.Errors
import Linnet.Input
import Linnet.Output
import Network.HTTP.Types (hCookie)
import Network.URI.Encode (decodeByteString)
import Network.Wai (requestHeaders)
findCookie :: B.ByteString -> B.ByteString -> Maybe B.ByteString
findCookie name cookies =
lookup name $
C8.split ';' cookies >>=
(\pairs ->
case C8.split '=' pairs of
[k, v] -> [(k, decodeByteString v)]
_ -> [])
cookie ::
forall a m. (DecodeEntity a, MonadThrow m)
=> B.ByteString
-> Endpoint m a
cookie name =
Endpoint
{ runEndpoint =
\input ->
let maybeCookie = (lookup hCookie . requestHeaders . request) input >>= findCookie name
output =
case maybeCookie of
Just val ->
case decodeEntity entity val of
Left err -> throwM err
Right v -> return $ ok v
_ -> throwM $ MissingEntity entity
in Matched {matchedReminder = input, matchedTrace = [], matchedOutput = output}
, toString = "cookie " `append` TE.decodeUtf8 name
}
where
entity = Cookie name
cookieMaybe ::
forall a m. (DecodeEntity a, MonadThrow m)
=> B.ByteString
-> Endpoint m (Maybe a)
cookieMaybe name =
Endpoint
{ runEndpoint =
\input ->
let maybeCookie = (lookup hCookie . requestHeaders . request) input >>= findCookie name
output =
case maybeCookie of
Just val ->
case decodeEntity entity val of
Left err -> throwM err
Right v -> return $ ok (Just v)
_ -> return $ ok Nothing
in Matched {matchedReminder = input, matchedTrace = [], matchedOutput = output}
, toString = "cookieMaybe " `append` TE.decodeUtf8 name
}
where
entity = Header name