{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
module Yesod.Core.Internal.Response where

import           Data.ByteString              (ByteString)
import qualified Data.ByteString              as S
import qualified Data.ByteString.Char8        as S8
import qualified Data.ByteString.Lazy         as BL
import           Data.CaseInsensitive         (CI)
import           Network.Wai
import           Control.Monad                (mplus)
import           Control.Monad.Trans.Resource (runInternalState, InternalState)
import           Network.Wai.Internal
import           Web.Cookie                   (renderSetCookie)
import           Yesod.Core.Content
import           Yesod.Core.Types
import qualified Network.HTTP.Types           as H
import qualified Data.Text                    as T
import           Control.Exception            (SomeException, handle)
import           Data.ByteString.Builder      (lazyByteString, toLazyByteString)
import qualified Data.ByteString.Lazy         as L
import qualified Data.Map                     as Map
import           Yesod.Core.Internal.Request  (tokenKey)
import           Data.Text.Encoding           (encodeUtf8)
import           Conduit

yarToResponse :: YesodResponse
              -> (SessionMap -> IO [Header]) -- ^ save session
              -> YesodRequest
              -> Request
              -> InternalState
              -> (Response -> IO ResponseReceived)
              -> IO ResponseReceived
yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header])
-> YesodRequest
-> Request
-> InternalState
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
yarToResponse (YRWai Response
a) SessionMap -> IO [Header]
_ YesodRequest
_ Request
_ InternalState
_ Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse Response
a
yarToResponse (YRWaiApp Application
app) SessionMap -> IO [Header]
_ YesodRequest
_ Request
req InternalState
_ Response -> IO ResponseReceived
sendResponse = Application
app Request
req Response -> IO ResponseReceived
sendResponse
yarToResponse (YRPlain Status
s' [Header]
hs ContentType
ct Content
c SessionMap
newSess) SessionMap -> IO [Header]
saveSession YesodRequest
yreq Request
_req InternalState
is Response -> IO ResponseReceived
sendResponse = do
    [(CI ContentType, ContentType)]
extraHeaders <- do
        let nsToken :: SessionMap
nsToken = SessionMap -> (Text -> SessionMap) -> Maybe Text -> SessionMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                SessionMap
newSess
                (\Text
n -> Text -> ContentType -> SessionMap -> SessionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
forall a. IsString a => a
tokenKey (Text -> ContentType
encodeUtf8 Text
n) SessionMap
newSess)
                (YesodRequest -> Maybe Text
reqToken YesodRequest
yreq)
        [Header]
sessionHeaders <- SessionMap -> IO [Header]
saveSession SessionMap
nsToken
        [(CI ContentType, ContentType)]
-> IO [(CI ContentType, ContentType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CI ContentType, ContentType)]
 -> IO [(CI ContentType, ContentType)])
-> [(CI ContentType, ContentType)]
-> IO [(CI ContentType, ContentType)]
forall a b. (a -> b) -> a -> b
$ (CI ContentType
"Content-Type", ContentType
ct) (CI ContentType, ContentType)
-> [(CI ContentType, ContentType)]
-> [(CI ContentType, ContentType)]
forall a. a -> [a] -> [a]
: (Header -> (CI ContentType, ContentType))
-> [Header] -> [(CI ContentType, ContentType)]
forall a b. (a -> b) -> [a] -> [b]
map Header -> (CI ContentType, ContentType)
headerToPair [Header]
sessionHeaders
    let finalHeaders :: [(CI ContentType, ContentType)]
finalHeaders = [(CI ContentType, ContentType)]
extraHeaders [(CI ContentType, ContentType)]
-> [(CI ContentType, ContentType)]
-> [(CI ContentType, ContentType)]
forall a. [a] -> [a] -> [a]
++ (Header -> (CI ContentType, ContentType))
-> [Header] -> [(CI ContentType, ContentType)]
forall a b. (a -> b) -> [a] -> [b]
map Header -> (CI ContentType, ContentType)
headerToPair [Header]
hs
        finalHeaders' :: a -> [(CI ContentType, ContentType)]
finalHeaders' a
len = (CI ContentType
"Content-Length", String -> ContentType
S8.pack (String -> ContentType) -> String -> ContentType
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
len)
                          (CI ContentType, ContentType)
-> [(CI ContentType, ContentType)]
-> [(CI ContentType, ContentType)]
forall a. a -> [a] -> [a]
: [(CI ContentType, ContentType)]
finalHeaders

    let go :: Content -> IO ResponseReceived
go (ContentBuilder Builder
b Maybe Int
mlen) = do
            let hs' :: [(CI ContentType, ContentType)]
hs' = [(CI ContentType, ContentType)]
-> (Int -> [(CI ContentType, ContentType)])
-> Maybe Int
-> [(CI ContentType, ContentType)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(CI ContentType, ContentType)]
finalHeaders Int -> [(CI ContentType, ContentType)]
forall a. Show a => a -> [(CI ContentType, ContentType)]
finalHeaders' Maybe Int
mlen
            Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(CI ContentType, ContentType)] -> Builder -> Response
ResponseBuilder Status
s [(CI ContentType, ContentType)]
hs' Builder
b
        go (ContentFile String
fp Maybe FilePart
p) = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status
-> [(CI ContentType, ContentType)]
-> String
-> Maybe FilePart
-> Response
ResponseFile Status
s [(CI ContentType, ContentType)]
finalHeaders String
fp Maybe FilePart
p
        go (ContentSource ConduitT () (Flush Builder) (ResourceT IO) ()
body) = Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status
-> [(CI ContentType, ContentType)] -> StreamingBody -> Response
responseStream Status
s [(CI ContentType, ContentType)]
finalHeaders
            (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                (forall a. ResourceT IO a -> IO a)
-> ConduitT () (Flush Builder) (ResourceT IO) ()
-> ConduitT () (Flush Builder) IO ()
forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe (ResourceT IO a -> InternalState -> IO a
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
`runInternalState` InternalState
is) ConduitT () (Flush Builder) (ResourceT IO) ()
body
                ConduitT () (Flush Builder) IO ()
-> ConduitM (Flush Builder) Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Flush Builder -> IO ()) -> ConduitM (Flush Builder) Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (\Flush Builder
mchunk ->
                    case Flush Builder
mchunk of
                        Flush Builder
Flush -> IO ()
flush
                        Chunk Builder
builder -> Builder -> IO ()
sendChunk Builder
builder)
        go (ContentDontEvaluate Content
c') = Content -> IO ResponseReceived
go Content
c'
    Content -> IO ResponseReceived
go Content
c
  where
    s :: Status
s
        | Status
s' Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
defaultStatus = Status
H.status200
        | Bool
otherwise = Status
s'

-- | Indicates that the user provided no specific status code to be used, and
-- therefore the default status code should be used. For normal responses, this
-- would be a 200 response, whereas for error responses this would be an
-- appropriate status code.
--
-- For more information on motivation for this, see:
--
-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ
--
-- Since 1.2.3.1
defaultStatus :: H.Status
defaultStatus :: Status
defaultStatus = Int -> ContentType -> Status
H.mkStatus (-Int
1) ContentType
"INVALID DEFAULT STATUS"

-- | Convert Header to a key/value pair.
headerToPair :: Header
             -> (CI ByteString, ByteString)
headerToPair :: Header -> (CI ContentType, ContentType)
headerToPair (AddCookie SetCookie
sc) =
    (CI ContentType
"Set-Cookie", ByteString -> ContentType
BL.toStrict (ByteString -> ContentType) -> ByteString -> ContentType
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ SetCookie -> Builder
renderSetCookie SetCookie
sc)
headerToPair (DeleteCookie ContentType
key ContentType
path) =
    ( CI ContentType
"Set-Cookie"
    , [ContentType] -> ContentType
S.concat
        [ ContentType
key
        , ContentType
"=; path="
        , ContentType
path
        , ContentType
"; expires=Thu, 01-Jan-1970 00:00:00 GMT"
        ]
    )
headerToPair (Header CI ContentType
key ContentType
value) = (CI ContentType
key, ContentType
value)

evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder Builder
b Maybe Int
mlen) = (SomeException -> IO (Either ErrorResponse Content))
-> IO (Either ErrorResponse Content)
-> IO (Either ErrorResponse Content)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO (Either ErrorResponse Content)
f (IO (Either ErrorResponse Content)
 -> IO (Either ErrorResponse Content))
-> IO (Either ErrorResponse Content)
-> IO (Either ErrorResponse Content)
forall a b. (a -> b) -> a -> b
$ do
    let lbs :: ByteString
lbs = Builder -> ByteString
toLazyByteString Builder
b
        len :: Int64
len = ByteString -> Int64
L.length ByteString
lbs
        mlen' :: Maybe Int
mlen' = Maybe Int
mlen Maybe Int -> Maybe Int -> Maybe Int
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Int -> Maybe Int
forall a. a -> Maybe a
Just (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)
    Int64
len Int64
-> IO (Either ErrorResponse Content)
-> IO (Either ErrorResponse Content)
`seq` Either ErrorResponse Content -> IO (Either ErrorResponse Content)
forall (m :: * -> *) a. Monad m => a -> m a
return (Content -> Either ErrorResponse Content
forall a b. b -> Either a b
Right (Content -> Either ErrorResponse Content)
-> Content -> Either ErrorResponse Content
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe Int -> Content
ContentBuilder (ByteString -> Builder
lazyByteString ByteString
lbs) Maybe Int
mlen')
  where
    f :: SomeException -> IO (Either ErrorResponse Content)
    f :: SomeException -> IO (Either ErrorResponse Content)
f = Either ErrorResponse Content -> IO (Either ErrorResponse Content)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorResponse Content -> IO (Either ErrorResponse Content))
-> (SomeException -> Either ErrorResponse Content)
-> SomeException
-> IO (Either ErrorResponse Content)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> Either ErrorResponse Content
forall a b. a -> Either a b
Left (ErrorResponse -> Either ErrorResponse Content)
-> (SomeException -> ErrorResponse)
-> SomeException
-> Either ErrorResponse Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorResponse
InternalError (Text -> ErrorResponse)
-> (SomeException -> Text) -> SomeException -> ErrorResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
evaluateContent Content
c = Either ErrorResponse Content -> IO (Either ErrorResponse Content)
forall (m :: * -> *) a. Monad m => a -> m a
return (Content -> Either ErrorResponse Content
forall a b. b -> Either a b
Right Content
c)

getStatus :: ErrorResponse -> H.Status
getStatus :: ErrorResponse -> Status
getStatus ErrorResponse
NotFound = Status
H.status404
getStatus (InternalError Text
_) = Status
H.status500
getStatus (InvalidArgs [Text]
_) = Status
H.status400
getStatus ErrorResponse
NotAuthenticated = Status
H.status401
getStatus (PermissionDenied Text
_) = Status
H.status403
getStatus (BadMethod ContentType
_) = Status
H.status405