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 ≡ cs MethodNotAllowed ∧
51 (¬) (hasHeader "Allow" res) )
53 $ cs ("The status was " ∷ Ascii)
55 ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
57 when ( resStatus ≢ cs 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 {..})
73 $ deleteHeader "Content-Length"
74 ∘ deleteHeader "Transfer-Encoding"
76 canHaveBody ← resCanHaveBody <$> readTVar niResponse
78 do when niWillChunkBody
79 $ writeHeader ni "Transfer-Encoding" (Just "chunked")
80 when (reqMethod niRequest ≢ HEAD)
81 $ writeDefaultPageIfNeeded ni
83 -- These headers make sense for HEAD requests even when
84 -- there won't be a response entity body.
85 when (reqMethod niRequest ≢ HEAD)
87 $ deleteHeader "Content-Type"
89 ∘ deleteHeader "Last-Modified"
91 hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
92 willClose ← readTVar niWillClose
93 when (hasConnClose ∧ (¬) willClose)
94 $ writeTVar niWillClose True
95 when ((¬) hasConnClose ∧ willClose)
96 $ writeHeader ni "Connection" (Just "close")
98 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
99 writeDefaultPageIfNeeded ni@(NI {..})
100 = do resHasCType ← readTVar niResponseHasCType
102 $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
103 writeHeader ni "Content-Encoding" Nothing
104 res ← readTVar niResponse
105 let body = defaultPageForResponse niConfig (Just niRequest) res
106 putTMVar niBodyToSend body
108 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
109 completeUnconditionalHeaders ni@(NI {..})
110 = do srv ← readHeader ni "Server"
111 when (isNothing srv) $
112 writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
114 date ← readHeader ni "Date"
115 when (isNothing date) $
116 do date' ← unsafeIOToSTM getCurrentDate
117 writeHeader ni "Date" $ Just date'
119 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
120 {-# INLINE writeHeader #-}
123 Just v' → updateRes ni $ setHeader k v'
124 Nothing → updateRes ni $ deleteHeader k
126 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
127 {-# INLINE readHeader #-}
128 readHeader (NI {..}) k
129 = getHeader k <$> readTVar niResponse
131 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
132 {-# INLINE readCIHeader #-}
133 readCIHeader (NI {..}) k
134 = getCIHeader k <$> readTVar niResponse
136 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
137 {-# INLINE updateRes #-}
138 updateRes (NI {..}) f
139 = do old ← readTVar niResponse
140 writeTVar niResponse $ f old