7 module Network.HTTP.Lucu.Postprocess
11 import Control.Applicative
12 import Control.Concurrent.STM
14 import Control.Monad.Unicode
15 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
16 import Data.Convertible.Base
18 import Data.Monoid.Unicode
19 import GHC.Conc (unsafeIOToSTM)
20 import Network.HTTP.Lucu.Abortion
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.DefaultPage
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import Network.HTTP.Lucu.Response.StatusCode
28 import Prelude.Unicode
30 postprocess ∷ NormalInteraction → STM ()
31 postprocess ni@(NI {..})
32 = do void $ tryPutTMVar niSendContinue False
33 abortOnCertainConditions ni
34 postprocessWithRequest ni
35 completeUnconditionalHeaders ni
37 abortOnCertainConditions ∷ NormalInteraction → STM ()
38 abortOnCertainConditions (NI {..})
39 = readTVar niResponse ≫= go
41 go ∷ Response → STM ()
42 go res@(Response {..})
43 = do unless (any (\ p → p resStatus) [ isSuccessful
48 $ cs ("Inappropriate status code for a response: " ∷ Ascii)
51 when ( resStatus ≡ cs MethodNotAllowed ∧
52 (¬) (hasHeader "Allow" res) )
54 $ cs ("The status was " ∷ Ascii)
56 ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
58 when ( resStatus ≢ cs NotModified ∧
59 isRedirection resStatus ∧
60 (¬) (hasHeader "Location" res) )
62 $ cs ("The status code was " ∷ Ascii)
64 ⊕ cs (" but no Location header." ∷ Ascii)
66 abort' ∷ AsciiBuilder → STM ()
68 ∘ mkAbortion' InternalServerError
71 postprocessWithRequest ∷ NormalInteraction → STM ()
72 postprocessWithRequest ni@(NI {..})
74 $ deleteHeader "Content-Length"
75 ∘ deleteHeader "Transfer-Encoding"
77 canHaveBody ← resCanHaveBody <$> readTVar niResponse
79 do when niWillChunkBody
80 $ writeHeader ni "Transfer-Encoding" (Just "chunked")
81 when (reqMethod niRequest ≢ HEAD)
82 $ writeDefaultPageIfNeeded ni
84 -- These headers make sense for HEAD requests even when
85 -- there won't be a response entity body.
86 when (reqMethod niRequest ≢ HEAD)
88 $ deleteHeader "Content-Type"
90 ∘ deleteHeader "Last-Modified"
92 hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
93 willClose ← readTVar niWillClose
94 when (hasConnClose ∧ (¬) willClose)
95 $ writeTVar niWillClose True
96 when ((¬) hasConnClose ∧ willClose)
97 $ writeHeader ni "Connection" (Just "close")
99 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
100 writeDefaultPageIfNeeded ni@(NI {..})
101 = do resHasCType ← readTVar niResponseHasCType
103 $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
104 writeHeader ni "Content-Encoding" Nothing
105 res ← readTVar niResponse
106 let body = defaultPageForResponse niConfig (Just niRequest) res
107 putTMVar niBodyToSend body
109 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
110 completeUnconditionalHeaders ni@(NI {..})
111 = do srv ← readHeader ni "Server"
112 when (isNothing srv) $
113 writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
115 date ← readHeader ni "Date"
116 when (isNothing date) $
117 do date' ← unsafeIOToSTM getCurrentDate
118 writeHeader ni "Date" $ Just date'
120 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
121 {-# INLINE writeHeader #-}
124 Just v' → updateRes ni $ setHeader k v'
125 Nothing → updateRes ni $ deleteHeader k
127 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
128 {-# INLINE readHeader #-}
129 readHeader (NI {..}) k
130 = getHeader k <$> readTVar niResponse
132 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
133 {-# INLINE readCIHeader #-}
134 readCIHeader (NI {..}) k
135 = getCIHeader k <$> readTVar niResponse
137 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
138 {-# INLINE updateRes #-}
139 updateRes (NI {..}) f
140 = do old ← readTVar niResponse
141 writeTVar niResponse $ f old