)
where
import Control.Applicative
-import Control.Monad
-import Control.Monad.Unicode
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP
+import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import qualified Data.Map as M
import Data.Map (Map)
-import Data.Maybe
import Data.Typeable
+import Data.List
import Data.Monoid
import Data.Monoid.Unicode
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Text.Encoding
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Utils
import Prelude.Unicode
import System.FilePath
deriving (Eq, Show, Read, Monoid, Typeable)
instance Lift ExtMap where
- lift (ExtMap m)
- = [| ExtMap $(liftMap liftText lift m) |]
+ lift (ExtMap m) = [| ExtMap $(lift m) |]
-- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
--
-- @
extMap ∷ QuasiQuoter
extMap = QuasiQuoter {
- quoteExp = (lift ∘ parseExtMap =≪) ∘ toAscii
+ quoteExp = lift ∘ parseExtMap ∘ Lazy.pack
, quotePat = const unsupported
, quoteType = const unsupported
, quoteDec = const unsupported
}
where
- toAscii ∷ Monad m ⇒ String → m Ascii
- toAscii (A.fromChars → Just a) = return a
- toAscii _ = fail "Malformed extension map"
-
unsupported ∷ Monad m ⇒ m α
unsupported = fail "Unsupported usage of extMap quasi-quoter."
-- |Parse Apache @mime.types@.
-parseExtMap ∷ Ascii → ExtMap
+parseExtMap ∷ Lazy.ByteString → ExtMap
parseExtMap src
- = case parseOnly (finishOff extMapP) $ A.toByteString src of
- Right xs → case compile xs of
- Right m → ExtMap m
- Left e → error ("Duplicate extension: " ⧺ show e)
- Left err → error ("Unparsable extension map: " ⧺ err)
-
-extMapP ∷ Parser [(MIMEType, [Text])]
-extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
+ = 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
- isSpc ∷ Char → Bool
- isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
-
- comment ∷ Parser (Maybe (MIMEType, [Text]))
- comment = do skipWhile isSpc
- void $ char '#'
- skipWhile (≢ '\x0A')
- return Nothing
+ pairs ∷ Parser [(MIMEType, [Text])]
+ pairs = do skipMany linebreak
+ xs ← sepBy pair (skipMany1 linebreak)
+ skipMany linebreak
+ endOfInput
+ return xs
+ <?>
+ "pairs"
- validLine ∷ Parser (Maybe (MIMEType, [Text]))
- validLine = do skipWhile isSpc
- mime ← mimeType
- skipWhile isSpc
- exts ← sepBy extP (skipWhile isSpc)
- return $ Just (mime, exts)
+ pair ∷ Parser (MIMEType, [Text])
+ pair = do skipSpace
+ mime ← mimeType
+ skipSpace1
+ exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
+ return (mime, exts)
+ <?>
+ "pair"
- extP ∷ Parser Text
- extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
+ ext ∷ Parser Text
+ ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
+ <?>
+ "ext"
- emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
- emptyLine = do skipWhile isSpc
- void $ char '\x0A'
- return Nothing
+ 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 ∘ map tr
+compile = go (∅) ∘ concat ∘ (tr <$>)
where
tr ∷ (v, [k]) → [(k, v)]
tr (v, ks) = [(k, v) | k ← ks]
guessTypeByFileName (ExtMap m) fpath
= case takeExtension fpath of
[] → Nothing
- (_:ext) → M.lookup (T.pack ext) m
+ (_:ext) → M.lookup (cs ext) m