    {-# LANGUAGE OverloadedStrings #-}

    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
        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 -> ByteString -> 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 -> ByteString
    encodeUtf8 Text
    n) SessionMap
    newSess)
                    (YesodRequest -> Maybe Text
    reqToken YesodRequest
    yreq)
            sessionHeaders <- SessionMap -> IO [Header]
    saveSession SessionMap
    nsToken
            return $ ("Content-Type", ct) : map headerToPair sessionHeaders
        let finalHeaders = [(CI ByteString, ByteString)]
    extraHeaders [(CI ByteString, ByteString)]
    -> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
    forall a. [a] -> [a] -> [a]
    ++ (Header -> (CI ByteString, ByteString))
    -> [Header] -> [(CI ByteString, ByteString)]
    forall a b. (a -> b) -> [a] -> [b]
    map Header -> (CI ByteString, ByteString)
    headerToPair [Header]
    hs
            finalHeaders' a
    len = (CI ByteString
    "Content-Length", String -> ByteString
    S8.pack (String -> ByteString) -> String -> ByteString
    forall a b. (a -> b) -> a -> b
    $ a -> String
    forall a. Show a => a -> String
    show a
    len)
                              (CI ByteString, ByteString)
    -> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
    forall a. a -> [a] -> [a]
    : [(CI ByteString, ByteString)]
    finalHeaders

        let go (ContentBuilder Builder
    b Maybe Int
    mlen) = do
                let hs' :: [(CI ByteString, ByteString)]
    hs' = [(CI ByteString, ByteString)]
    -> (Int -> [(CI ByteString, ByteString)])
    -> Maybe Int
    -> [(CI ByteString, ByteString)]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [(CI ByteString, ByteString)]
    finalHeaders Int -> [(CI ByteString, ByteString)]
    forall {a}. Show a => a -> [(CI ByteString, ByteString)]
    finalHeaders' Maybe Int
    mlen
                Response -> IO ResponseReceived
    sendResponse (Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived
    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 (Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived
    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 (Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ Status
    -> [(CI ByteString, ByteString)] -> StreamingBody -> Response
    responseStream Status
    s [(CI ByteString, ByteString)]
    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 ()
    -> ConduitT (Flush Builder) Void IO () -> ConduitT () Void IO ()
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
    .| (Flush Builder -> IO ()) -> ConduitT (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'
        go 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 -> 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", LazyByteString -> ByteString
    BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Builder -> LazyByteString
    toLazyByteString (Builder -> LazyByteString) -> Builder -> LazyByteString
    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) = (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 :: LazyByteString
    lbs = Builder -> LazyByteString
    toLazyByteString Builder
    b
            len :: Int64
    len = LazyByteString -> Int64
    L.length LazyByteString
    lbs
            mlen' :: Maybe Int
    mlen' = Maybe Int
    mlen Maybe Int -> Maybe Int -> Maybe Int
    forall a. Maybe a -> Maybe a -> Maybe a
    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 a. a -> IO a
    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 (LazyByteString -> Builder
    lazyByteString LazyByteString
    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 a. a -> IO a
    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 a. a -> IO a
    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 ByteString
    _) = Status
    H.status405