6 module Network.HTTP.Lucu.Postprocess
8 , completeUnconditionalHeaders
11 import Control.Applicative
12 import Control.Concurrent.STM
14 import Control.Monad.Unicode
15 import Data.Ascii (Ascii, CIAscii)
16 import qualified Data.Ascii as A
17 import qualified Data.ByteString as Strict (ByteString)
18 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
21 import Data.Monoid.Unicode
23 import qualified Data.Time.HTTP as HTTP
24 import GHC.Conc (unsafeIOToSTM)
25 import Network.HTTP.Lucu.Abortion
26 import Network.HTTP.Lucu.Config
27 import Network.HTTP.Lucu.Headers
28 import Network.HTTP.Lucu.HttpVersion
29 import Network.HTTP.Lucu.Interaction
30 import Network.HTTP.Lucu.Request
31 import Network.HTTP.Lucu.Response
32 import Prelude.Unicode
33 import System.IO.Unsafe
37 * Response が未設定なら、200 OK にする。
39 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
41 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
43 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
46 * Content-Length があれば、それを削除する。Transfer-Encoding があって
49 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
52 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
53 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
56 * body を持つ事が出來ない時、body 破棄フラグを立てる。
58 * Connection: close が設定されてゐる時、切斷フラグを立てる。
60 * 切斷フラグが立ってゐる時、Connection: close を設定する。
68 postprocess ∷ Interaction → STM ()
70 = do reqM ← readItr itr itrRequest id
71 res ← readItr itr itrResponse id
72 let sc = resStatus res
74 unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
75 $ abortSTM InternalServerError []
77 $ A.toText ( "The status code is not good for a final status of a response: "
78 ⊕ printStatusCode sc )
80 when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
81 $ abortSTM InternalServerError []
82 $ Just ("The status was " ++ show sc ++ " but no Allow header.")
84 when (sc /= NotModified ∧ isRedirection sc ∧ getHeader (C8.pack "Location") res ≡ Nothing)
85 $ abortSTM InternalServerError []
86 $ Just ("The status code was " ++ show sc ++ " but no Location header.")
88 when (reqM /= Nothing) relyOnRequest
90 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
92 do oldRes ← readItr itr itrResponse id
93 newRes ← unsafeIOToSTM
94 $ completeUnconditionalHeaders (itrConfig itr) oldRes
95 writeItr itr itrResponse newRes
97 relyOnRequest ∷ STM ()
99 = do status ← readItr itr itrResponse resStatus
100 req ← readItr itr itrRequest fromJust
102 let reqVer = reqVersion req
103 canHaveBody = if reqMethod req ≡ HEAD then
106 not (isInformational status ∨
108 status ≡ ResetContent ∨
109 status ≡ NotModified )
111 updateRes $ deleteHeader "Content-Length"
112 updateRes $ deleteHeader "Transfer-Encoding"
114 cType ← readHeader "Content-Type"
115 when (cType ≡ Nothing)
116 $ updateRes $ setHeader "Content-Type" defaultPageContentType
119 when (reqVer ≡ HttpVersion 1 1)
120 $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
121 writeItr itr itrWillChunkBody True
123 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
124 when (reqMethod req /= HEAD)
125 $ do updateRes $ deleteHeader "Content-Type"
126 updateRes $ deleteHeader "Etag"
127 updateRes $ deleteHeader "Last-Modified"
129 conn ← readHeader "Connection"
132 Just value → when (A.toCIAscii value ≡ "close")
133 $ writeItr itr itrWillClose True
135 willClose ← readItr itr itrWillClose id
137 $ updateRes $ setHeader "Connection" "close"
139 when (reqMethod req ≡ HEAD ∨ not canHaveBody)
140 $ writeTVar (itrWillDiscardBody itr) True
142 readHeader ∷ CIAscii → STM (Maybe Ascii)
143 readHeader = readItr itr itrResponse ∘ getHeader
145 updateRes ∷ (Response → Response) → STM ()
146 updateRes = updateItr itr itrResponse
148 completeUnconditionalHeaders ∷ Config → Response → IO Response
149 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
152 = case getHeader "Server" res' of
153 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
157 = case getHeader "Date" res' of
158 Nothing → do date ← getCurrentDate
159 return $ setHeader "Date" date res'
162 getCurrentDate ∷ IO Ascii
163 getCurrentDate = HTTP.format <$> getCurrentTime