]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Postprocess.hs
Small fixes
[Lucu.git] / Network / HTTP / Lucu / Postprocess.hs
1 module Network.HTTP.Lucu.Postprocess
2     ( postprocess
3     , completeUnconditionalHeaders
4     )
5     where
6
7 import           Control.Concurrent.STM
8 import           Control.Monad
9 import qualified Data.ByteString as Strict (ByteString)
10 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
11 import           Data.IORef
12 import           Data.Maybe
13 import           Data.Time
14 import           GHC.Conc (unsafeIOToSTM)
15 import           Network.HTTP.Lucu.Abortion
16 import           Network.HTTP.Lucu.Config
17 import           Network.HTTP.Lucu.Headers
18 import           Network.HTTP.Lucu.HttpVersion
19 import           Network.HTTP.Lucu.Interaction
20 import           Network.HTTP.Lucu.RFC1123DateTime
21 import           Network.HTTP.Lucu.Request
22 import           Network.HTTP.Lucu.Response
23 import           System.IO.Unsafe
24
25 {-
26   
27   * Response が未設定なら、200 OK にする。
28
29   * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
30
31   * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
32
33   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
34     する。
35
36   * Content-Length があれば、それを削除する。Transfer-Encoding があって
37     も削除する。
38
39   * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
40     chunked に設定する。
41
42   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
43     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
44     する。
45
46   * body を持つ事が出來ない時、body 破棄フラグを立てる。
47
48   * Connection: close が設定されてゐる時、切斷フラグを立てる。
49
50   * 切斷フラグが立ってゐる時、Connection: close を設定する。
51
52   * Server が無ければ設定。
53
54   * Date が無ければ設定。
55
56 -}
57
58 postprocess :: Interaction -> STM ()
59 postprocess itr
60     = itr `seq`
61       do reqM <- readItr itr itrRequest id
62          res  <- readItr itr itrResponse id
63          let sc = resStatus res
64
65          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
66                   $ abortSTM InternalServerError []
67                         $ Just ("The status code is not good for a final status: "
68                                 ++ show sc)
69
70          when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
71                   $ abortSTM InternalServerError []
72                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
73
74          when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
75                   $ abortSTM InternalServerError []
76                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
77
78          when (reqM /= Nothing) relyOnRequest
79
80          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
81          -- 能性が高い。
82          do oldRes <- readItr itr itrResponse id
83             newRes <- unsafeIOToSTM
84                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
85             writeItr itr itrResponse newRes
86     where
87       relyOnRequest :: STM ()
88       relyOnRequest
89           = do status <- readItr itr itrResponse resStatus
90                req    <- readItr itr itrRequest fromJust
91
92                let reqVer      = reqVersion req
93                    canHaveBody = if reqMethod req == HEAD then
94                                      False
95                                  else
96                                      not (isInformational status ||
97                                           status == NoContent    ||
98                                           status == ResetContent ||
99                                           status == NotModified    )
100
101                updateRes $! deleteHeader (C8.pack "Content-Length")
102                updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
103
104                cType <- readHeader (C8.pack "Content-Type")
105                when (cType == Nothing)
106                         $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
107
108                if canHaveBody then
109                    when (reqVer == HttpVersion 1 1)
110                             $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
111                                  writeItr itr itrWillChunkBody True
112                  else
113                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
114                    when (reqMethod req /= HEAD)
115                             $ do updateRes $! deleteHeader (C8.pack "Content-Type")
116                                  updateRes $! deleteHeader (C8.pack "Etag")
117                                  updateRes $! deleteHeader (C8.pack "Last-Modified")
118
119                conn <- readHeader (C8.pack "Connection")
120                case conn of
121                  Nothing    -> return ()
122                  Just value -> if value `noCaseEq` C8.pack "close" then
123                                    writeItr itr itrWillClose True
124                                else
125                                    return ()
126
127                willClose <- readItr itr itrWillClose id
128                when willClose
129                         $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
130
131                when (reqMethod req == HEAD || not canHaveBody)
132                         $ writeTVar (itrWillDiscardBody itr) True
133
134       readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
135       readHeader name
136           = name `seq`
137             readItr itr itrResponse $ getHeader name
138
139       updateRes :: (Response -> Response) -> STM ()
140       updateRes updator 
141           = updator `seq`
142             updateItr itr itrResponse updator
143
144
145 completeUnconditionalHeaders :: Config -> Response -> IO Response
146 completeUnconditionalHeaders conf res
147     = conf `seq` res `seq`
148       return res >>= compServer >>= compDate >>= return
149       where
150         compServer res'
151             = case getHeader (C8.pack "Server") res' of
152                 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
153                 Just _  -> return res'
154
155         compDate res'
156             = case getHeader (C8.pack "Date") res' of
157                 Nothing -> do date <- getCurrentDate
158                               return $ setHeader (C8.pack "Date") date res'
159                 Just _  -> return res'
160
161
162 cache :: IORef (UTCTime, Strict.ByteString)
163 cache = unsafePerformIO $
164         newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
165 {-# NOINLINE cache #-}
166
167 getCurrentDate :: IO Strict.ByteString
168 getCurrentDate = do now                     <- getCurrentTime
169                     (cachedTime, cachedStr) <- readIORef cache
170
171                     if now `mostlyEq` cachedTime then
172                         return cachedStr
173                       else
174                         do let dateStr = C8.pack $ formatHTTPDateTime now
175                            writeIORef cache (now, dateStr)
176                            return dateStr
177     where
178       mostlyEq :: UTCTime -> UTCTime -> Bool
179       mostlyEq a b
180           = if utctDay a == utctDay b then
181                 fromEnum (utctDayTime a) == fromEnum (utctDayTime b)
182             else
183                 False