From: PHO Date: Sun, 31 Jul 2011 02:28:15 +0000 (+0900) Subject: MIMEType X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=65a16e9330e797303a5cf8143dcbe135812d526f;p=Lucu.git MIMEType Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 2378ebc..cfb3fb2 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -119,7 +119,7 @@ headersP = do xs ← P.many header joinValues ∷ [Ascii] → Ascii {-# INLINE joinValues #-} - joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" + joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder hPutHeaders ∷ HandleLike h => h → Headers → IO () hPutHeaders !h !(Headers m) diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 88a2eef..4128f53 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - UnboxedTuples + OverloadedStrings , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -14,28 +14,32 @@ module Network.HTTP.Lucu.MIMEType , mimeTypeListP ) where +import Control.Applicative import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A -import qualified Data.ByteString.Lazy as B +import Data.Attoparsec.Char8 as P +import qualified Data.ByteString.Char8 as C8 +import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude hiding (min) +import Prelude.Unicode -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@ -- represents \"major\/minor; name=value\". data MIMEType = MIMEType { - mtMajor :: !CIAscii - , mtMinor :: !CIAscii - , mtParams :: ![ (CIAscii, Ascii) ] + mtMajor ∷ !CIAscii + , mtMinor ∷ !CIAscii + , mtParams ∷ ![ (CIAscii, Ascii) ] } deriving (Eq, Show) -- |Convert a 'MIMEType' to 'Ascii'. printMIMEType ∷ MIMEType → Ascii printMIMEType (MIMEType maj min params) = A.fromAsciiBuilder $ - ( A.toAsciiBuilder maj ⊕ + ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕ A.toAsciiBuilder "/" ⊕ - A.toAsciiBuilder min ⊕ + A.toAsciiBuilder (A.fromCIAscii min) ⊕ if null params then (∅) else @@ -47,37 +51,41 @@ printMIMEType (MIMEType maj min params) printPair (name, value) = A.toAsciiBuilder (A.fromCIAscii name) ⊕ A.toAsciiBuilder "=" ⊕ - if any ((¬) ∘ isToken) value then + if C8.any ((¬) ∘ isToken) (A.toByteString value) then quoteStr value else A.toAsciiBuilder value --- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an +-- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. -parseMIMEType :: String -> MIMEType -parseMIMEType str = case parseStr mimeTypeP str of - (# Success t, r #) -> if B.null r - then t - else error ("unparsable MIME Type: " ++ str) - (# _ , _ #) -> error ("unparsable MIME Type: " ++ str) +parseMIMEType ∷ Ascii → MIMEType +parseMIMEType str + = let p = do t ← mimeTypeP + endOfInput + return t + bs = A.toByteString str + in + case parseOnly p bs of + Right t → t + Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err) - -mimeTypeP :: Parser MIMEType -mimeTypeP = allowEOF $! - do maj <- token - _ <- char '/' - min <- token - params <- many paramP +mimeTypeP ∷ Parser MIMEType +mimeTypeP = try $ + do maj ← A.toCIAscii <$> token + _ ← char '/' + min ← A.toCIAscii <$> token + params ← P.many paramP return $ MIMEType maj min params where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr + paramP ∷ Parser (CIAscii, Ascii) + paramP = try $ + do skipMany lws + _ ← char ';' + skipMany lws + name ← A.toCIAscii <$> token + _ ← char '=' + value ← token <|> quotedStr return (name, value) -mimeTypeListP :: Parser [MIMEType] -mimeTypeListP = allowEOF $! listOf mimeTypeP +mimeTypeListP ∷ Parser [MIMEType] +mimeTypeListP = listOf mimeTypeP diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 387cca2..abd4556 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -32,17 +32,15 @@ splitBy isSep src -- |> joinWith ":" ["ab", "c", "def"] -- > ==> "ab:c:def" -joinWith ∷ Ascii → [Ascii] → AsciiBuilder +joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder {-# INLINEABLE joinWith #-} joinWith sep = flip go (∅) where - go ∷ [Ascii] → A.AsciiBuilder → A.AsciiBuilder + go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder {-# INLINE go #-} go [] ab = ab - go (x:[]) ab = ab ⊕ A.toAsciiBuilder x - go (x:xs) ab = go xs ( ab ⊕ - A.toAsciiBuilder sep ⊕ - A.toAsciiBuilder x ) + go (x:[]) ab = ab ⊕ x + go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x) -- |> quoteStr "abc" -- > ==> "\"abc\""