- do setRes itr (deleteHeader res "Transfer-Encoding")
- when (reqMethod req /= HEAD)
- $ setRes itr (deleteHeader res "Content-Type")
-
- if fmap (map toLower) (getHeader res "Connection") == Just "close" then
- writeTVar (itrWillClose itr) True
- else
- setRes itr (setHeader res "Connection" "close")
-
- when (reqMethod req == HEAD || not canHaveBody)
- $ writeTVar (itrWillDiscardBody itr) True
-
- setStatus itr status
- = writeTVar (itrResponse itr) (Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- })
-
- setRes itr res
- = writeTVar (itrResponse itr) (Just res)
-
-
-completeUnconditionalHeaders :: Response -> IO Response
-completeUnconditionalHeaders res
- = return res >>= compServer >>= compDate >>= return
+ when (reqMethod ≢ HEAD)
+ $ do updateRes $ deleteHeader "Content-Type"
+ updateRes $ deleteHeader "Etag"
+ updateRes $ deleteHeader "Last-Modified"
+
+ conn ← readCIHeader "Connection"
+ case conn of
+ Nothing → return ()
+ Just value → when (value ≡ "close")
+ $ writeTVar itrWillClose True
+
+ willClose ← readTVar itrWillClose
+ when willClose
+ $ updateRes $ setHeader "Connection" "close"
+
+ when (reqMethod ≡ HEAD ∨ not canHaveBody)
+ $ writeTVar itrWillDiscardBody True
+
+ readHeader ∷ CIAscii → STM (Maybe Ascii)
+ {-# INLINE readHeader #-}
+ readHeader k = getHeader k <$> readTVar itrResponse
+
+ readCIHeader ∷ CIAscii → STM (Maybe CIAscii)
+ {-# INLINE readCIHeader #-}
+ readCIHeader k = getCIHeader k <$> readTVar itrResponse
+
+ updateRes ∷ (Response → Response) → STM ()
+ {-# INLINE updateRes #-}
+ updateRes f
+ = do old ← readTVar itrResponse
+ writeTVar itrResponse (f old)
+
+completeUnconditionalHeaders ∷ Config → Response → IO Response
+completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer