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 qualified Data.ByteString as Strict (ByteString)
19 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
22 import Data.Monoid.Unicode
24 import qualified Data.Time.HTTP as HTTP
25 import GHC.Conc (unsafeIOToSTM)
26 import Network.HTTP.Lucu.Abortion
27 import Network.HTTP.Lucu.Config
28 import Network.HTTP.Lucu.Headers
29 import Network.HTTP.Lucu.HttpVersion
30 import Network.HTTP.Lucu.Interaction
31 import Network.HTTP.Lucu.Request
32 import Network.HTTP.Lucu.Response
33 import Prelude.Unicode
34 import System.IO.Unsafe
38 * Response が未設定なら、200 OK にする。
40 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
42 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
44 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
47 * Content-Length があれば、それを削除する。Transfer-Encoding があって
50 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
53 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
54 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
57 * body を持つ事が出來ない時、body 破棄フラグを立てる。
59 * Connection: close が設定されてゐる時、切斷フラグを立てる。
61 * 切斷フラグが立ってゐる時、Connection: close を設定する。
69 postprocess ∷ Interaction → STM ()
71 = do reqM ← readItr itr itrRequest id
72 res ← readItr itr itrResponse id
73 let sc = resStatus res
75 unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
76 $ abortSTM InternalServerError []
78 $ A.toText ( "The status code is not good for a final status of a response: "
79 ⊕ printStatusCode sc )
81 when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
82 $ abortSTM InternalServerError []
84 $ A.toText ( "The status was "
86 ⊕ " but no Allow header." )
88 when (sc /= NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
89 $ abortSTM InternalServerError []
91 $ A.toText ( "The status code was "
93 ⊕ " but no Location header." )
95 when (reqM /= Nothing) relyOnRequest
97 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
99 do oldRes ← readItr itr itrResponse id
100 newRes ← unsafeIOToSTM
101 $ completeUnconditionalHeaders (itrConfig itr) oldRes
102 writeItr itr itrResponse newRes
104 relyOnRequest ∷ STM ()
106 = do status ← readItr itr itrResponse resStatus
107 req ← readItr itr itrRequest fromJust
109 let reqVer = reqVersion req
110 canHaveBody = if reqMethod req ≡ HEAD then
113 not (isInformational status ∨
115 status ≡ ResetContent ∨
116 status ≡ NotModified )
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 (reqVer ≡ HttpVersion 1 1)
127 $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
128 writeItr itr itrWillChunkBody True
130 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
131 when (reqMethod req /= HEAD)
132 $ do updateRes $ deleteHeader "Content-Type"
133 updateRes $ deleteHeader "Etag"
134 updateRes $ deleteHeader "Last-Modified"
136 conn ← readHeader "Connection"
139 Just value → when (A.toCIAscii value ≡ "close")
140 $ writeItr itr itrWillClose True
142 willClose ← readItr itr itrWillClose id
144 $ updateRes $ setHeader "Connection" "close"
146 when (reqMethod req ≡ HEAD ∨ not canHaveBody)
147 $ writeTVar (itrWillDiscardBody itr) True
149 readHeader ∷ CIAscii → STM (Maybe Ascii)
150 {-# INLINE readHeader #-}
151 readHeader = readItr itr itrResponse ∘ getHeader
153 updateRes ∷ (Response → Response) → STM ()
154 {-# INLINE updateRes #-}
155 updateRes = updateItr itr itrResponse
157 completeUnconditionalHeaders ∷ Config → Response → IO Response
158 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
161 = case getHeader "Server" res' of
162 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
166 = case getHeader "Date" res' of
167 Nothing → do date ← getCurrentDate
168 return $ setHeader "Date" date res'
171 getCurrentDate ∷ IO Ascii
172 getCurrentDate = HTTP.format <$> getCurrentTime