From 5e561403ba8ad9c440cc2bf2bacb61ebc3c7a111 Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 3 Nov 2011 13:30:27 +0900 Subject: [PATCH] New module: Network.HTTP.Lucu.MIMEType.TH Ditz-issue: c566a8433e8af700655680f53e99cfe9f563ed32 --- Lucu.cabal | 4 +- .../HTTP/Lucu/{RFC2231.hs => MIMEParams.hs} | 43 ++++++++---- Network/HTTP/Lucu/MIMEType.hs | 66 ++++++++++-------- Network/HTTP/Lucu/MIMEType/TH.hs | 37 ++++++++++ Network/HTTP/Lucu/MultipartForm.hs | 24 ++++--- Network/HTTP/Lucu/Resource.hs | 5 +- Network/HTTP/Lucu/StaticFile.hs | 7 +- Network/HTTP/Lucu/Utils.hs | 67 +++++++++++++++---- ...6a8433e8af700655680f53e99cfe9f563ed32.yaml | 8 ++- 9 files changed, 188 insertions(+), 73 deletions(-) rename Network/HTTP/Lucu/{RFC2231.hs => MIMEParams.hs} (90%) create mode 100644 Network/HTTP/Lucu/MIMEType/TH.hs diff --git a/Lucu.cabal b/Lucu.cabal index 46fabcf..48c9268 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -64,6 +64,7 @@ Library network == 2.3.*, stm == 2.2.*, stringsearch == 0.3.*, + template-haskell == 2.5.*, text == 0.11.*, time == 1.2.*, time-http == 0.2.*, @@ -78,13 +79,14 @@ Library Network.HTTP.Lucu.ETag Network.HTTP.Lucu.HttpVersion Network.HTTP.Lucu.Httpd + Network.HTTP.Lucu.MIMEParams Network.HTTP.Lucu.MIMEType Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess + Network.HTTP.Lucu.MIMEType.TH Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Parser.Http Network.HTTP.Lucu.Parser - Network.HTTP.Lucu.RFC2231 Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Resource.Tree diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/MIMEParams.hs similarity index 90% rename from Network/HTTP/Lucu/RFC2231.hs rename to Network/HTTP/Lucu/MIMEParams.hs index 1046c5d..b3edeb5 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -1,16 +1,17 @@ {-# LANGUAGE - DoAndIfThenElse + DeriveDataTypeable + , DoAndIfThenElse + , GeneralizedNewtypeDeriving , OverloadedStrings , RecordWildCards + , TemplateHaskell , UnicodeSyntax #-} --- |Provide functionalities to encode/decode MIME parameter values in --- character sets other than US-ASCII. See: --- --- --- You usually don't have to use this module directly. -module Network.HTTP.Lucu.RFC2231 - ( printMIMEParams +-- |Parsing and printing MIME parameter values +-- (). +module Network.HTTP.Lucu.MIMEParams + ( MIMEParams(..) + , printMIMEParams , mimeParams ) where @@ -23,9 +24,11 @@ import Data.Attoparsec.Char8 as P import Data.Bits import qualified Data.ByteString.Char8 as BS import Data.Char +import Data.Data import Data.Foldable import Data.Map (Map) import qualified Data.Map as M +import Data.Monoid import Data.Monoid.Unicode import Data.Sequence (Seq, ViewL(..)) import qualified Data.Sequence as S @@ -36,15 +39,29 @@ import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Traversable import Data.Word +import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude hiding (concat, mapM, takeWhile) import Prelude.Unicode +-- |A map from MIME parameter attributes to values. Attributes are +-- always case-insensitive according to RFC 2045 +-- (). +newtype MIMEParams + = MIMEParams (Map CIAscii Text) + deriving (Eq, Show, Read, Monoid, Typeable) + +instance Lift MIMEParams where + lift (MIMEParams m) = [| MIMEParams $(liftParams m) |] + where + liftParams ∷ Map CIAscii Text → Q Exp + liftParams = liftMap liftCIAscii liftText + -- |Convert MIME parameter values to an 'AsciiBuilder'. -printMIMEParams ∷ Map CIAscii Text → AsciiBuilder +printMIMEParams ∷ MIMEParams → AsciiBuilder {-# INLINEABLE printMIMEParams #-} -printMIMEParams m = M.foldlWithKey f (∅) m +printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m -- THINKME: Use foldlWithKey' for newer Data.Map where f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder @@ -124,7 +141,7 @@ section (InitialEncodedParam {..}) = 0 section ep = epSection ep -- |'Parser' for MIME parameter values. -mimeParams ∷ Parser (Map CIAscii Text) +mimeParams ∷ Parser MIMEParams {-# INLINEABLE mimeParams #-} mimeParams = decodeParams =≪ P.many (try paramP) @@ -202,9 +219,9 @@ rawChars ∷ Parser BS.ByteString {-# INLINE rawChars #-} rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') -decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) +decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams {-# INLINE decodeParams #-} -decodeParams = (mapM decodeSections =≪) ∘ sortBySection +decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection sortBySection ∷ Monad m ⇒ [ExtendedParam] diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 1aebc9f..9c34c50 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,9 +1,12 @@ {-# LANGUAGE - OverloadedStrings + DeriveDataTypeable + , OverloadedStrings + , RecordWildCards + , TemplateHaskell , UnicodeSyntax #-} - --- |MIME Types +-- |Parsing and printing MIME Media Types +-- (). module Network.HTTP.Lucu.MIMEType ( MIMEType(..) , mkMIMEType @@ -19,44 +22,51 @@ import Control.Applicative import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P -import Data.Map (Map) import Data.Monoid.Unicode -import Data.Text (Text) +import Data.Typeable +import Language.Haskell.TH.Syntax +import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.RFC2231 -import Prelude hiding (min) +import Network.HTTP.Lucu.Utils import Prelude.Unicode --- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\"), ...]@ --- represents \"major\/minor; name=value; ...\". -data MIMEType = MIMEType { - mtMajor ∷ !CIAscii - , mtMinor ∷ !CIAscii - , mtParams ∷ !(Map CIAscii Text) - } deriving (Eq) +-- |A media type, subtype, and parameters. +data MIMEType + = MIMEType { + mtMedia ∷ !CIAscii + , mtSub ∷ !CIAscii + , mtParams ∷ !MIMEParams + } + deriving (Eq, Show, Read, Typeable) -instance Show MIMEType where - show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType +instance Lift MIMEType where + lift (MIMEType {..}) + = [| MIMEType { + mtMedia = $(liftCIAscii mtMedia) + , mtSub = $(liftCIAscii mtSub) + , mtParams = $(lift mtParams) + } + |] --- |@'mkMIMEType' major minor@ returns a 'MIMEType' with the given --- @major@ and @minor@ types but without any parameters. +-- |@'mkMIMEType' media sub@ returns a 'MIMEType' with the given +-- @media@ and @sub@ types but without any parameters. mkMIMEType ∷ CIAscii → CIAscii → MIMEType {-# INLINE mkMIMEType #-} -mkMIMEType maj min - = MIMEType maj min (∅) +mkMIMEType = flip flip (∅) ∘ MIMEType -- |Convert a 'MIMEType' to an 'AsciiBuilder'. printMIMEType ∷ MIMEType → AsciiBuilder {-# INLINEABLE printMIMEType #-} -printMIMEType (MIMEType maj min params) - = A.toAsciiBuilder (A.fromCIAscii maj) ⊕ +printMIMEType (MIMEType {..}) + = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕ A.toAsciiBuilder "/" ⊕ - A.toAsciiBuilder (A.fromCIAscii min) ⊕ - printMIMEParams params + A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕ + printMIMEParams mtParams -- |Parse 'MIMEType' from an 'Ascii'. This function throws an --- exception for parse error. +-- exception for parse error. For literals consider using +-- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'. parseMIMEType ∷ Ascii → MIMEType {-# INLINEABLE parseMIMEType #-} parseMIMEType str @@ -67,11 +77,11 @@ parseMIMEType str -- |'Parser' for an 'MIMEType'. mimeType ∷ Parser MIMEType {-# INLINEABLE mimeType #-} -mimeType = do maj ← A.toCIAscii <$> token +mimeType = do media ← A.toCIAscii <$> token _ ← char '/' - min ← A.toCIAscii <$> token + sub ← A.toCIAscii <$> token params ← mimeParams - return $ MIMEType maj min params + return $ MIMEType media sub params -- |'Parser' for a list of 'MIMEType's. mimeTypeList ∷ Parser [MIMEType] diff --git a/Network/HTTP/Lucu/MIMEType/TH.hs b/Network/HTTP/Lucu/MIMEType/TH.hs new file mode 100644 index 0000000..1aae0b4 --- /dev/null +++ b/Network/HTTP/Lucu/MIMEType/TH.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE + UnicodeSyntax + , ViewPatterns + #-} +module Network.HTTP.Lucu.MIMEType.TH + ( mimeType + ) + where +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Network.HTTP.Lucu.MIMEType hiding (mimeType) +import Network.HTTP.Lucu.Utils +import Prelude.Unicode + +-- |A 'QuasiQuoter' for 'MIMEType' literals. +-- +-- @ +-- textPlain :: 'MIMEType' +-- textPlain = ['mimeType'| text/plain; charset="UTF-8" |] +-- @ +mimeType ∷ QuasiQuoter +mimeType = QuasiQuoter { + quoteExp = (lift ∘ parseMIMEType =≪) ∘ toAscii + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = const unsupported + } + where + toAscii ∷ Monad m ⇒ String → m Ascii + toAscii (A.fromChars ∘ trim → Just a) = return a + toAscii str = fail $ "Malformed MIME Type: " ⧺ str + + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of mimeType quasi-quoter." diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 16d8f28..fd85eaf 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -8,7 +8,7 @@ , ViewPatterns #-} -- |Parse \"multipart/form-data\" based on RFC 2388: --- +-- -- -- You usually don't have to use this module directly. module Network.HTTP.Lucu.MultipartForm @@ -29,7 +29,6 @@ import qualified Data.ByteString.Lazy as LS import Data.ByteString.Lazy.Search import Data.Foldable import Data.List -import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Monoid.Unicode @@ -38,10 +37,10 @@ import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.RFC2231 import Prelude.Unicode -- |'FormData' represents a form value and possibly an uploaded file @@ -66,7 +65,7 @@ data Part data ContDispo = ContDispo { dType ∷ !CIAscii - , dParams ∷ !(Map CIAscii Text) + , dParams ∷ !MIMEParams } printContDispo ∷ ContDispo → Ascii @@ -85,10 +84,10 @@ printContDispo d -- -- * \"Content-Transfer-Encoding\" is always ignored. -- --- * RFC 2388 says that non-ASCII field names are encoded according --- to the method in RFC 2047 --- , but they won't be --- decoded. +-- * RFC 2388 () says +-- that non-ASCII field names are encoded according to the method in +-- RFC 2047 (), but they won't +-- be decoded. parseMultipartFormData ∷ Ascii -- ^boundary → LS.ByteString -- ^input → Either String [(Ascii, FormData)] @@ -229,7 +228,7 @@ partToFormPair pt@(Part {..}) partName ∷ MonadError String m ⇒ Part → m Ascii {-# INLINEABLE partName #-} partName (Part {..}) - = case M.lookup "name" $ dParams ptContDispo of + = case M.lookup "name" params of Just name → case A.fromText name of Just a → return a @@ -238,7 +237,10 @@ partName (Part {..}) Nothing → throwError $ "form-data without name: " ⧺ A.toString (printContDispo ptContDispo) + where + params = case dParams ptContDispo of + MIMEParams m → m partFileName ∷ Part → Maybe Text -partFileName (Part {..}) - = M.lookup "filename" $ dParams ptContDispo +partFileName (dParams ∘ ptContDispo → MIMEParams m) + = M.lookup "filename" m diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 474f79a..e6a03ac 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -173,6 +173,7 @@ import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) @@ -591,8 +592,8 @@ getForm limit Just a → return a Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" - readMultipartFormData params - = case M.lookup "boundary" params of + readMultipartFormData (MIMEParams m) + = case M.lookup "boundary" m of Nothing → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" Just boundary diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 4f66931..90cdcb0 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , QuasiQuotes , UnicodeSyntax #-} -- | Handling static files on the filesystem. @@ -27,8 +28,9 @@ import Data.Time.Clock.POSIX import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType hiding (mimeType) import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response @@ -46,8 +48,7 @@ staticFile path } octetStream ∷ MIMEType -{-# NOINLINE octetStream #-} -octetStream = parseMIMEType "application/octet-stream" +octetStream = [mimeType| application/octet-stream |] handleStaticFile ∷ Bool → FilePath → Resource () handleStaticFile sendContent path diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 3d38b8b..5cee03a 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings + , TemplateHaskell , UnicodeSyntax #-} -- |Utility functions used internally in the Lucu httpd. These @@ -10,23 +11,34 @@ module Network.HTTP.Lucu.Utils , parseWWWFormURLEncoded , splitPathInfo , show3 + , trim + , liftCIAscii + , liftText + , liftMap ) where import Blaze.ByteString.Builder.ByteString as B import Blaze.Text.Int as BT import Control.Monad -import Data.Ascii (Ascii, AsciiBuilder) +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS +import Data.Char import Data.List hiding (last) +import Data.Map (Map) +import qualified Data.Map as M import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax import Network.URI import Prelude hiding (last) import Prelude.Unicode --- |> splitBy (== ':') "ab:c:def" --- > ==> ["ab", "c", "def"] +-- |>>> splitBy (== ':') "ab:c:def" +-- ["ab", "c", "def"] splitBy ∷ (a → Bool) → [a] → [[a]] {-# INLINEABLE splitBy #-} splitBy isSep src @@ -34,11 +46,11 @@ splitBy isSep src (last , [] ) → [last] (first, _sep:rest) → first : splitBy isSep rest --- |> quoteStr "abc" --- > ==> "\"abc\"" +-- |>>> quoteStr "abc" +-- "\"abc\"" -- --- > quoteStr "ab\"c" --- > ==> "\"ab\\\"c\"" +-- >>> quoteStr "ab\"c" +-- "\"ab\\\"c\"" quoteStr ∷ Ascii → AsciiBuilder quoteStr str = A.toAsciiBuilder "\"" ⊕ go (A.toByteString str) (∅) ⊕ @@ -55,8 +67,8 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ b2ab ∷ BS.ByteString → AsciiBuilder b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString --- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" --- > ==> [("aaa", "bbb"), ("ccc", "ddd")] +-- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" +-- [("aaa", "bbb"), ("ccc", "ddd")] parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)] parseWWWFormURLEncoded src -- THINKME: We could gain some performance by using attoparsec @@ -77,8 +89,8 @@ parseWWWFormURLEncoded src plusToSpace '+' = ' ' plusToSpace c = c --- |> splitPathInfo "http://example.com/foo/bar" --- > ==> ["foo", "bar"] +-- |>>> splitPathInfo "http://example.com/foo/bar" +-- ["foo", "bar"] splitPathInfo ∷ URI → [ByteString] splitPathInfo uri = let reqPathStr = uriPath uri @@ -86,8 +98,8 @@ splitPathInfo uri in map BS.pack reqPath --- |> show3 5 --- > ==> "005" +-- |>>> show3 5 +-- "005" show3 ∷ Integral n ⇒ n → AsciiBuilder {-# INLINEABLE show3 #-} show3 = A.unsafeFromBuilder ∘ go @@ -98,3 +110,32 @@ show3 = A.unsafeFromBuilder ∘ go | otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i) -- FIXME: Drop this function as soon as possible, to eliminate the -- dependency on blaze-textual. + +-- |>>> trim " ab c d " +-- "ab c d" +trim ∷ String → String +trim = reverse ∘ f ∘ reverse ∘ f + where + f = dropWhile isSpace + +-- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. +liftCIAscii ∷ CIAscii → Q Exp +liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |] + where + strLit ∷ CIAscii → Q Exp + strLit = liftString ∘ A.toString ∘ A.fromCIAscii + +-- |Convert a 'Text' to an 'Exp' representing it as a literal. +liftText ∷ Text → Q Exp +liftText t = [| T.pack $(strLit t) |] + where + strLit ∷ Text → Q Exp + strLit = liftString ∘ T.unpack + +-- |Convert an arbitrary 'Map' to an 'Exp' representing it as a +-- literal, using a given key lifter and a value lifter. +liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp +liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |] + where + liftPairs = listE ∘ map liftPair + liftPair (k, v) = tupE [liftK k, liftV v] diff --git a/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml b/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml index d48a69f..48f876f 100644 --- a/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml +++ b/bugs/issue-c566a8433e8af700655680f53e99cfe9f563ed32.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-10-31 22:25:21.576787 Z references: [] @@ -16,4 +16,8 @@ log_events: - PHO - created - "" -git_branch: +- - 2011-11-01 22:31:41.771947 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: template-haskell -- 2.40.0