5 module Network.HTTP.Lucu.Postprocess
7 , completeUnconditionalHeaders
11 import Control.Concurrent.STM
13 import qualified Data.ByteString as Strict (ByteString)
14 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
18 import qualified Data.Time.HTTP as HTTP
19 import GHC.Conc (unsafeIOToSTM)
20 import Network.HTTP.Lucu.Abortion
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.Headers
23 import Network.HTTP.Lucu.HttpVersion
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import System.IO.Unsafe
31 * Response が未設定なら、200 OK にする。
33 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
35 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
37 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
40 * Content-Length があれば、それを削除する。Transfer-Encoding があって
43 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
46 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
47 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
50 * body を持つ事が出來ない時、body 破棄フラグを立てる。
52 * Connection: close が設定されてゐる時、切斷フラグを立てる。
54 * 切斷フラグが立ってゐる時、Connection: close を設定する。
62 postprocess :: Interaction -> STM ()
64 = do reqM <- readItr itr itrRequest id
65 res <- readItr itr itrResponse id
66 let sc = resStatus res
68 unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])
69 $ abortSTM InternalServerError []
70 $ Just ("The status code is not good for a final status: "
73 when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
74 $ abortSTM InternalServerError []
75 $ Just ("The status was " ++ show sc ++ " but no Allow header.")
77 when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
78 $ abortSTM InternalServerError []
79 $ Just ("The status code was " ++ show sc ++ " but no Location header.")
81 when (reqM /= Nothing) relyOnRequest
83 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
85 do oldRes <- readItr itr itrResponse id
86 newRes <- unsafeIOToSTM
87 $ completeUnconditionalHeaders (itrConfig itr) oldRes
88 writeItr itr itrResponse newRes
90 relyOnRequest :: STM ()
92 = do status <- readItr itr itrResponse resStatus
93 req <- readItr itr itrRequest fromJust
95 let reqVer = reqVersion req
96 canHaveBody = if reqMethod req == HEAD then
99 not (isInformational status ||
100 status == NoContent ||
101 status == ResetContent ||
102 status == NotModified )
104 updateRes $! deleteHeader (C8.pack "Content-Length")
105 updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
107 cType <- readHeader (C8.pack "Content-Type")
108 when (cType == Nothing)
109 $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
112 when (reqVer == HttpVersion 1 1)
113 $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
114 writeItr itr itrWillChunkBody True
116 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
117 when (reqMethod req /= HEAD)
118 $ do updateRes $! deleteHeader (C8.pack "Content-Type")
119 updateRes $! deleteHeader (C8.pack "Etag")
120 updateRes $! deleteHeader (C8.pack "Last-Modified")
122 conn <- readHeader (C8.pack "Connection")
125 Just value -> when (value `noCaseEq` C8.pack "close")
126 $ writeItr itr itrWillClose True
128 willClose <- readItr itr itrWillClose id
130 $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
132 when (reqMethod req == HEAD || not canHaveBody)
133 $ writeTVar (itrWillDiscardBody itr) True
135 readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
137 = readItr itr itrResponse $ getHeader name
139 updateRes :: (Response -> Response) -> STM ()
141 = updateItr itr itrResponse updator
144 completeUnconditionalHeaders :: Config -> Response -> IO Response
145 completeUnconditionalHeaders !conf !res
146 = compServer res >>= compDate
149 = case getHeader (C8.pack "Server") res' of
150 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
151 Just _ -> return res'
154 = case getHeader (C8.pack "Date") res' of
155 Nothing -> do date <- getCurrentDate
156 return $ setHeader (C8.pack "Date") date res'
157 Just _ -> return res'
160 cache :: IORef (UTCTime, Strict.ByteString)
161 cache = unsafePerformIO $
162 newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
163 {-# NOINLINE cache #-}
165 getCurrentDate :: IO Strict.ByteString
166 getCurrentDate = do now <- getCurrentTime
167 (cachedTime, cachedStr) <- readIORef cache
169 if now `mostlyEq` cachedTime then
172 do let dateStr = C8.pack $ HTTP.format now
173 writeIORef cache (now, dateStr)
176 mostlyEq :: UTCTime -> UTCTime -> Bool
178 = (utctDay a == utctDay b)
180 (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))