{-# 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 a :: Response
a) _ _ _ _ sendResponse :: Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse Response
a
yarToResponse (YRWaiApp app :: Application
app) _ _ req :: Request
req _ sendResponse :: Response -> IO ResponseReceived
sendResponse = Application
app Request
req Response -> IO ResponseReceived
sendResponse
yarToResponse (YRPlain s' :: Status
s' hs :: [Header]
hs ct :: ContentType
ct c :: Content
c newSess :: SessionMap
newSess) saveSession :: SessionMap -> IO [Header]
saveSession yreq :: YesodRequest
yreq _req :: Request
_req is :: InternalState
is sendResponse :: 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
                (\n :: 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
$ ("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' len :: a
len = ("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 b :: Builder
b mlen :: 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 fp :: String
fp p :: 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 body :: 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
$ \sendChunk :: Builder -> IO ()
sendChunk flush :: 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 (\mchunk :: Flush Builder
mchunk ->
                    case Flush Builder
mchunk of
                        Flush -> IO ()
flush
                        Chunk builder :: Builder
builder -> Builder -> IO ()
sendChunk Builder
builder)
        go (ContentDontEvaluate c' :: 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 (-1) "INVALID DEFAULT STATUS"

-- | Convert Header to a key/value pair.
headerToPair :: Header
             -> (CI ByteString, ByteString)
headerToPair :: Header -> (CI ContentType, ContentType)
headerToPair (AddCookie sc :: SetCookie
sc) =
    ("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 key :: ContentType
key path :: ContentType
path) =
    ( "Set-Cookie"
    , [ContentType] -> ContentType
S.concat
        [ ContentType
key
        , "=; path="
        , ContentType
path
        , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
        ]
    )
headerToPair (Header key :: CI ContentType
key value :: ContentType
value) = (CI ContentType
key, ContentType
value)

evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b :: Builder
b mlen :: 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)
forall a b. a -> b -> b
`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 c :: 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 NotFound = Status
H.status404
getStatus (InternalError _) = Status
H.status500
getStatus (InvalidArgs _) = Status
H.status400
getStatus NotAuthenticated = Status
H.status401
getStatus (PermissionDenied _) = Status
H.status403
getStatus (BadMethod _) = Status
H.status405