- do updateRes itr $ deleteHeader "Transfer-Encoding"
- when (reqMethod req /= HEAD)
- $ updateRes itr $ deleteHeader "Content-Type"
-
- conn <- readHeader itr "Connection"
- case fmap (map toLower) conn of
- Just "close" -> writeItr itr itrWillClose True
- _ -> updateRes itr $ setHeader "Connection" "close"
-
- when (reqMethod req == HEAD || not canHaveBody)
- $ writeTVar (itrWillDiscardBody itr) True
-
- setStatus :: Interaction -> StatusCode -> STM ()
- setStatus itr status
- = writeTVar (itrResponse itr) (Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = status
- , resHeaders = []
- })
-
- readHeader :: Interaction -> String -> STM (Maybe String)
- readHeader itr name
- = do valueMM <- readItrF itr itrResponse $ getHeader name
- case valueMM of
- Just (Just val) -> return $ Just val
- _ -> return Nothing
-
- updateRes :: Interaction -> (Response -> Response) -> STM ()
- updateRes itr updator
- = updateItrF itr itrResponse updator
-
-
-completeUnconditionalHeaders :: Response -> IO Response
-completeUnconditionalHeaders res
- = return res >>= compServer >>= compDate >>= return
+ when (reqMethod req ≢ HEAD)
+ $ do updateRes $ deleteHeader "Content-Type"
+ updateRes $ deleteHeader "Etag"
+ updateRes $ deleteHeader "Last-Modified"
+
+ conn ← readHeader "Connection"
+ case conn of
+ Nothing → return ()
+ Just value → when (A.toCIAscii value ≡ "close")
+ $ writeItr itrWillClose True itr
+
+ willClose ← readItr itrWillClose itr
+ when willClose
+ $ updateRes $ setHeader "Connection" "close"
+
+ when (reqMethod req ≡ HEAD ∨ not canHaveBody)
+ $ writeTVar (itrWillDiscardBody itr) True
+
+ readHeader ∷ CIAscii → STM (Maybe Ascii)
+ {-# INLINE readHeader #-}
+ readHeader k = getHeader k <$> readItr itrResponse itr
+
+ updateRes ∷ (Response → Response) → STM ()
+ {-# INLINE updateRes #-}
+ updateRes f = updateItr itrResponse f itr
+
+completeUnconditionalHeaders ∷ Config → Response → IO Response
+completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer