X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEType%2FGuess.hs;h=d94711ac624cdfa9878243b55f46b1dbca61b223;hb=50805329b976eb90092504d4d181269f151fbb82;hp=7fe58206b5dcb86cd15538c4906f2f86ed0a09d8;hpb=a44a96d95b5fcbaf24a21c0336046ce0c3bab614;p=Lucu.git

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 7fe5820..d94711a 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -1,14 +1,17 @@
+-- |MIME Type guessing by a file extension. This is a poor man's way
+-- of guessing MIME Types. It is simple and fast.
+--
+-- In general you don't have to use this module directly.
 module Network.HTTP.Lucu.MIMEType.Guess
     ( ExtMap
-    , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType
+    , guessTypeByFileName
 
-    , parseExtMapFile  -- FilePath -> IO ExtMap
-    , outputExtMapAsHS -- ExtMap -> FilePath -> IO ()
+    , parseExtMapFile
+    , serializeExtMap
     )
     where
 
 import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Maybe
@@ -20,24 +23,30 @@ import           Network.HTTP.Lucu.Parser.Http
 import           Network.HTTP.Lucu.Utils
 import           System.IO
 
+-- |'Data.Map.Map' from extension to MIME Type.
 type ExtMap = Map String MIMEType
 
-
+-- |Guess the MIME Type of file.
 guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
 guessTypeByFileName extMap fpath
-    = let ext = head $ reverse $ splitBy (== '.') fpath
+    = extMap `seq` fpath `seq`
+      let ext = last $ splitBy (== '.') fpath
       in
         M.lookup ext extMap >>= return
 
-
+-- |Read an Apache mime.types and parse it.
 parseExtMapFile :: FilePath -> IO ExtMap
 parseExtMapFile fpath
-    = do file <- B.readFile fpath
+    = fpath `seq`
+      do file <- B.readFile fpath
          case parse (allowEOF extMapP) file of
-           (Success xs, _) -> return $ compile xs
-           (_, input')     -> let near = B.unpack $ B.take 100 input'
-                              in 
-                                fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
+           (# Success xs, _ #)
+               -> return $ compile xs
+
+           (# _, input' #)
+               -> let near = B.unpack $ B.take 100 input'
+                  in 
+                    fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
 
 
 extMapP :: Parser [ (MIMEType, [String]) ]
@@ -67,29 +76,37 @@ compile = M.fromList . foldr (++) [] . map tr
       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
 
-
-outputExtMapAsHS :: ExtMap -> FilePath -> IO ()
-outputExtMapAsHS extMap fpath
+-- |@'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
+--   @extMap@.
+--
+-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
+-- surely generated using this function.
+serializeExtMap :: ExtMap -> String -> String -> String
+serializeExtMap extMap moduleName variableName
     = let hsModule = HsModule undefined modName (Just exports) imports decls
-          modName  = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
-          exports  = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))]
-          imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+          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
-                     , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")]))
                      ]
-          decls    = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"]
-                                     (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map")))
-                                                                      (HsTyCon (UnQual (HsIdent "String"))))
-                                                             (HsTyCon (UnQual (HsIdent "MIMEType")))))
-                     , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap")
+          decls    = [ HsTypeSig undefined [HsIdent variableName]
+                                     (HsQualType []
+                                      (HsTyCon (UnQual (HsIdent "ExtMap"))))
+                     , HsFunBind [HsMatch undefined (HsIdent variableName)
                                   [] (HsUnGuardedRhs extMapExp) []]
                      ]
           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
-          comment =    "{- !!! WARNING !!!\n"
-                    ++ "   This file is automatically generated from data/mime.types.\n"
-                    ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+          comment   =    "{- !!! WARNING !!!\n"
+                      ++ "   This file is automatically generated.\n"
+                      ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
       in
-        writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
+        comment ++ prettyPrint hsModule ++ "\n"
     where
       records :: [HsExp]
       records = map record $ M.assocs extMap
@@ -99,19 +116,5 @@ outputExtMapAsHS extMap fpath
           = HsTuple [HsLit (HsString ext), mimeToExp mime]
                     
       mimeToExp :: MIMEType -> HsExp
-      mimeToExp (MIMEType maj min params)
-          = foldl appendParam (HsInfixApp
-                               (HsLit (HsString maj))
-                               (HsQVarOp (UnQual (HsSymbol "+/+")))
-                               (HsLit (HsString min))) params
-
-      appendParam :: HsExp -> (String, String) -> HsExp
-      appendParam x param
-          = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "+:+"))) $ paramToExp param
-
-      paramToExp :: (String, String) -> HsExp
-      paramToExp (name, value)
-          = HsInfixApp
-            (HsLit (HsString name))
-            (HsQVarOp (UnQual (HsSymbol "+=+")))
-            (HsLit (HsString value))
\ No newline at end of file
+      mimeToExp mt
+          = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))