7 module Network.HTTP.Lucu.Postprocess
9 , completeUnconditionalHeaders
12 import Control.Applicative
13 import Control.Concurrent.STM
15 import Control.Monad.Unicode
16 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
17 import qualified Data.Ascii as A
18 import Data.Monoid.Unicode
20 import qualified Data.Time.HTTP as HTTP
21 import GHC.Conc (unsafeIOToSTM)
22 import Network.HTTP.Lucu.Abortion
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.DefaultPage
25 import Network.HTTP.Lucu.Headers
26 import Network.HTTP.Lucu.HttpVersion
27 import Network.HTTP.Lucu.Interaction
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response
30 import Prelude.Unicode
32 postprocess ∷ Interaction → STM ()
33 postprocess itr@(Interaction {..})
34 = do abortOnCertainConditions itr
37 Just req → postprocessWithRequest itr req
40 updateResIO itr $ completeUnconditionalHeaders itrConfig
42 abortOnCertainConditions ∷ Interaction → STM ()
43 abortOnCertainConditions (Interaction {..})
44 = readTVar itrResponse ≫= go
46 go ∷ Response → STM ()
47 go res@(Response {..})
48 = do unless (any (\ p → p resStatus) [ isSuccessful
53 $ A.toAsciiBuilder "Inappropriate status code for a response: "
54 ⊕ printStatusCode resStatus
56 when ( resStatus ≡ MethodNotAllowed ∧
57 hasHeader "Allow" res )
59 $ A.toAsciiBuilder "The status was "
60 ⊕ printStatusCode resStatus
61 ⊕ A.toAsciiBuilder " but no \"Allow\" header."
63 when ( resStatus ≢ NotModified ∧
64 isRedirection resStatus ∧
65 hasHeader "Location" res )
67 $ A.toAsciiBuilder "The status code was "
68 ⊕ printStatusCode resStatus
69 ⊕ A.toAsciiBuilder " but no Location header."
71 abort' ∷ AsciiBuilder → STM ()
72 abort' = abortSTM InternalServerError []
77 postprocessWithRequest ∷ Interaction → Request → STM ()
78 postprocessWithRequest itr@(Interaction {..}) (Request {..})
79 = do willDiscardBody ← readTVar itrWillDiscardBody
80 canHaveBody ← if willDiscardBody then
83 resCanHaveBody <$> readTVar itrResponse
86 $ deleteHeader "Content-Length"
87 ∘ deleteHeader "Transfer-Encoding"
90 do when (reqVersion ≡ HttpVersion 1 1)
91 $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
92 writeTVar itrWillChunkBody True
93 writeDefaultPageIfNeeded itr
95 do writeTVar itrWillDiscardBody True
96 -- These headers make sense for HEAD requests even
97 -- when there won't be a response entity body.
98 when (reqMethod ≢ HEAD)
100 $ deleteHeader "Content-Type"
101 ∘ deleteHeader "Etag"
102 ∘ deleteHeader "Last-Modified"
104 hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
105 willClose ← readTVar itrWillClose
106 when (hasConnClose ∧ (¬) willClose)
107 $ writeTVar itrWillClose True
108 when ((¬) hasConnClose ∧ willClose)
109 $ writeHeader itr "Connection" (Just "close")
111 writeDefaultPageIfNeeded ∷ Interaction → STM ()
112 writeDefaultPageIfNeeded itr@(Interaction {..})
113 = do resHasCType ← readTVar itrResponseHasCType
115 $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
116 writeHeader itr "Content-Encoding" Nothing
117 res ← readTVar itrResponse
118 let page = getDefaultPage itrConfig itrRequest res
119 putTMVar itrBodyToSend page
121 writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
122 {-# INLINE writeHeader #-}
125 Just v' → updateRes itr $ setHeader k v'
126 Nothing → updateRes itr $ deleteHeader k
128 readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
129 {-# INLINE readCIHeader #-}
130 readCIHeader (Interaction {..}) k
131 = getCIHeader k <$> readTVar itrResponse
133 updateRes ∷ Interaction → (Response → Response) → STM ()
134 {-# INLINE updateRes #-}
135 updateRes (Interaction {..}) f
136 = do old ← readTVar itrResponse
137 writeTVar itrResponse (f old)
139 updateResIO ∷ Interaction → (Response → IO Response) → STM ()
140 {-# INLINE updateResIO #-}
141 updateResIO (Interaction {..}) f
142 = do old ← readTVar itrResponse
143 new ← unsafeIOToSTM $ f old
144 writeTVar itrResponse new
146 completeUnconditionalHeaders ∷ Config → Response → IO Response
147 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
150 = case getHeader "Server" res' of
151 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
155 = case getHeader "Date" res' of
156 Nothing → do date ← getCurrentDate
157 return $ setHeader "Date" date res'
160 getCurrentDate ∷ IO Ascii
161 getCurrentDate = HTTP.toAscii <$> getCurrentTime