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)
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.Headers
25 import Network.HTTP.Lucu.HttpVersion
26 import Network.HTTP.Lucu.Interaction
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
29 import Prelude.Unicode
32 TODO: Tanslate this memo into English. It doesn't make sense to
33 non-Japanese speakers.
35 * Response が未設定なら、200 OK にする。
37 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
39 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
41 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
44 * Content-Length があれば、それを削除する。Transfer-Encoding があって
47 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
50 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
51 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
54 * body を持つ事が出來ない時、body 破棄フラグを立てる。
56 * Connection: close が設定されてゐる時、切斷フラグを立てる。
58 * 切斷フラグが立ってゐる時、Connection: close を設定する。
66 postprocess ∷ Interaction → STM ()
67 postprocess (Interaction {..})
68 = do res ← readTVar itrResponse
69 let sc = resStatus res
71 unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
72 $ abortSTM InternalServerError []
76 $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
79 when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
80 $ abortSTM InternalServerError []
84 $ A.toAsciiBuilder "The status was "
86 ⊕ A.toAsciiBuilder " but no Allow header."
88 when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
89 $ abortSTM InternalServerError []
93 $ A.toAsciiBuilder "The status code was "
95 ⊕ A.toAsciiBuilder " but no Location header."
98 Just req → postprocessWithRequest sc req
101 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
103 do oldRes ← readTVar itrResponse
104 newRes ← unsafeIOToSTM
105 $ completeUnconditionalHeaders itrConfig oldRes
106 writeTVar itrResponse newRes
108 postprocessWithRequest ∷ StatusCode → Request → STM ()
109 postprocessWithRequest sc (Request {..})
110 = do let canHaveBody = if reqMethod ≡ HEAD then
113 (¬) (isInformational sc ∨
118 updateRes $ deleteHeader "Content-Length"
119 updateRes $ deleteHeader "Transfer-Encoding"
121 cType ← readHeader "Content-Type"
122 when (cType ≡ Nothing)
123 $ updateRes $ setHeader "Content-Type" defaultPageContentType
126 when (reqVersion ≡ HttpVersion 1 1)
127 $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
128 writeTVar itrWillChunkBody True
130 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
131 when (reqMethod ≢ HEAD)
132 $ do updateRes $ deleteHeader "Content-Type"
133 updateRes $ deleteHeader "Etag"
134 updateRes $ deleteHeader "Last-Modified"
136 conn ← readCIHeader "Connection"
139 Just value → when (value ≡ "close")
140 $ writeTVar itrWillClose True
142 willClose ← readTVar itrWillClose
144 $ updateRes $ setHeader "Connection" "close"
146 when (reqMethod ≡ HEAD ∨ not canHaveBody)
147 $ writeTVar itrWillDiscardBody True
149 readHeader ∷ CIAscii → STM (Maybe Ascii)
150 {-# INLINE readHeader #-}
151 readHeader k = getHeader k <$> readTVar itrResponse
153 readCIHeader ∷ CIAscii → STM (Maybe CIAscii)
154 {-# INLINE readCIHeader #-}
155 readCIHeader k = getCIHeader k <$> readTVar itrResponse
157 updateRes ∷ (Response → Response) → STM ()
158 {-# INLINE updateRes #-}
160 = do old ← readTVar itrResponse
161 writeTVar itrResponse (f old)
163 completeUnconditionalHeaders ∷ Config → Response → IO Response
164 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
167 = case getHeader "Server" res' of
168 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
172 = case getHeader "Date" res' of
173 Nothing → do date ← getCurrentDate
174 return $ setHeader "Date" date res'
177 getCurrentDate ∷ IO Ascii
178 getCurrentDate = HTTP.toAscii <$> getCurrentTime