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 Prelude.Unicode
29 postprocess ∷ NormalInteraction → STM ()
30 postprocess ni@(NI {..})
31 = do void $ tryPutTMVar niSendContinue False
32 abortOnCertainConditions ni
33 postprocessWithRequest ni
34 completeUnconditionalHeaders ni
36 abortOnCertainConditions ∷ NormalInteraction → STM ()
37 abortOnCertainConditions (NI {..})
38 = readTVar niResponse ≫= go
40 go ∷ Response → STM ()
41 go res@(Response {..})
42 = do unless (any (\ p → p resStatus) [ isSuccessful
47 $ cs ("Inappropriate status code for a response: " ∷ Ascii)
50 when ( resStatus ≈ MethodNotAllowed ∧
51 hasHeader "Allow" res )
53 $ cs ("The status was " ∷ Ascii)
55 ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
57 when ( resStatus ≉ NotModified ∧
58 isRedirection resStatus ∧
59 hasHeader "Location" res )
61 $ cs ("The status code was " ∷ Ascii)
63 ⊕ cs (" but no Location header." ∷ Ascii)
65 abort' ∷ AsciiBuilder → STM ()
67 ∘ mkAbortion' InternalServerError
70 postprocessWithRequest ∷ NormalInteraction → STM ()
71 postprocessWithRequest ni@(NI {..})
72 = do willDiscardBody ← readTVar niWillDiscardBody
73 canHaveBody ← if willDiscardBody then
76 resCanHaveBody <$> readTVar niResponse
79 $ deleteHeader "Content-Length"
80 ∘ deleteHeader "Transfer-Encoding"
83 do when niWillChunkBody $
84 writeHeader ni "Transfer-Encoding" (Just "chunked")
85 writeDefaultPageIfNeeded ni
87 do writeTVar niWillDiscardBody True
88 -- These headers make sense for HEAD requests even
89 -- when there won't be a response entity body.
90 when (reqMethod niRequest ≢ HEAD)
92 $ deleteHeader "Content-Type"
94 ∘ deleteHeader "Last-Modified"
96 hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
97 willClose ← readTVar niWillClose
98 when (hasConnClose ∧ (¬) willClose)
99 $ writeTVar niWillClose True
100 when ((¬) hasConnClose ∧ willClose)
101 $ writeHeader ni "Connection" (Just "close")
103 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
104 writeDefaultPageIfNeeded ni@(NI {..})
105 = do resHasCType ← readTVar niResponseHasCType
107 $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
108 writeHeader ni "Content-Encoding" Nothing
109 res ← readTVar niResponse
110 let body = defaultPageForResponse niConfig (Just niRequest) res
111 putTMVar niBodyToSend body
113 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
114 completeUnconditionalHeaders ni@(NI {..})
115 = do srv ← readHeader ni "Server"
116 when (isNothing srv) $
117 writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
119 date ← readHeader ni "Date"
120 when (isNothing date) $
121 do date' ← unsafeIOToSTM getCurrentDate
122 writeHeader ni "Date" $ Just date'
124 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
125 {-# INLINE writeHeader #-}
128 Just v' → updateRes ni $ setHeader k v'
129 Nothing → updateRes ni $ deleteHeader k
131 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
132 {-# INLINE readHeader #-}
133 readHeader (NI {..}) k
134 = getHeader k <$> readTVar niResponse
136 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
137 {-# INLINE readCIHeader #-}
138 readCIHeader (NI {..}) k
139 = getCIHeader k <$> readTVar niResponse
141 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
142 {-# INLINE updateRes #-}
143 updateRes (NI {..}) f
144 = do old ← readTVar niResponse
145 writeTVar niResponse $ f old