- rsrc :: Maybe (Resource ())
- rsrc = case reqMethod $ fromJust $ itrRequest itr of
- GET -> resGet def
- HEAD -> case resHead def of
- Just r -> Just r
- Nothing -> resGet def
- POST -> resPost def
- PUT -> resPut def
- DELETE -> resDelete def
-
- notAllowed :: Resource ()
- notAllowed = do setStatus MethodNotAllowed
- setHeader "Allow" $ joinWith ", " allowedMethods
-
- allowedMethods :: [String]
- allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
- , methods resHead ["GET", "HEAD"]
- , methods resPost ["POST"]
- , methods resPut ["PUT"]
- , methods resDelete ["DELETE"]
- ]
-
- methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
- methods f xs = case f def of
- Just _ -> xs
- Nothing -> []
-
- processException :: Config -> Exception -> IO ()
- processException conf exc
- = do let abo = case exc of
- ErrorCall msg -> Abortion InternalServerError [] msg
- IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE
- DynException dynE -> case fromDynamic dynE of
- Just (abo :: Abortion) -> abo
- Nothing
- -> Abortion InternalServerError []
- $ show exc
- _ -> Abortion InternalServerError [] $ show exc
- -- まだ DecidingHeader 以前の状態だったら、この途中終了
- -- を應答に反映させる餘地がある。さうでなければ stderr
- -- にでも吐くしか無い。
- state <- atomically $ readItr itr itrState id
- if state <= DecidingHeader then
- flip runReaderT itr
- $ do setStatus $ aboStatus abo
- -- FIXME: 同じ名前で複數の値があった時は、こ
- -- れではまずいと思ふ。
- mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
- setHeader "Content-Type" "application/xhtml+xml"
- output $ aboPage conf abo
- else
- hPutStrLn stderr $ show abo
-
- flip runReaderT itr $ driftTo Done
-
- formatIOE :: IOError -> String
- formatIOE ioE = if isUserError ioE then
- ioeGetErrorString ioE
- else
- show ioE
-
-
-{- Resource モナド -}
-
+ accEncP :: Parser (String, Maybe Double)
+ accEncP = do coding <- token
+ qVal <- option Nothing
+ $ do string ";q="
+ q <- qvalue
+ return $ Just q
+ return (normalizeCoding coding, qVal)
+
+ normalizeCoding :: String -> String
+ normalizeCoding coding
+ = case map toLower coding of
+ "x-gzip" -> "gzip"
+ "x-compress" -> "compress"
+ other -> other
+
+-- |Get the header \"Content-Type\" as
+-- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
+getContentType :: Resource (Maybe MIMEType)
+getContentType
+ = do cTypeM <- getHeader "Content-Type"
+ case cTypeM of
+ Nothing
+ -> return Nothing
+ Just cType
+ -> case parseStr mimeTypeP cType of
+ (Success t, _) -> return $ Just t
+ _ -> abort BadRequest []
+ (Just $ "Unparsable Content-Type: " ++ cType)
+
+
+{- ExaminingRequest 時に使用するアクション群 -}
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. If this is a GET or HEAD request, a found entity means
+-- a datum to be replied. If this is a PUT or DELETE request, it means
+-- a datum which was stored for the URI up to now. It is an error to
+-- compute 'foundEntity' if this is a POST request.
+--
+-- Computation of 'foundEntity' performs \"If-Match\" test or
+-- \"If-None-Match\" test if possible. When those tests fail, the
+-- computation of 'Resource' immediately aborts with status \"412
+-- Precondition Failed\" or \"304 Not Modified\" depending on the
+-- situation.
+--
+-- If this is a GET or HEAD request, 'foundEntity' automatically puts
+-- \"ETag\" and \"Last-Modified\" headers into the response.
+foundEntity :: ETag -> ClockTime -> Resource ()
+foundEntity tag timeStamp
+ = tag `seq` timeStamp `seq`
+ do driftTo ExaminingRequest
+
+ method <- getMethod
+ when (method == GET || method == HEAD)
+ $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundEntity for POST request.")
+ foundETag tag
+
+ driftTo GettingBody
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
+-- the response.
+--
+-- This action is not preferred. You should use 'foundEntity' when
+-- possible.
+foundETag :: ETag -> Resource ()
+foundETag tag
+ = tag `seq`
+ do driftTo ExaminingRequest
+
+ method <- getMethod
+ when (method == GET || method == HEAD)
+ $ setHeader' "ETag" $! show tag
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundETag for POST request.")
+
+ -- If-Match があればそれを見る。
+ ifMatch <- getHeader "If-Match"
+ case ifMatch of
+ Nothing -> return ()
+ Just "*" -> return ()
+ Just list -> case parseStr eTagListP list of
+ (Success tags, _)
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ -> when (not $ any (== tag) tags)
+ $ abort PreconditionFailed []
+ $! Just ("The entity tag doesn't match: " ++ list)
+ _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+
+ let statusForNoneMatch = if method == GET || method == HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-None-Match があればそれを見る。
+ ifNoneMatch <- getHeader "If-None-Match"
+ case ifNoneMatch of
+ Nothing -> return ()
+ Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
+ Just list -> case parseStr eTagListP list of
+ (Success tags, _)
+ -> when (any (== tag) tags)
+ $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
+ _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
+
+ driftTo GettingBody
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
+-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
+-- \"If-None-Match\" test. Be aware that any tests based on last
+-- modification time are unsafe because it is possible to mess up such
+-- tests by modifying the entity twice in a second.
+--
+-- This action is not preferred. You should use 'foundEntity' when
+-- possible.
+foundTimeStamp :: ClockTime -> Resource ()
+foundTimeStamp timeStamp
+ = timeStamp `seq`
+ do driftTo ExaminingRequest
+
+ method <- getMethod
+ when (method == GET || method == HEAD)
+ $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundTimeStamp for POST request.")
+
+ let statusForIfModSince = if method == GET || method == HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-Modified-Since があればそれを見る。
+ ifModSince <- getHeader "If-Modified-Since"
+ case ifModSince of
+ Just str -> case parseHTTPDateTime str of
+ Just lastTime
+ -> when (timeStamp <= lastTime)
+ $ abort statusForIfModSince []
+ $! Just ("The entity has not been modified since " ++ str)
+ Nothing
+ -> return () -- 不正な時刻は無視
+ Nothing -> return ()
+
+ -- If-Unmodified-Since があればそれを見る。
+ ifUnmodSince <- getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str -> case parseHTTPDateTime str of
+ Just lastTime
+ -> when (timeStamp > lastTime)
+ $ abort PreconditionFailed []
+ $! Just ("The entity has not been modified since " ++ str)
+ Nothing
+ -> return () -- 不正な時刻は無視
+ Nothing -> return ()
+
+ driftTo GettingBody
+
+-- | Computation of @'foundNoEntity' mStr@ tells the system that the
+-- 'Resource' found no entity for the request URI. @mStr@ is an
+-- optional error message to be replied to the client.
+--
+-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
+-- test and aborts with status \"412 Precondition Failed\" when it
+-- failed. If this is a GET, HEAD, POST or DELETE request,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
+foundNoEntity :: Maybe String -> Resource ()
+foundNoEntity msgM
+ = msgM `seq`
+ do driftTo ExaminingRequest
+
+ method <- getMethod
+ when (method /= PUT)
+ $ abort NotFound [] msgM
+
+ -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+ -- If-Match: 條件も滿たさない。
+ ifMatch <- getHeader "If-Match"
+ when (ifMatch /= Nothing)
+ $ abort PreconditionFailed [] msgM
+
+ driftTo GettingBody
+
+
+{- GettingBody 時に使用するアクション群 -}
+
+-- | Computation of @'input' limit@ attempts to read the request body
+-- up to @limit@ bytes, and then make the 'Resource' transit to
+-- /Deciding Header/ state. When the actual size of body is larger
+-- than @limit@ bytes, computation of 'Resource' immediately aborts
+-- with status \"413 Request Entity Too Large\". When the request has
+-- no body, 'input' returns an empty string.
+--
+-- @limit@ may be less than or equal to zero. In this case, the
+-- default limitation value
+-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
+-- 'defaultLimit'.
+--
+-- Note that 'inputBS' is more efficient than 'input' so you should
+-- use it whenever possible.