From db4a546d0d462cb94639b1f273bf0b78bccc960c Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 19 Dec 2011 23:30:34 +0900 Subject: [PATCH] Done. Ditz-issue: d23a51590bc111f85646532c9a8538dd04aa20b4 --- Data/Attoparsec/Parsable.hs | 48 +++++----- Lucu.cabal | 1 - Network/HTTP/Lucu.hs | 3 +- Network/HTTP/Lucu/Authentication.hs | 44 ++++----- Network/HTTP/Lucu/Chunk.hs | 3 +- Network/HTTP/Lucu/ContentCoding.hs | 30 ++++--- Network/HTTP/Lucu/ETag.hs | 28 +++--- Network/HTTP/Lucu/Headers.hs | 58 ++++++------ Network/HTTP/Lucu/HttpVersion.hs | 13 +-- Network/HTTP/Lucu/Implant.hs | 3 +- Network/HTTP/Lucu/MIMEParams.hs | 54 +++++------ Network/HTTP/Lucu/MIMEType.hs | 63 +++++++++---- Network/HTTP/Lucu/MIMEType/Guess.hs | 89 ++++++++++--------- Network/HTTP/Lucu/MIMEType/TH.hs | 47 ---------- Network/HTTP/Lucu/MultipartForm.hs | 21 +++-- Network/HTTP/Lucu/Request.hs | 33 ++++--- Network/HTTP/Lucu/RequestReader.hs | 3 +- Network/HTTP/Lucu/Resource.hs | 21 +++-- Network/HTTP/Lucu/StaticFile.hs | 3 +- ...a51590bc111f85646532c9a8538dd04aa20b4.yaml | 8 +- 20 files changed, 287 insertions(+), 286 deletions(-) delete mode 100644 Network/HTTP/Lucu/MIMEType/TH.hs diff --git a/Data/Attoparsec/Parsable.hs b/Data/Attoparsec/Parsable.hs index a991607..d801fb7 100644 --- a/Data/Attoparsec/Parsable.hs +++ b/Data/Attoparsec/Parsable.hs @@ -16,50 +16,50 @@ import Data.Word -- |Class of types which have their corresponding parsers. -- --- Minimal complete definition: 'parse' +-- Minimal complete definition: 'parser' class Parsable t a where - parse :: Parser t a + parser :: Parser t a instance Parsable B.ByteString Word8 where - {-# INLINE CONLIKE parse #-} - parse = B.anyWord8 + {-# INLINE CONLIKE parser #-} + parser = B.anyWord8 instance Parsable B.ByteString Char where - {-# INLINE CONLIKE parse #-} - parse = B.anyChar + {-# INLINE CONLIKE parser #-} + parser = B.anyChar instance Parsable B.ByteString B.ByteString where - {-# INLINE CONLIKE parse #-} - parse = B.takeByteString + {-# INLINE CONLIKE parser #-} + parser = B.takeByteString instance Parsable B.ByteString LB.ByteString where - {-# INLINE CONLIKE parse #-} - parse = B.takeLazyByteString + {-# INLINE CONLIKE parser #-} + parser = B.takeLazyByteString instance Parsable B.ByteString Double where - {-# INLINE CONLIKE parse #-} - parse = B.double + {-# INLINE CONLIKE parser #-} + parser = B.double instance Parsable B.ByteString Number where - {-# INLINE CONLIKE parse #-} - parse = B.number + {-# INLINE CONLIKE parser #-} + parser = B.number instance Parsable T.Text Char where - {-# INLINE CONLIKE parse #-} - parse = T.anyChar + {-# INLINE CONLIKE parser #-} + parser = T.anyChar instance Parsable T.Text T.Text where - {-# INLINE CONLIKE parse #-} - parse = T.takeText + {-# INLINE CONLIKE parser #-} + parser = T.takeText instance Parsable T.Text LT.Text where - {-# INLINE CONLIKE parse #-} - parse = T.takeLazyText + {-# INLINE CONLIKE parser #-} + parser = T.takeLazyText instance Parsable T.Text Double where - {-# INLINE CONLIKE parse #-} - parse = T.double + {-# INLINE CONLIKE parser #-} + parser = T.double instance Parsable T.Text Number where - {-# INLINE CONLIKE parse #-} - parse = T.number + {-# INLINE CONLIKE parser #-} + parser = T.number diff --git a/Lucu.cabal b/Lucu.cabal index 163b9b7..effcefd 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -107,7 +107,6 @@ Library 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 diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 876064c..f826176 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -81,8 +81,7 @@ import Network.HTTP.Lucu.Dispatcher import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.MIMEParams -import Network.HTTP.Lucu.MIMEType hiding (mimeType) -import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs index 69223f2..c91aa7e 100644 --- a/Network/HTTP/Lucu/Authentication.hs +++ b/Network/HTTP/Lucu/Authentication.hs @@ -12,14 +12,15 @@ module Network.HTTP.Lucu.Authentication , Realm , UserID , Password - , authCredential ) where import Control.Monad import Data.Ascii (Ascii, AsciiBuilder) import Data.Attempt import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable import qualified Data.ByteString.Base64 as B64 +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Data.Convertible.Base import Data.Convertible.Instances.Ascii () @@ -64,25 +65,24 @@ deriveAttempts [ ([t| AuthChallenge |], [t| Ascii |]) , ([t| AuthChallenge |], [t| AsciiBuilder |]) ] --- |'Parser' for an 'AuthCredential'. -authCredential ∷ Parser AuthCredential -authCredential - = do void $ string "Basic" - skipMany1 lws - b64 ← takeWhile1 base64 - case C8.break (≡ ':') (B64.decodeLenient b64) of - (user, cPassword) - | C8.null cPassword - → fail "no colons in the basic auth credential" - | otherwise - → do u ← asc user - p ← asc (C8.tail cPassword) - return (BasicAuthCredential u p) - where - base64 ∷ Char → Bool - base64 = inClass "a-zA-Z0-9+/=" +instance Parsable ByteString AuthCredential where + parser = do void $ string "Basic" + skipMany1 lws + b64 ← takeWhile1 base64 + case C8.break (≡ ':') (B64.decodeLenient b64) of + (user, cPassword) + | C8.null cPassword + → fail "no colons in the basic auth credential" + | otherwise + → do u ← asc user + p ← asc (C8.tail cPassword) + return (BasicAuthCredential u p) + where + base64 ∷ Char → Bool + base64 = inClass "a-zA-Z0-9+/=" - asc ∷ C8.ByteString → Parser Ascii - asc bs = case ca bs of - Success as → return as - Failure _ → fail "Non-ascii character in auth credential" + asc ∷ C8.ByteString → Parser Ascii + asc bs + = case ca bs of + Success as → return as + Failure _ → fail "Non-ascii character in auth credential" diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index e8c9de4..101ed74 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -9,6 +9,7 @@ module Network.HTTP.Lucu.Chunk where import Control.Applicative import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable import Data.Bits import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Parser.Http @@ -31,4 +32,4 @@ chunkFooter ∷ Parser () chunkFooter = crlf chunkTrailer ∷ Parser Headers -chunkTrailer = headers +chunkTrailer = parser diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index a5f02b1..033b48b 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -1,11 +1,11 @@ {-# LANGUAGE - OverloadedStrings + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.ContentCoding ( AcceptEncoding(..) - - , acceptEncodingList , normalizeCoding , unnormalizeCoding ) @@ -13,6 +13,8 @@ module Network.HTTP.Lucu.ContentCoding import Control.Applicative import Data.Ascii (CIAscii, toCIAscii) import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import Data.Ord import Data.Maybe import Network.HTTP.Lucu.Parser.Http @@ -34,24 +36,28 @@ instance Ord AcceptEncoding where q1' = fromMaybe 0 q1 q2' = fromMaybe 0 q2 -acceptEncodingList ∷ Parser [AcceptEncoding] -acceptEncodingList = listOf accEnc +instance Parsable ByteString [AcceptEncoding] where + {-# INLINE parser #-} + parser = listOf parser -accEnc ∷ Parser AcceptEncoding -accEnc = do coding ← toCIAscii <$> token - qVal ← option Nothing - $ do _ ← string ";q=" - q ← qvalue - return $ Just q - return $ AcceptEncoding (normalizeCoding coding) qVal +instance Parsable ByteString AcceptEncoding where + {-# INLINE parser #-} + parser = do coding ← toCIAscii <$> token + qVal ← option Nothing + $ do _ ← string ";q=" + q ← qvalue + return $ Just q + return $ AcceptEncoding (normalizeCoding coding) qVal normalizeCoding ∷ CIAscii → CIAscii +{-# INLINEABLE normalizeCoding #-} normalizeCoding coding | coding ≡ "x-gzip" = "gzip" | coding ≡ "x-compress" = "compress" | otherwise = coding unnormalizeCoding ∷ CIAscii → CIAscii +{-# INLINEABLE unnormalizeCoding #-} unnormalizeCoding coding | coding ≡ "gzip" = "x-gzip" | coding ≡ "compress" = "x-compress" diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 6d09aee..b049120 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -12,14 +12,14 @@ module Network.HTTP.Lucu.ETag ( ETag(..) , strongETag , weakETag - , eTag - , eTagList ) where import Control.Applicative import Control.Monad import Data.Ascii (Ascii, AsciiBuilder) import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils @@ -81,17 +81,15 @@ weakETag ∷ Ascii → ETag {-# INLINE weakETag #-} weakETag = ETag True --- |'Parser' for an 'ETag'. -eTag ∷ Parser ETag -{-# INLINEABLE eTag #-} -eTag = do isWeak ← option False (string "W/" *> return True) - str ← quotedStr - return $ ETag isWeak str +instance Parsable ByteString ETag where + {-# INLINEABLE parser #-} + parser = do isWeak ← option False (string "W/" *> return True) + str ← quotedStr + return $ ETag isWeak str --- |'Parser' for a list of 'ETag's. -eTagList ∷ Parser [ETag] -{-# INLINEABLE eTagList #-} -eTagList = do xs ← listOf eTag - when (null xs) $ - fail "empty list of ETags" - return xs +instance Parsable ByteString [ETag] where + {-# INLINEABLE parser #-} + parser = do xs ← listOf parser + when (null xs) $ + fail "empty list of ETags" + return xs diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index f0e6ad8..e664115 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -12,7 +12,6 @@ module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - , headers ) where import Control.Applicative hiding (empty) @@ -21,6 +20,8 @@ import Control.Monad import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import qualified Data.Collections.Newtype.TH as C import Data.Convertible.Base import Data.Convertible.Instances.Ascii () @@ -138,30 +139,31 @@ deriveAttempts [ ([t| Headers |], [t| Ascii |]) field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} -headers ∷ Parser Headers -{-# INLINEABLE headers #-} -headers = do xs ← many header - crlf - return $ fromFoldable xs - where - header ∷ Parser (CIAscii, Ascii) - header = do name ← cs <$> token - void $ char ':' - skipMany lws - values ← content `sepBy` try lws - skipMany (try lws) - crlf - return (name, joinValues values) - - content ∷ Parser Ascii - {-# INLINE content #-} - content = A.unsafeFromByteString - <$> - takeWhile1 (\c → isText c ∧ c ≢ '\x20') - - joinValues ∷ [Ascii] → Ascii - {-# INLINE joinValues #-} - joinValues = cs - ∘ mconcat - ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder) - ∘ (cs <$>) +instance Parsable ByteString Headers where + {-# INLINEABLE parser #-} + parser = do xs ← many header + crlf + return $ fromFoldable xs + where + header ∷ Parser (CIAscii, Ascii) + {-# INLINEABLE header #-} + header = do name ← cs <$> token + void $ char ':' + skipMany lws + values ← content `sepBy` try lws + skipMany (try lws) + crlf + return (name, joinValues values) + + content ∷ Parser Ascii + {-# INLINEABLE content #-} + content = A.unsafeFromByteString + <$> + takeWhile1 (\c → isText c ∧ c ≢ '\x20') + + joinValues ∷ [Ascii] → Ascii + {-# INLINEABLE joinValues #-} + joinValues = cs + ∘ mconcat + ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder) + ∘ (cs <$>) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 8890427..983cb50 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -8,13 +8,14 @@ -- |An internal module for HTTP version numbers. module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) - , httpVersion ) where import Control.Applicative import Control.Applicative.Unicode import Data.Ascii (Ascii, AsciiBuilder) import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils @@ -57,8 +58,8 @@ deriveAttempts [ ([t| HttpVersion |], [t| Ascii |]) , ([t| HttpVersion |], [t| AsciiBuilder |]) ] --- |'Parser' for an 'HttpVersion'. -httpVersion ∷ Parser HttpVersion -httpVersion = string "HTTP/" - *> - (HttpVersion <$> decimal ⊛ (char '.' *> decimal)) +instance Parsable ByteString HttpVersion where + {-# INLINEABLE parser #-} + parser = string "HTTP/" + *> + (HttpVersion <$> decimal ⊛ (char '.' *> decimal)) diff --git a/Network/HTTP/Lucu/Implant.hs b/Network/HTTP/Lucu/Implant.hs index 58e2b2e..1d418c0 100644 --- a/Network/HTTP/Lucu/Implant.hs +++ b/Network/HTTP/Lucu/Implant.hs @@ -24,10 +24,9 @@ import Data.Digest.Pure.SHA import Data.Maybe import Data.Time import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.MIMEType hiding (mimeType) +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap import Network.HTTP.Lucu.MIMEType.Guess -import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Utils import Prelude.Unicode diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 6f9eb7e..3741033 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -16,7 +16,6 @@ -- (). module Network.HTTP.Lucu.MIMEParams ( MIMEParams - , mimeParams ) where import Control.Applicative hiding (empty) @@ -25,7 +24,9 @@ import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable import Data.Bits +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Collections @@ -145,34 +146,33 @@ section ∷ ExtendedParam → Integer section (InitialEncodedParam {..}) = 0 section ep = epSection ep --- |'Parser' for MIME parameter values. -mimeParams ∷ Parser MIMEParams -{-# INLINEABLE mimeParams #-} -mimeParams = decodeParams =≪ many (try paramP) +instance Parsable ByteString MIMEParams where + {-# INLINEABLE parser #-} + parser = decodeParams =≪ many (try parser) -paramP ∷ Parser ExtendedParam -paramP = do skipMany lws - void $ char ';' - skipMany lws - epm ← nameP - void $ char '=' - case epm of - (name, 0, True) - → do (charset, payload) ← initialEncodedValue - return $ InitialEncodedParam name charset payload - (name, sect, True) - → do payload ← encodedPayload - return $ ContinuedEncodedParam name sect payload - (name, sect, False) - → do payload ← token <|> quotedStr - return $ AsciiParam name sect payload +instance Parsable ByteString ExtendedParam where + parser = do skipMany lws + void $ char ';' + skipMany lws + epm ← name + void $ char '=' + case epm of + (nm, 0, True) + → do (charset, payload) ← initialEncodedValue + return $ InitialEncodedParam nm charset payload + (nm, sect, True) + → do payload ← encodedPayload + return $ ContinuedEncodedParam nm sect payload + (nm, sect, False) + → do payload ← token <|> quotedStr + return $ AsciiParam nm sect payload -nameP ∷ Parser (CIAscii, Integer, Bool) -nameP = do name ← (cs ∘ A.unsafeFromByteString) <$> - takeWhile1 (\c → isToken c ∧ c ≢ '*') - sect ← option 0 $ try (char '*' *> decimal ) - isEncoded ← option False $ try (char '*' *> pure True) - return (name, sect, isEncoded) +name ∷ Parser (CIAscii, Integer, Bool) +name = do nm ← (cs ∘ A.unsafeFromByteString) <$> + takeWhile1 (\c → isToken c ∧ c ≢ '*') + sect ← option 0 $ try (char '*' *> decimal ) + isEncoded ← option False $ try (char '*' *> pure True) + return (nm, sect, isEncoded) initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) initialEncodedValue diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 250fdbf..949bc44 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -6,28 +6,34 @@ , RecordWildCards , TemplateHaskell , UnicodeSyntax + , ViewPatterns #-} -- |Parsing and printing MIME Media Types -- (). module Network.HTTP.Lucu.MIMEType ( MIMEType(..) , mimeType - , mimeTypeList ) where import Control.Applicative +import Control.Monad.Unicode import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import Data.Attempt import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils import Data.Monoid.Unicode import Data.Typeable import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils import Prelude.Unicode -- |A media type, subtype, and parameters. @@ -65,24 +71,51 @@ deriveAttempts [ ([t| MIMEType |], [t| Ascii |]) ] -- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider --- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'. +-- using 'mimeType' quasi-quoter. instance ConvertAttempt Ascii MIMEType where {-# INLINEABLE convertAttempt #-} convertAttempt str - = case parseOnly (finishOff mimeType) (cs str) of + = case parseOnly (finishOff parser) (cs str) of Right t → return t Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err) --- |'Parser' for an 'MIMEType'. -mimeType ∷ Parser MIMEType -{-# INLINEABLE mimeType #-} -mimeType = do media ← cs <$> token - _ ← char '/' - sub ← cs <$> token - params ← mimeParams - return $ MIMEType media sub params +instance Parsable ByteString MIMEType where + {-# INLINEABLE parser #-} + parser = do media ← cs <$> token + _ ← char '/' + sub ← cs <$> token + params ← parser + return $ MIMEType media sub params --- |'Parser' for a list of 'MIMEType's. -mimeTypeList ∷ Parser [MIMEType] -{-# INLINE mimeTypeList #-} -mimeTypeList = listOf mimeType +instance Parsable ByteString [MIMEType] where + {-# INLINE parser #-} + parser = listOf parser + +-- |'QuasiQuoter' for 'MIMEType' literals. +-- +-- @ +-- textPlain :: 'MIMEType' +-- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |] +-- @ +mimeType ∷ QuasiQuoter +mimeType = QuasiQuoter { + quoteExp = (lift =≪) ∘ (parseType =≪) ∘ toAscii + , quotePat = const unsupported + , quoteType = const unsupported + , quoteDec = const unsupported + } + where + parseType ∷ Monad m ⇒ Ascii → m MIMEType + parseType a + = case ca a of + Success t → return t + Failure e → fail (show e) + + toAscii ∷ Monad m ⇒ String → m Ascii + toAscii (trim → s) + = case ca s of + Success a → return a + Failure e → fail (show e) + + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of mimeType quasi-quoter." diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index cd178de..3149859 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable , GeneralizedNewtypeDeriving + , MultiParamTypeClasses , TemplateHaskell , UnicodeSyntax , ViewPatterns @@ -12,13 +13,13 @@ module Network.HTTP.Lucu.MIMEType.Guess ( ExtMap(..) , extMap - , parseExtMap , guessTypeByFileName ) where import Control.Applicative import Data.Attoparsec.Char8 import qualified Data.Attoparsec.Lazy as LP +import Data.Attoparsec.Parsable import qualified Data.ByteString.Lazy.Char8 as Lazy import Data.Convertible.Base import Data.Convertible.Instances.Text () @@ -68,54 +69,56 @@ extMap = QuasiQuoter { , quoteDec = const unsupported } where + parseExtMap ∷ Lazy.ByteString → ExtMap + parseExtMap = convertUnsafe + unsupported ∷ Monad m ⇒ m α unsupported = fail "Unsupported usage of extMap quasi-quoter." --- |Parse Apache @mime.types@. -parseExtMap ∷ Lazy.ByteString → ExtMap -parseExtMap src - = case LP.parse pairs src of - LP.Fail _ eCtx e - → error $ "Unparsable extension map: " - ⧺ intercalate ", " eCtx - ⧺ ": " - ⧺ e - LP.Done _ xs - → case compile xs of - Right m → ExtMap m - Left e → error ("Duplicate extension: " ⧺ show e) - where - pairs ∷ Parser [(MIMEType, [Text])] - pairs = do skipMany linebreak - xs ← sepBy pair (skipMany1 linebreak) - skipMany linebreak - endOfInput - return xs - - "pairs" +instance ConvertAttempt Lazy.ByteString ExtMap where + convertAttempt src + = case LP.parse pairs src of + LP.Fail _ eCtx e + → fail $ "Unparsable extension map: " + ⊕ intercalate ", " eCtx + ⊕ ": " + ⊕ e + LP.Done _ xs + → case compile xs of + Right m → return $ ExtMap m + Left e → fail $ "Duplicate extension: " ⊕ show e + where + pairs ∷ Parser [(MIMEType, [Text])] + pairs = do skipMany linebreak + xs ← sepBy pair (skipMany1 linebreak) + skipMany linebreak + endOfInput + return xs + + "pairs" - pair ∷ Parser (MIMEType, [Text]) - pair = do skipSpace - mime ← mimeType - skipSpace1 - exts ← sepBy1 ext $ skipWhile1 (≡ '\x20') - return (mime, exts) - - "pair" + pair ∷ Parser (MIMEType, [Text]) + pair = do skipSpace + mime ← parser + skipSpace1 + exts ← sepBy1 ext $ skipWhile1 (≡ '\x20') + return (mime, exts) + + "pair" - ext ∷ Parser Text - ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) - - "ext" + ext ∷ Parser Text + ext = (decodeUtf8 <$> takeWhile1 isAlphaNum) + + "ext" - linebreak ∷ Parser () - linebreak - = ( endOfLine - <|> - try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine) - ) - - "linebreak" + linebreak ∷ Parser () + linebreak + = ( endOfLine + <|> + try (skipSpace *> char '#' *> skipManyTill anyChar endOfLine) + ) + + "linebreak" compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) compile = go (∅) ∘ concat ∘ (tr <$>) diff --git a/Network/HTTP/Lucu/MIMEType/TH.hs b/Network/HTTP/Lucu/MIMEType/TH.hs deleted file mode 100644 index 9e16efc..0000000 --- a/Network/HTTP/Lucu/MIMEType/TH.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - , ViewPatterns - #-} --- |A module to provide 'QuasiQuoter' for 'MIMEType' literals. -module Network.HTTP.Lucu.MIMEType.TH - ( mimeType - ) - where -import Control.Monad.Unicode -import Data.Ascii (Ascii) -import Data.Attempt -import Data.Convertible.Base -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 - --- |'QuasiQuoter' for 'MIMEType' literals. --- --- @ --- textPlain :: 'MIMEType' --- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |] --- @ -mimeType ∷ QuasiQuoter -mimeType = QuasiQuoter { - quoteExp = (lift =≪) ∘ (parse =≪) ∘ toAscii - , quotePat = const unsupported - , quoteType = const unsupported - , quoteDec = const unsupported - } - where - parse ∷ Monad m ⇒ Ascii → m MIMEType - parse a - = case ca a of - Success t → return t - Failure e → fail (show e) - - toAscii ∷ Monad m ⇒ String → m Ascii - toAscii (trim → s) - = case ca s of - Success a → return a - Failure e → fail (show e) - - 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 2d1b347..ecff350 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -26,6 +26,7 @@ import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import Data.Attempt import Data.Attoparsec import qualified Data.Attoparsec.Lazy as LP +import Data.Attoparsec.Parsable import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LS import Data.ByteString.Lazy.Search @@ -40,9 +41,7 @@ import Data.Sequence (Seq) import Data.Text (Text) import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.MIMEParams -import Network.HTTP.Lucu.MIMEType (MIMEType) -import qualified Network.HTTP.Lucu.MIMEType as MT -import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils @@ -87,8 +86,8 @@ deriveAttempts [ ([t| ContDispo |], [t| Ascii |]) , ([t| ContDispo |], [t| AsciiBuilder |]) ] --- |Parse \"multipart/form-data\" and return either @'Left' err@ or --- @'Right' result@. Note that there are currently the following +-- |Parse \"multipart/form-data\" to a list of @(name, +-- formData)@. Note that there are currently the following -- limitations: -- -- * Multiple files embedded as \"multipart/mixed\" within the @@ -97,9 +96,9 @@ deriveAttempts [ ([t| ContDispo |], [t| Ascii |]) -- * \"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. +-- that non-ASCII field names are encoded according to the method +-- in RFC 2047 (), but this +-- function currently doesn't decode them. parseMultipartFormData ∷ Ascii -- ^boundary → LS.ByteString -- ^input → Either String [(Ascii, FormData)] @@ -170,7 +169,7 @@ parsePart boundary src defaultCType = [mimeType| text/plain |] partHeader ∷ Parser Headers -partHeader = crlf *> headers +partHeader = crlf *> parser getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo {-# INLINEABLE getContDispo #-} @@ -188,7 +187,7 @@ getContDispo hdrs contentDisposition ∷ Parser ContDispo contentDisposition - = (ContDispo <$> (cs <$> token) ⊛ mimeParams) + = (ContDispo <$> (cs <$> token) ⊛ parser) "contentDisposition" @@ -199,7 +198,7 @@ getContType hdrs Nothing → return Nothing Just str - → case parseOnly (finishOff MT.mimeType) $ cs str of + → case parseOnly (finishOff parser) $ cs str of Right d → return $ Just d Left err → throwError $ "malformed Content-Type: " ⊕ cs str diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 58286db..2fcfc91 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - OverloadedStrings + MultiParamTypeClasses + , OverloadedStrings , UnicodeSyntax , ViewPatterns #-} @@ -10,13 +11,14 @@ module Network.HTTP.Lucu.Request ( Method(..) , Request(..) , reqMustHaveBody - , request ) where import Control.Applicative import Control.Monad.Unicode import Data.Ascii (Ascii) import Data.Attoparsec.Char8 +import Data.Attoparsec.Parsable +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion @@ -61,28 +63,30 @@ reqMustHaveBody (reqMethod → m) | m ≡ PUT = True | otherwise = False --- |'Parser' for a 'Request'. -request ∷ Parser Request -request = do skipMany crlf - (meth, u, ver) ← requestLine - hdrs ← headers - return Request { - reqMethod = meth - , reqURI = u - , reqVersion = ver - , reqHeaders = hdrs - } +instance Parsable ByteString Request where + {-# INLINEABLE parser #-} + parser = do skipMany crlf + (meth, u, ver) ← requestLine + hdrs ← parser + return Request { + reqMethod = meth + , reqURI = u + , reqVersion = ver + , reqHeaders = hdrs + } requestLine ∷ Parser (Method, URI, HttpVersion) +{-# INLINEABLE requestLine #-} requestLine = do meth ← method sp u ← uri sp - ver ← httpVersion + ver ← parser crlf return (meth, u, ver) method ∷ Parser Method +{-# INLINEABLE method #-} method = choice [ string "OPTIONS" ≫ return OPTIONS , string "GET" ≫ return GET @@ -96,6 +100,7 @@ method = choice ] uri ∷ Parser URI +{-# INLINEABLE uri #-} uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20')) let str = C8.unpack bs case parseURIReference str of diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 6c5070b..91aa86d 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -16,6 +16,7 @@ import Control.Exception hiding (block) import Control.Monad import Control.Monad.Trans.Maybe import qualified Data.Attoparsec.Lazy as LP +import Data.Attoparsec.Parsable import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.Convertible.Base @@ -94,7 +95,7 @@ acceptRequest ctx@(Context {..}) input if Lazy.null input then return () else - case LP.parse request input of + case LP.parse parser input of LP.Done input' req → acceptParsableRequest ctx req input' LP.Fail _ _ _ → acceptNonparsableRequest ctx diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 8585cea..4141529 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -151,6 +151,7 @@ import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import Data.Attempt import qualified Data.Attoparsec.Char8 as P +import Data.Attoparsec.Parsable import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy @@ -180,9 +181,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.MIMEType (MIMEType(..)) -import qualified Network.HTTP.Lucu.MIMEType as MT -import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) import Network.URI hiding (path) @@ -265,7 +264,7 @@ getAccept Nothing → return [] Just accept - → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of + → case P.parseOnly (finishOff parser) (cs accept) of Right xs → return xs Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept: " ⊕ cs accept @@ -293,7 +292,7 @@ getAcceptEncoding -- identity のみが許される。 return [("identity", Nothing)] else - case P.parseOnly (finishOff acceptEncodingList) (cs ae) of + case P.parseOnly (finishOff parser) (cs ae) of Right xs → return $ map toTuple $ reverse $ sort xs Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Accept-Encoding: " ⊕ cs ae @@ -317,7 +316,7 @@ getContentType Nothing → return Nothing Just cType - → case P.parseOnly (finishOff MT.mimeType) (cs cType) of + → case P.parseOnly (finishOff parser) (cs cType) of Right t → return $ Just t Left _ → abort $ mkAbortion' BadRequest $ "Unparsable Content-Type: " ⊕ cs cType @@ -331,7 +330,7 @@ getAuthorization Nothing → return Nothing Just auth - → case P.parseOnly (finishOff authCredential) (cs auth) of + → case P.parseOnly (finishOff parser) (cs auth) of Right ac → return $ Just ac Left _ → return Nothing @@ -394,11 +393,11 @@ foundETag tag → if value ≡ "*" then return () else - case P.parseOnly (finishOff eTagList) (cs value) of + case P.parseOnly (finishOff parser) (cs value) of Right tags -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 - → when ((¬) (any (≡ tag) tags)) + → when ((¬) (any (≡ tag) (tags ∷ [ETag]))) $ abort $ mkAbortion' PreconditionFailed $ "The entity tag doesn't match: " ⊕ cs value @@ -422,9 +421,9 @@ foundETag tag abort $ mkAbortion' statusForNoneMatch $ "The entity tag matches: *" else - case P.parseOnly (finishOff eTagList) (cs value) of + case P.parseOnly (finishOff parser) (cs value) of Right tags - → when (any (≡ tag) tags) + → when (any (≡ tag) (tags ∷ [ETag])) $ abort $ mkAbortion' statusForNoneMatch $ "The entity tag matches: " ⊕ cs value diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index f560ae3..7d2ff79 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -22,9 +22,8 @@ import Data.String import qualified Data.Text.Encoding as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.MIMEType hiding (mimeType) +import Network.HTTP.Lucu.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 diff --git a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml b/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml index d33391b..3ff42d3 100644 --- a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml +++ b/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml @@ -5,8 +5,8 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :in_progress -disposition: +status: :closed +disposition: :fixed creation_time: 2011-12-19 13:01:51.401625 Z references: [] @@ -20,4 +20,8 @@ log_events: - PHO - changed status from unstarted to in_progress - "" +- - 2011-12-19 14:29:32.083785 Z + - PHO + - closed with disposition fixed + - Done. git_branch: -- 2.40.0