{-# 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 ByteString
ct Content
c SessionMap
newSess) SessionMap -> IO [Header]
saveSession YesodRequest
yreq Request
_req InternalState
is Response -> IO ResponseReceived
sendResponse = do
    [(CI ByteString, ByteString)]
extraHeaders <- do
        let nsToken :: SessionMap
nsToken = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                SessionMap
newSess
                (\Text
n -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert forall a. IsString a => a
tokenKey (Text -> ByteString
encodeUtf8 Text
n) SessionMap
newSess)
                (YesodRequest -> Maybe Text
reqToken YesodRequest
yreq)
        [Header]
sessionHeaders <- SessionMap -> IO [Header]
saveSession SessionMap
nsToken
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (CI ByteString
"Content-Type", ByteString
ct) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Header -> (CI ByteString, ByteString)
headerToPair [Header]
sessionHeaders
    let finalHeaders :: [(CI ByteString, ByteString)]
finalHeaders = [(CI ByteString, ByteString)]
extraHeaders forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Header -> (CI ByteString, ByteString)
headerToPair [Header]
hs
        finalHeaders' :: a -> [(CI ByteString, ByteString)]
finalHeaders' a
len = (CI ByteString
"Content-Length", String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
len)
                          forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)]
finalHeaders

    let go :: Content -> IO ResponseReceived
go (ContentBuilder Builder
b Maybe Int
mlen) = do
            let hs' :: [(CI ByteString, ByteString)]
hs' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(CI ByteString, ByteString)]
finalHeaders forall {a}. Show a => a -> [(CI ByteString, ByteString)]
finalHeaders' Maybe Int
mlen
            Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> [(CI ByteString, ByteString)] -> Builder -> Response
ResponseBuilder Status
s [(CI ByteString, ByteString)]
hs' Builder
b
        go (ContentFile String
fp Maybe FilePart
p) = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status
-> [(CI ByteString, ByteString)]
-> String
-> Maybe FilePart
-> Response
ResponseFile Status
s [(CI ByteString, ByteString)]
finalHeaders String
fp Maybe FilePart
p
        go (ContentSource ConduitT () (Flush Builder) (ResourceT IO) ()
body) = Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status
-> [(CI ByteString, ByteString)] -> StreamingBody -> Response
responseStream Status
s [(CI ByteString, ByteString)]
finalHeaders
            forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
                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 (forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
`runInternalState` InternalState
is) ConduitT () (Flush Builder) (ResourceT IO) ()
body
                forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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' 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 -> ByteString -> Status
H.mkStatus (-Int
1) ByteString
"INVALID DEFAULT STATUS"

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

evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder Builder
b Maybe Int
mlen) = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO (Either ErrorResponse Content)
f 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 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)
    Int64
len seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorResponse
InternalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
evaluateContent Content
c = forall (m :: * -> *) a. Monad m => a -> m a
return (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 ByteString
_) = Status
H.status405