1 module Network.HTTP.Lucu.MIMEType.Guess
2 ( parseExtMapFile -- FilePath -> IO (Map String MIMEType)
3 , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO ()
7 import qualified Data.ByteString.Lazy.Char8 as B
8 import Data.ByteString.Lazy.Char8 (ByteString)
9 import qualified Data.Map as M
12 import Language.Haskell.Pretty
13 import Language.Haskell.Syntax
14 import Network.HTTP.Lucu.MIMEType
15 import Network.HTTP.Lucu.Parser
16 import Network.HTTP.Lucu.Parser.Http
21 parseExtMapFile :: FilePath -> IO (Map String MIMEType)
23 = do file <- B.readFile fpath
24 case parse (allowEOF extMapP) file of
25 (Success xs, _) -> return $ compile xs
26 (_, input') -> let near = B.unpack $ B.take 100 input'
28 fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
31 extMapP :: Parser [ (MIMEType, [String]) ]
32 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
40 many $ satisfy (/= '\n')
43 validLine = do many spc
46 exts <- sepBy token (many spc)
47 return $ Just (mime, exts)
49 emptyLine = oneOf " \t\n" >> return Nothing
52 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
53 compile = M.fromList . foldr (++) [] . map tr
55 tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
56 tr (mime, exts) = [ (ext, mime) | ext <- exts ]
59 outputExtMapAsHS :: Map String MIMEType -> FilePath -> IO ()
60 outputExtMapAsHS extMap fpath
61 = let hsModule = HsModule undefined modName (Just exports) imports decls
62 modName = Module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"
63 exports = [HsEVar (UnQual (HsIdent "defaultExtensionMap"))]
64 imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
65 , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
66 , HsImportDecl undefined (Module "Data.Map") False Nothing (Just (False, [HsIAbs (HsIdent "Map")]))
68 decls = [ HsTypeSig undefined [HsIdent "defaultExtensionMap"]
69 (HsQualType [] (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Map")))
70 (HsTyCon (UnQual (HsIdent "String"))))
71 (HsTyCon (UnQual (HsIdent "MIMEType")))))
72 , HsFunBind [HsMatch undefined (HsIdent "defaultExtensionMap")
73 [] (HsUnGuardedRhs extMapExp) []]
75 extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
76 comment = "{- !!! WARNING !!!\n"
77 ++ " This file is automatically generated from data/mime.types.\n"
78 ++ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
80 writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
83 records = map record $ M.assocs extMap
85 record :: (String, MIMEType) -> HsExp
87 = HsTuple [HsLit (HsString ext), mimeToExp mime]
89 mimeToExp :: MIMEType -> HsExp
90 mimeToExp (MIMEType maj min params)
91 = foldl appendParam (HsInfixApp
92 (HsLit (HsString maj))
93 (HsQVarOp (UnQual (HsSymbol "+/+")))
94 (HsLit (HsString min))) params
96 appendParam :: HsExp -> (String, String) -> HsExp
98 = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "+:+"))) $ paramToExp param
100 paramToExp :: (String, String) -> HsExp
101 paramToExp (name, value)
103 (HsLit (HsString name))
104 (HsQVarOp (UnQual (HsSymbol "+=+")))
105 (HsLit (HsString value))