X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=2319477f68dc3410fa69cbd6ae2cc5bce5173eea;hp=5a10bb60bd7e16ee6ae008534c8c5cc914568cb5;hb=360baa7e2cc4d4458481f3981d94e767a5ad4c02;hpb=65a16e9330e797303a5cf8143dcbe135812d526f

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 5a10bb6..2319477 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    UnboxedTuples
+    BangPatterns
+  , UnboxedTuples
   , UnicodeSyntax
   #-}
 -- |MIME Type guessing by a file extension. This is a poor man's way
@@ -14,92 +15,104 @@ module Network.HTTP.Lucu.MIMEType.Guess
     , serializeExtMap
     )
     where
+import Control.Applicative
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.Attoparsec.Lazy as AL
 import qualified Data.ByteString.Lazy.Char8 as B
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
 import Language.Haskell.Pretty
 import Language.Haskell.Syntax
 import Network.HTTP.Lucu.MIMEType
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+import System.FilePath
 
--- |'Data.Map.Map' from extension to MIME Type.
-type ExtMap = Map String MIMEType
+-- |'Map' from extension to 'MIMEType'.
+type ExtMap = Map Text MIMEType
 
 -- |Guess the MIME Type of file.
-guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
-guessTypeByFileName extMap fpath
-    = extMap `seq` fpath `seq`
-      let ext = last $ splitBy (== '.') fpath
+guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
+guessTypeByFileName !extMap !fpath
+    = let ext = T.pack $ takeExtension fpath
       in
-        M.lookup ext extMap >>= return
+        M.lookup ext extMap
 
 -- |Read an Apache mime.types and parse it.
-parseExtMapFile :: FilePath -> IO ExtMap
+parseExtMapFile ∷ FilePath → IO ExtMap
 parseExtMapFile fpath
-    = fpath `seq`
-      do file <- B.readFile fpath
-         case parse (allowEOF extMapP) file of
-           (# Success xs, _ #)
-               -> return $ compile xs
+    = do file ← B.readFile fpath
+         case AL.parse extMapP file of
+           AL.Done _ xs  → return $ compile xs
+           AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
 
-           (# _, input' #)
-               -> let near = B.unpack $ B.take 100 input'
-                  in 
-                    fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
-
-
-extMapP :: Parser [ (MIMEType, [String]) ]
-extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
-             eof
+extMapP ∷ Parser [ (MIMEType, [Text]) ]
+extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
+             endOfInput
              return $ catMaybes xs
     where
-      spc = oneOf " \t"
+      isSpc ∷ Char → Bool
+      isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
 
-      comment = many spc >>
-                char '#' >>
-                ( many $ satisfy (/= '\n') ) >>
-                return Nothing
+      comment ∷ Parser (Maybe (MIMEType, [Text]))
+      comment = try $
+                do skipWhile isSpc
+                   _ ← char '#'
+                   skipWhile (≢ '\x0A')
+                   return Nothing
 
-      validLine = do _    <- many spc
-                     mime <- mimeTypeP
-                     _    <- many spc
-                     exts <- sepBy token (many spc)
+      validLine ∷ Parser (Maybe (MIMEType, [Text]))
+      validLine = try $
+                  do skipWhile isSpc
+                     mime ← mimeTypeP
+                     skipWhile isSpc
+                     exts ← sepBy extP (skipWhile isSpc)
                      return $ Just (mime, exts)
 
-      emptyLine = oneOf " \t\n" >> return Nothing
+      extP ∷ Parser Text
+      extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
 
+      emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
+      emptyLine = try $
+                  do skipWhile isSpc
+                     _ ← char '\x0A'
+                     return Nothing
 
-compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
-compile = M.fromList . foldr (++) [] . map tr
+compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType
+compile = M.fromList ∘ concat ∘ map tr
     where
-      tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
-      tr (mime, exts) = [ (ext, mime) | ext <- exts ]
+      tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ]
+      tr (mime, exts) = [ (ext, mime) | ext ← exts ]
 
 -- |@'serializeExtMap' extMap moduleName variableName@ generates a
 -- Haskell source code which contains the following things:
 --
 -- * A definition of module named @moduleName@.
 --
--- * @variableName :: 'ExtMap'@ whose content is a serialization of
+-- * @variableName ∷ 'ExtMap'@ whose content is a serialization of
 --   @extMap@.
 --
 -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
 -- surely generated using this function.
-serializeExtMap :: ExtMap -> String -> String -> String
+serializeExtMap ∷ ExtMap → String → String → String
 serializeExtMap extMap moduleName variableName
-    = let hsModule = HsModule undefined modName (Just exports) imports decls
+    = let hsModule = HsModule (⊥) modName (Just exports) imports decls
           modName  = Module moduleName
           exports  = [HsEVar (UnQual (HsIdent variableName))]
-          imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, []))
-                     , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
-                     , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
+          imports  = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+                     , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
+                     , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing
+                     , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing
+                     , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing
                      ]
-          decls    = [ HsTypeSig undefined [HsIdent variableName]
+          decls    = [ HsTypeSig (⊥) [HsIdent variableName]
                                      (HsQualType []
                                       (HsTyCon (UnQual (HsIdent "ExtMap"))))
-                     , HsFunBind [HsMatch undefined (HsIdent variableName)
+                     , HsFunBind [HsMatch (⊥) (HsIdent variableName)
                                   [] (HsUnGuardedRhs extMapExp) []]
                      ]
           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
@@ -109,13 +122,20 @@ serializeExtMap extMap moduleName variableName
       in
         comment ++ prettyPrint hsModule ++ "\n"
     where
-      records :: [HsExp]
+      records ∷ [HsExp]
       records = map record $ M.assocs extMap
 
-      record :: (String, MIMEType) -> HsExp
+      record ∷ (Text, MIMEType) → HsExp
       record (ext, mime)
-          = HsTuple [HsLit (HsString ext), mimeToExp mime]
+          = HsTuple
+            [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack")))
+                    (HsLit (HsString (T.unpack ext)))
+            , mimeToExp mime
+            ]
                     
-      mimeToExp :: MIMEType -> HsExp
+      mimeToExp ∷ MIMEType → HsExp
       mimeToExp mt
-          = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))
+          = HsApp (HsVar (UnQual (HsIdent "parseMIMEType")))
+            (HsParen
+             (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString")))
+              (HsLit (HsString $ A.toString $ printMIMEType mt))))