]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Postprocess.hs
0e089cac47e7cb00504abefc8e3230e4393e0cc1
[Lucu.git] / Network / HTTP / Lucu / Postprocess.hs
1 {-# LANGUAGE
2     BangPatterns
3   , DoAndIfThenElse
4   , OverloadedStrings
5   , UnicodeSyntax
6   #-}
7 module Network.HTTP.Lucu.Postprocess
8     ( postprocess
9     , completeUnconditionalHeaders
10     )
11     where
12 import Control.Applicative
13 import Control.Concurrent.STM
14 import Control.Monad
15 import Control.Monad.Unicode
16 import Data.Ascii (Ascii, CIAscii)
17 import qualified Data.Ascii as A
18 import Data.Maybe
19 import Data.Monoid.Unicode
20 import Data.Time
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
31
32 {-
33   
34   * Response が未設定なら、200 OK にする。
35
36   * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
37
38   * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
39
40   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
41     する。
42
43   * Content-Length があれば、それを削除する。Transfer-Encoding があって
44     も削除する。
45
46   * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
47     chunked に設定する。
48
49   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
50     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
51     する。
52
53   * body を持つ事が出來ない時、body 破棄フラグを立てる。
54
55   * Connection: close が設定されてゐる時、切斷フラグを立てる。
56
57   * 切斷フラグが立ってゐる時、Connection: close を設定する。
58
59   * Server が無ければ設定。
60
61   * Date が無ければ設定。
62
63 -}
64
65 postprocess ∷ Interaction → STM ()
66 postprocess !itr
67     = do reqM ← readItr itrRequest  id itr
68          res  ← readItr itrResponse id itr
69          let sc = resStatus res
70
71          unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
72              $ abortSTM InternalServerError []
73              $ Just
74              $ A.toText
75              $ A.fromAsciiBuilder
76              $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
77              ⊕ printStatusCode sc
78
79          when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
80              $ abortSTM InternalServerError []
81              $ Just
82              $ A.toText
83              $ A.fromAsciiBuilder
84              $ A.toAsciiBuilder "The status was "
85              ⊕ printStatusCode sc
86              ⊕ A.toAsciiBuilder " but no Allow header."
87
88          when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
89              $ abortSTM InternalServerError []
90              $ Just
91              $ A.toText
92              $ A.fromAsciiBuilder
93              $ A.toAsciiBuilder "The status code was "
94              ⊕ printStatusCode sc
95              ⊕ A.toAsciiBuilder " but no Location header."
96
97          when (reqM ≢ Nothing) relyOnRequest
98
99          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
100          -- 能性が高い。
101          do oldRes ← readItr itrResponse id itr
102             newRes ← unsafeIOToSTM
103                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
104             writeItr itrResponse newRes itr
105     where
106       relyOnRequest ∷ STM ()
107       relyOnRequest
108           = do status ← readItr itrResponse resStatus itr
109                req    ← readItr itrRequest  fromJust  itr
110
111                let reqVer      = reqVersion req
112                    canHaveBody = if reqMethod req ≡ HEAD then
113                                      False
114                                  else
115                                      not (isInformational status ∨
116                                           status ≡ NoContent     ∨
117                                           status ≡ ResetContent  ∨
118                                           status ≡ NotModified   )
119
120                updateRes $ deleteHeader "Content-Length"
121                updateRes $ deleteHeader "Transfer-Encoding"
122
123                cType ← readHeader "Content-Type"
124                when (cType ≡ Nothing)
125                         $ updateRes $ setHeader "Content-Type" defaultPageContentType
126
127                if canHaveBody then
128                    when (reqVer ≡ HttpVersion 1 1)
129                        $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
130                             writeItr itrWillChunkBody True itr
131                else
132                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
133                    when (reqMethod req ≢ HEAD)
134                        $ do updateRes $ deleteHeader "Content-Type"
135                             updateRes $ deleteHeader "Etag"
136                             updateRes $ deleteHeader "Last-Modified"
137
138                conn ← readHeader "Connection"
139                case conn of
140                  Nothing    → return ()
141                  Just value → when (A.toCIAscii value ≡ "close")
142                                   $ writeItr itrWillClose True itr
143
144                willClose ← readItr itrWillClose id itr
145                when willClose
146                    $ updateRes $ setHeader "Connection" "close"
147
148                when (reqMethod req ≡ HEAD ∨ not canHaveBody)
149                    $ writeTVar (itrWillDiscardBody itr) True
150
151       readHeader ∷ CIAscii → STM (Maybe Ascii)
152       {-# INLINE readHeader #-}
153       readHeader k = readItr itrResponse (getHeader k) itr
154
155       updateRes ∷ (Response → Response) → STM ()
156       {-# INLINE updateRes #-}
157       updateRes f = updateItr itrResponse f itr
158
159 completeUnconditionalHeaders ∷ Config → Response → IO Response
160 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
161       where
162         compServer res'
163             = case getHeader "Server" res' of
164                 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
165                 Just _  → return res'
166
167         compDate res'
168             = case getHeader "Date" res' of
169                 Nothing → do date ← getCurrentDate
170                              return $ setHeader "Date" date res'
171                 Just _  → return res'
172
173 getCurrentDate ∷ IO Ascii
174 getCurrentDate = HTTP.toAscii <$> getCurrentTime