Fixed many bugs...

[Lucu.git] / Network / HTTP / Lucu / MIMEType / Guess.hs

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 2664d79b859e853565090f5581e103e7f9fce17f..37a3ad6f25a7f1eb1a35da9e74ac7de01d7224b6 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -21,6 +21,7 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Maybe
+import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
@@ -38,17 +39,25 @@ type ExtMap = Map Text MIMEType
 -- |Guess the MIME Type of file.
 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
 guessTypeByFileName extMap fpath
-    = let ext = T.pack $ takeExtension fpath
-      in
-        M.lookup ext extMap
+    = case takeExtension fpath of
+        []      → Nothing
+        (_:ext) → M.lookup (T.pack ext) extMap
 
 -- |Read an Apache mime.types and parse it.
 parseExtMapFile ∷ FilePath → IO ExtMap
 parseExtMapFile fpath
     = do file ← B.readFile fpath
          case LP.parse extMapP file of
-           LP.Done _ xs  → return $ compile xs
-           LP.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
+           LP.Done _ xs
+               → case compile xs of
+                    Right m → return m
+                    Left  e → fail (concat [ "Duplicate extension \""
+                                           , show e
+                                           , "\" in: "
+                                           , fpath
+                                           ])
+           LP.Fail _ _ e
+               → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
 
 extMapP ∷ Parser [ (MIMEType, [Text]) ]
 extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
@@ -82,11 +91,21 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
                      _ ← char '\x0A'
                      return Nothing
 
-compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType
-compile = M.fromList ∘ concat ∘ map tr
+compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
+compile = go (∅) ∘ concat ∘ map tr
     where
-      tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ]
-      tr (mime, exts) = [ (ext, mime) | ext ← exts ]
+      tr ∷ (v, [k]) → [(k, v)]
+      tr (v, ks) = [(k, v) | k ← ks]
+
+      go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
+      go m []         = Right m
+      go m ((k, v):xs)
+          = case M.insertLookupWithKey' f k v m of
+              (Nothing, m') → go m' xs
+              (Just v0, _ ) → Left (k, v0, v)
+
+      f ∷ k → v → v → v
+      f _ _ = id
 
 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
 -- Haskell source code which contains the following things: