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