From 636a3b3334f1ede61dc1e6faa2c4a021ea9bbd5c Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 2 Oct 2007 23:59:00 +0900 Subject: [PATCH] Added new actions to the Resource. darcs-hash:20071002145900-62b54-89be9254e0b4e65f57b3248fb40ae6d2ee264908.gz --- Lucu.cabal | 10 ++-- Makefile | 1 + Network/HTTP/Lucu/Parser/Http.hs | 19 ++++++- Network/HTTP/Lucu/Resource.hs | 93 ++++++++++++++++++++++++++------ Network/HTTP/Lucu/Utils.hs | 2 +- 5 files changed, 105 insertions(+), 20 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 22a64f0..0fb5c07 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -17,7 +17,7 @@ Homepage: http://ccm.sherry.jp/lucu/ Category: Network Tested-With: GHC == 6.6.1 Build-Depends: - base, mtl, network, stm, hxt, haskell-src, unix + base, mtl, network, stm, hxt, haskell-src, unix Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion @@ -52,8 +52,12 @@ Extra-Source-Files: data/mime.types examples/HelloWorld.hs examples/Makefile -ghc-options: -fglasgow-exts -fwarn-missing-signatures -fwarn-unused-imports -funbox-strict-fields -O3 ---ghc-options: -fglasgow-exts +ghc-options: + -fglasgow-exts + -fwarn-missing-signatures + -fwarn-unused-imports + -funbox-strict-fields + -O3 --Executable: HelloWorld diff --git a/Makefile b/Makefile index 7c0b30e..6b4ad4d 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,7 @@ run: build $(MAKE) -C examples run .setup-config: $(CABAL_FILE) Setup +# ./Setup configure ./Setup configure -p Setup: Setup.hs diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index cb21d29..77dbe7f 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -13,13 +13,14 @@ module Network.HTTP.Lucu.Parser.Http , text , separator , quotedStr + , qvalue ) where import Data.List import Network.HTTP.Lucu.Parser --- |@'isCtl' c@ is True iff @0x20 <= @c@ < 0x7F@. +-- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@. isCtl :: Char -> Bool isCtl c | c < '\x1f' = True @@ -105,3 +106,19 @@ quotedStr = do char '"' quotedPair = do q <- char '\\' c <- satisfy isChar return [c] + +-- |'qvalue' accepts a so-called qvalue. +qvalue :: Parser Double +qvalue = do x <- char '0' + xs <- option "" + $ do x <- char '.' + xs <- many digit -- 本當は三文字までに制限 + return (x:xs) + return $ read (x:xs) + <|> + do x <- char '1' + xs <- option "" + $ do x <- char '.' + xs <- many (char '0') -- 本當は三文字までに制限 + return (x:xs) + return $ read (x:xs) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index bacb00f..fcf2359 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -74,11 +74,13 @@ module Network.HTTP.Lucu.Resource , getRequest , getMethod , getRequestURI + , getRequestVersion , getResourcePath , getPathInfo , getQueryForm , getHeader , getAccept + , getAcceptEncoding , getContentType -- ** Finding an entity @@ -111,6 +113,7 @@ module Network.HTTP.Lucu.Resource , redirect , setContentType , setLocation + , setContentEncoding -- ** Writing a response body @@ -130,6 +133,7 @@ import Control.Monad.Reader import Data.Bits import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Char import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion @@ -137,8 +141,10 @@ import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H +import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request @@ -202,6 +208,11 @@ getRequestURI :: Resource URI getRequestURI = do req <- getRequest return $! reqURI req +-- |Get the HTTP version of the request. +getRequestVersion :: Resource HttpVersion +getRequestVersion = do req <- getRequest + return $! reqVersion req + -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this @@ -263,25 +274,71 @@ getHeader name = name `seq` -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". getAccept :: Resource [MIMEType] -getAccept = do accept <- getHeader "Accept" - if accept == Nothing then - return [] - else - case parseStr mimeTypeListP $ fromJust accept of - (Success xs, _) -> return xs - _ -> return [] +getAccept = do acceptM <- getHeader "Accept" + case acceptM of + Nothing + -> return [] + Just accept + -> case parseStr mimeTypeListP accept of + (Success xs, _) -> return xs + _ -> abort BadRequest [] + (Just $ "Unparsable Accept: " ++ accept) + +-- |Get a list of @(contentCoding, qvalue)@ enumerated on header +-- \"Accept-Encoding\". +getAcceptEncoding :: Resource [(String, Maybe Double)] +getAcceptEncoding + = do accEncM <- getHeader "Accept-Encoding" + case accEncM of + Nothing + -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い + -- ので安全の爲 identity が指定された事にする。HTTP/1.1 + -- の場合は何でも受け入れて良い事になってゐるので "*" が + -- 指定された事にする。 + -> do ver <- getRequestVersion + case ver of + HttpVersion 1 0 -> return [("identity", Nothing)] + HttpVersion 1 1 -> return [("*" , Nothing)] + Just "" + -- identity のみが許される。 + -> return [("identity", Nothing)] + Just accEnc + -> case parseStr accEncListP accEnc of + (Success x, _) -> return x + _ -> abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ++ accEnc) + where + accEncListP :: Parser [(String, Maybe Double)] + accEncListP = allowEOF $! listOf accEncP + + 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 cType <- getHeader "Content-Type" - if cType == Nothing then - return Nothing - else - case parseStr mimeTypeP $ fromJust cType of - (Success t, _) -> return $ Just t - _ -> return Nothing - +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 時に使用するアクション群 -} @@ -703,6 +760,12 @@ setLocation :: URI -> Resource () setLocation uri = setHeader "Location" $ uriToString id uri $ "" +-- |Computation of @'setContentEncoding' codings@ sets the response +-- header \"Content-Encoding\" to @codings@. +setContentEncoding :: [String] -> Resource () +setContentEncoding codings + = setHeader "Content-Encoding" $ joinWith ", " codings + {- DecidingBody 時に使用するアクション群 -} diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index d6e46f1..d92516e 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -25,7 +25,7 @@ splitBy isSeparator src of (last , [] ) -> last : [] (first, sep:rest) -> first : splitBy isSeparator rest --- |> joinWith ':' ["ab", "c", "def"] +-- |> joinWith ":" ["ab", "c", "def"] -- > ==> "ab:c:def" joinWith :: [a] -> [[a]] -> [a] joinWith separator xs -- 2.40.0