1{-# LANGUAGE CPP               #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes        #-}
4module Yesod.Core.Internal.Response where
5
6import           Data.ByteString              (ByteString)
7import qualified Data.ByteString              as S
8import qualified Data.ByteString.Char8        as S8
9import qualified Data.ByteString.Lazy         as BL
10import           Data.CaseInsensitive         (CI)
11import           Network.Wai
12import           Control.Monad                (mplus)
13import           Control.Monad.Trans.Resource (runInternalState, InternalState)
14import           Network.Wai.Internal
15import           Web.Cookie                   (renderSetCookie)
16import           Yesod.Core.Content
17import           Yesod.Core.Types
18import qualified Network.HTTP.Types           as H
19import qualified Data.Text                    as T
20import           Control.Exception            (SomeException, handle)
21import           Data.ByteString.Builder      (lazyByteString, toLazyByteString)
22import qualified Data.ByteString.Lazy         as L
23import qualified Data.Map                     as Map
24import           Yesod.Core.Internal.Request  (tokenKey)
25import           Data.Text.Encoding           (encodeUtf8)
26import           Conduit
27
28yarToResponse :: YesodResponse
29              -> (SessionMap -> IO [Header]) -- ^ save session
30              -> YesodRequest
31              -> Request
32              -> InternalState
33              -> (Response -> IO ResponseReceived)
34              -> IO ResponseReceived
35yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a
36yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse
37yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse = do
38    extraHeaders <- do
39        let nsToken = maybe
40                newSess
41                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
42                (reqToken yreq)
43        sessionHeaders <- saveSession nsToken
44        return $ ("Content-Type", ct) : map headerToPair sessionHeaders
45    let finalHeaders = extraHeaders ++ map headerToPair hs
46        finalHeaders' len = ("Content-Length", S8.pack $ show len)
47                          : finalHeaders
48
49    let go (ContentBuilder b mlen) = do
50            let hs' = maybe finalHeaders finalHeaders' mlen
51            sendResponse $ ResponseBuilder s hs' b
52        go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
53        go (ContentSource body) = sendResponse $ responseStream s finalHeaders
54            $ \sendChunk flush -> runConduit $
55                transPipe (`runInternalState` is) body
56                .| mapM_C (\mchunk ->
57                    case mchunk of
58                        Flush -> flush
59                        Chunk builder -> sendChunk builder)
60        go (ContentDontEvaluate c') = go c'
61    go c
62  where
63    s
64        | s' == defaultStatus = H.status200
65        | otherwise = s'
66
67-- | Indicates that the user provided no specific status code to be used, and
68-- therefore the default status code should be used. For normal responses, this
69-- would be a 200 response, whereas for error responses this would be an
70-- appropriate status code.
71--
72-- For more information on motivation for this, see:
73--
74-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ
75--
76-- Since 1.2.3.1
77defaultStatus :: H.Status
78defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
79
80-- | Convert Header to a key/value pair.
81headerToPair :: Header
82             -> (CI ByteString, ByteString)
83headerToPair (AddCookie sc) =
84    ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
85headerToPair (DeleteCookie key path) =
86    ( "Set-Cookie"
87    , S.concat
88        [ key
89        , "=; path="
90        , path
91        , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
92        ]
93    )
94headerToPair (Header key value) = (key, value)
95
96evaluateContent :: Content -> IO (Either ErrorResponse Content)
97evaluateContent (ContentBuilder b mlen) = handle f $ do
98    let lbs = toLazyByteString b
99        len = L.length lbs
100        mlen' = mlen `mplus` Just (fromIntegral len)
101    len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
102  where
103    f :: SomeException -> IO (Either ErrorResponse Content)
104    f = return . Left . InternalError . T.pack . show
105evaluateContent c = return (Right c)
106
107getStatus :: ErrorResponse -> H.Status
108getStatus NotFound = H.status404
109getStatus (InternalError _) = H.status500
110getStatus (InvalidArgs _) = H.status400
111getStatus NotAuthenticated = H.status401
112getStatus (PermissionDenied _) = H.status403
113getStatus (BadMethod _) = H.status405
114