X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Network%2FHTTP%2FLucu%2FMIMEType.hs;h=768b4cf53d3227c1ff1fde966755acfa23eef780;hb=90fca0675b1694e69b8e431c989343855cbd125d;hp=88a2eeffde0ad8e7e673af93c425f506c6d5706e;hpb=9bb89434103e9a22f100d6ecb7e65a5d461e0454;p=Lucu.git diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 88a2eef..768b4cf 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,83 +1,121 @@ {-# LANGUAGE - UnboxedTuples + DeriveDataTypeable + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , RecordWildCards + , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax + , ViewPatterns #-} -{-# OPTIONS_HADDOCK prune #-} - --- |Manipulation of MIME Types. +-- |Parsing and printing MIME Media Types +-- (). module Network.HTTP.Lucu.MIMEType ( MIMEType(..) - , parseMIMEType - , printMIMEType - - , mimeTypeP - , mimeTypeListP + , mimeType ) where -import Data.Ascii (Ascii, CIAscii) -import qualified Data.Ascii as A -import qualified Data.ByteString.Lazy as B +import Control.Applicative +import Control.Monad.Unicode +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import Data.Attempt +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils +import Data.Default +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 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) ] - } deriving (Eq, Show) +-- |A media type, subtype, and parameters. +data MIMEType + = MIMEType { + mtMedia ∷ !CIAscii + , mtSub ∷ !CIAscii + , mtParams ∷ !MIMEParams + } + deriving (Eq, Show, Read, Typeable) --- |Convert a 'MIMEType' to 'Ascii'. -printMIMEType ∷ MIMEType → Ascii -printMIMEType (MIMEType maj min params) - = A.fromAsciiBuilder $ - ( A.toAsciiBuilder maj ⊕ - A.toAsciiBuilder "/" ⊕ - A.toAsciiBuilder min ⊕ - if null params then - (∅) - else - A.toAsciiBuilder "; " ⊕ - joinWith "; " (map printPair params) - ) - where - printPair ∷ (CIAscii, Ascii) → A.AsciiBuilder - printPair (name, value) - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "=" ⊕ - if any ((¬) ∘ isToken) value then - quoteStr value - else - A.toAsciiBuilder value +instance Lift MIMEType where + lift (MIMEType {..}) + = [| MIMEType { + mtMedia = $(lift mtMedia ) + , mtSub = $(lift mtSub ) + , mtParams = $(lift mtParams) + } + |] + +instance ConvertSuccess MIMEType Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) --- |Parse 'MIMEType' from a 'Prelude.String'. 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) +instance ConvertSuccess MIMEType AsciiBuilder where + {-# INLINEABLE convertSuccess #-} + convertSuccess (MIMEType {..}) + = cs mtMedia ⊕ + cs ("/" ∷ Ascii) ⊕ + cs mtSub ⊕ + cs mtParams +deriveAttempts [ ([t| MIMEType |], [t| Ascii |]) + , ([t| MIMEType |], [t| AsciiBuilder |]) + ] -mimeTypeP :: Parser MIMEType -mimeTypeP = allowEOF $! - do maj <- token - _ <- char '/' - min <- token - params <- many paramP - return $ MIMEType maj min params +-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider +-- using 'mimeType' quasi-quoter. +instance ConvertAttempt Ascii MIMEType where + {-# INLINEABLE convertAttempt #-} + convertAttempt str + = case parseOnly (finishOff def) (cs str) of + Right t → return t + Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err) + +instance Default (Parser MIMEType) where + {-# INLINEABLE def #-} + def = do media ← cs <$> token + _ ← char '/' + sub ← cs <$> token + params ← def + return $ MIMEType media sub params + +instance Default (Parser [MIMEType]) where + {-# INLINE def #-} + def = listOf def + +-- |'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 - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) + 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) -mimeTypeListP :: Parser [MIMEType] -mimeTypeListP = allowEOF $! listOf mimeTypeP + unsupported ∷ Monad m ⇒ m α + unsupported = fail "Unsupported usage of mimeType quasi-quoter."