1 module Network.HTTP.Lucu.Postprocess
3 , completeUnconditionalHeaders
7 import Control.Concurrent.STM
9 import qualified Data.ByteString as Strict (ByteString)
10 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
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
27 * Response が未設定なら、200 OK にする。
29 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
31 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
33 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
36 * Content-Length があれば、それを削除する。Transfer-Encoding があって
39 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
42 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
43 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
46 * body を持つ事が出來ない時、body 破棄フラグを立てる。
48 * Connection: close が設定されてゐる時、切斷フラグを立てる。
50 * 切斷フラグが立ってゐる時、Connection: close を設定する。
58 postprocess :: Interaction -> STM ()
60 = do reqM <- readItr itr itrRequest id
61 res <- readItr itr itrResponse id
62 let sc = resStatus res
64 unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])
65 $ abortSTM InternalServerError []
66 $ Just ("The status code is not good for a final status: "
69 when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
70 $ abortSTM InternalServerError []
71 $ Just ("The status was " ++ show sc ++ " but no Allow header.")
73 when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
74 $ abortSTM InternalServerError []
75 $ Just ("The status code was " ++ show sc ++ " but no Location header.")
77 when (reqM /= Nothing) relyOnRequest
79 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
81 do oldRes <- readItr itr itrResponse id
82 newRes <- unsafeIOToSTM
83 $ completeUnconditionalHeaders (itrConfig itr) oldRes
84 writeItr itr itrResponse newRes
86 relyOnRequest :: STM ()
88 = do status <- readItr itr itrResponse resStatus
89 req <- readItr itr itrRequest fromJust
91 let reqVer = reqVersion req
92 canHaveBody = if reqMethod req == HEAD then
95 not (isInformational status ||
96 status == NoContent ||
97 status == ResetContent ||
98 status == NotModified )
100 updateRes $! deleteHeader (C8.pack "Content-Length")
101 updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
103 cType <- readHeader (C8.pack "Content-Type")
104 when (cType == Nothing)
105 $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
108 when (reqVer == HttpVersion 1 1)
109 $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
110 writeItr itr itrWillChunkBody True
112 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
113 when (reqMethod req /= HEAD)
114 $ do updateRes $! deleteHeader (C8.pack "Content-Type")
115 updateRes $! deleteHeader (C8.pack "Etag")
116 updateRes $! deleteHeader (C8.pack "Last-Modified")
118 conn <- readHeader (C8.pack "Connection")
121 Just value -> when (value `noCaseEq` C8.pack "close")
122 $ writeItr itr itrWillClose True
124 willClose <- readItr itr itrWillClose id
126 $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
128 when (reqMethod req == HEAD || not canHaveBody)
129 $ writeTVar (itrWillDiscardBody itr) True
131 readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
133 = readItr itr itrResponse $ getHeader name
135 updateRes :: (Response -> Response) -> STM ()
137 = updateItr itr itrResponse updator
140 completeUnconditionalHeaders :: Config -> Response -> IO Response
141 completeUnconditionalHeaders !conf !res
142 = compServer res >>= compDate
145 = case getHeader (C8.pack "Server") res' of
146 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
147 Just _ -> return res'
150 = case getHeader (C8.pack "Date") res' of
151 Nothing -> do date <- getCurrentDate
152 return $ setHeader (C8.pack "Date") date res'
153 Just _ -> return res'
156 cache :: IORef (UTCTime, Strict.ByteString)
157 cache = unsafePerformIO $
158 newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
159 {-# NOINLINE cache #-}
161 getCurrentDate :: IO Strict.ByteString
162 getCurrentDate = do now <- getCurrentTime
163 (cachedTime, cachedStr) <- readIORef cache
165 if now `mostlyEq` cachedTime then
168 do let dateStr = C8.pack $ formatHTTPDateTime now
169 writeIORef cache (now, dateStr)
172 mostlyEq :: UTCTime -> UTCTime -> Bool
174 = (utctDay a == utctDay b)
176 (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))