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
19 import Data.Monoid.Unicode
21 import qualified Data.Time.HTTP as HTTP
22 import GHC.Conc (unsafeIOToSTM)
23 import Network.HTTP.Lucu.Abortion
24 import Network.HTTP.Lucu.Config
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
34 * Response が未設定なら、200 OK にする。
36 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
38 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
40 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
43 * Content-Length があれば、それを削除する。Transfer-Encoding があって
46 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
49 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
50 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
53 * body を持つ事が出來ない時、body 破棄フラグを立てる。
55 * Connection: close が設定されてゐる時、切斷フラグを立てる。
57 * 切斷フラグが立ってゐる時、Connection: close を設定する。
65 postprocess ∷ Interaction → STM ()
67 = do reqM ← readItr itrRequest id itr
68 res ← readItr itrResponse id itr
69 let sc = resStatus res
71 unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
72 $ abortSTM InternalServerError []
74 $ A.toText ( "The status code is not good for a final status of a response: "
75 ⊕ printStatusCode sc )
77 when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
78 $ abortSTM InternalServerError []
80 $ A.toText ( "The status was "
82 ⊕ " but no Allow header." )
84 when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
85 $ abortSTM InternalServerError []
87 $ A.toText ( "The status code was "
89 ⊕ " but no Location header." )
91 when (reqM ≢ Nothing) relyOnRequest
93 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
95 do oldRes ← readItr itrResponse id itr
96 newRes ← unsafeIOToSTM
97 $ completeUnconditionalHeaders (itrConfig itr) oldRes
98 writeItr itrResponse newRes itr
100 relyOnRequest ∷ STM ()
102 = do status ← readItr itrResponse resStatus itr
103 req ← readItr itrRequest fromJust itr
105 let reqVer = reqVersion req
106 canHaveBody = if reqMethod req ≡ HEAD then
109 not (isInformational status ∨
111 status ≡ ResetContent ∨
112 status ≡ NotModified )
114 updateRes $ deleteHeader "Content-Length"
115 updateRes $ deleteHeader "Transfer-Encoding"
117 cType ← readHeader "Content-Type"
118 when (cType ≡ Nothing)
119 $ updateRes $ setHeader "Content-Type" defaultPageContentType
122 when (reqVer ≡ HttpVersion 1 1)
123 $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
124 writeItr itrWillChunkBody True itr
126 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
127 when (reqMethod req ≢ HEAD)
128 $ do updateRes $ deleteHeader "Content-Type"
129 updateRes $ deleteHeader "Etag"
130 updateRes $ deleteHeader "Last-Modified"
132 conn ← readHeader "Connection"
135 Just value → when (A.toCIAscii value ≡ "close")
136 $ writeItr itrWillClose True itr
138 willClose ← readItr itrWillClose id itr
140 $ updateRes $ setHeader "Connection" "close"
142 when (reqMethod req ≡ HEAD ∨ not canHaveBody)
143 $ writeTVar (itrWillDiscardBody itr) True
145 readHeader ∷ CIAscii → STM (Maybe Ascii)
146 {-# INLINE readHeader #-}
147 readHeader k = readItr itrResponse (getHeader k) itr
149 updateRes ∷ (Response → Response) → STM ()
150 {-# INLINE updateRes #-}
151 updateRes f = updateItr itrResponse f itr
153 completeUnconditionalHeaders ∷ Config → Response → IO Response
154 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
157 = case getHeader "Server" res' of
158 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
162 = case getHeader "Date" res' of
163 Nothing → do date ← getCurrentDate
164 return $ setHeader "Date" date res'
167 getCurrentDate ∷ IO Ascii
168 getCurrentDate = HTTP.toAscii <$> getCurrentTime