1 module Network.HTTP.Lucu.MIMEType.Guess
3 , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType
5 , parseExtMapFile -- FilePath -> IO ExtMap
6 , outputExtMapAsHS -- ExtMap -> FilePath -> IO ()
10 import qualified Data.ByteString.Lazy.Char8 as B
11 import Data.ByteString.Lazy.Char8 (ByteString)
12 import qualified Data.Map as M
15 import Language.Haskell.Pretty
16 import Language.Haskell.Syntax
17 import Network.HTTP.Lucu.MIMEType
18 import Network.HTTP.Lucu.Parser
19 import Network.HTTP.Lucu.Parser.Http
20 import Network.HTTP.Lucu.Utils
23 type ExtMap = Map String MIMEType
26 guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
27 guessTypeByFileName extMap fpath
28 = let ext = head $ reverse $ splitBy (== '.') fpath
30 M.lookup ext extMap >>= return
33 parseExtMapFile :: FilePath -> IO ExtMap
35 = do file <- B.readFile fpath
36 case parse (allowEOF extMapP) file of
37 (Success xs, _) -> return $ compile xs
38 (_, input') -> let near = B.unpack $ B.take 100 input'
40 fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
43 extMapP :: Parser [ (MIMEType, [String]) ]
44 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
52 many $ satisfy (/= '\n')
55 validLine = do many spc
58 exts <- sepBy token (many spc)
59 return $ Just (mime, exts)
61 emptyLine = oneOf " \t\n" >> return Nothing
64 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
65 compile = M.fromList . foldr (++) [] . map tr
67 tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
68 tr (mime, exts) = [ (ext, mime) | ext <- exts ]
71 outputExtMapAsHS :: ExtMap -> FilePath -> IO ()
72 outputExtMapAsHS extMap fpath
73 = let hsModule = HsModule undefined modName (Just exports) imports decls
74 modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
75 exports = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))]
76 imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
77 , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
78 , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")]))
80 decls = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"]
81 (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map")))
82 (HsTyCon (UnQual (HsIdent "String"))))
83 (HsTyCon (UnQual (HsIdent "MIMEType")))))
84 , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap")
85 [] (HsUnGuardedRhs extMapExp) []]
87 extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
88 comment = "{- !!! WARNING !!!\n"
89 ++ " This file is automatically generated from data/mime.types.\n"
90 ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
92 writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
95 records = map record $ M.assocs extMap
97 record :: (String, MIMEType) -> HsExp
99 = HsTuple [HsLit (HsString ext), mimeToExp mime]
101 mimeToExp :: MIMEType -> HsExp
102 mimeToExp (MIMEType maj min params)
103 = foldl appendParam (HsInfixApp
104 (HsLit (HsString maj))
105 (HsQVarOp (UnQual (HsSymbol "+/+")))
106 (HsLit (HsString min))) params
108 appendParam :: HsExp -> (String, String) -> HsExp
110 = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "+:+"))) $ paramToExp param
112 paramToExp :: (String, String) -> HsExp
113 paramToExp (name, value)
115 (HsLit (HsString name))
116 (HsQVarOp (UnQual (HsSymbol "+=+")))
117 (HsLit (HsString value))