X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=6a791e4d15792a5aaff5a4504ceb6e10930e7a22;hb=bb41be0c967538a1014c87103a3a5d3840ad3e15;hp=8cddcba19bd60934b934f07dd520c97ef9c7fad9;hpb=48bc90d66a45c0b9b6f52272b46cf2949ed802e3;p=Lucu.git

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 8cddcba..6a791e4 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -17,15 +17,13 @@ module Network.HTTP.Lucu.MIMEType.Guess
     )
     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 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)
@@ -34,8 +32,8 @@ 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
 
@@ -45,8 +43,7 @@ newtype ExtMap
     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@.
 --
@@ -64,57 +61,63 @@ instance Lift ExtMap where
 -- @
 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]