Network/HTTP/Lucu/MIMEType/Guess.hs

   1 module Network.HTTP.Lucu.MIMEType.Guess
   2     ( ExtMap
   3     , guessTypeByFileName -- ExtMap -> FilePath -> Maybe MIMEType
   4
   5     , parseExtMapFile  -- FilePath -> IO ExtMap
   6     , outputExtMapAsHS -- ExtMap -> FilePath -> IO ()
   7     )
   8     where
   9
  10 import qualified Data.ByteString.Lazy.Char8 as B
  11 import           Data.ByteString.Lazy.Char8 (ByteString)
  12 import qualified Data.Map as M
  13 import           Data.Map (Map)
  14 import           Data.Maybe
  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
  21 import           System.IO
  22
  23 type ExtMap = Map String MIMEType
  24
  25
  26 guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
  27 guessTypeByFileName extMap fpath
  28     = let ext = last $ splitBy (== '.') fpath
  29       in
  30         M.lookup ext extMap >>= return
  31
  32
  33 parseExtMapFile :: FilePath -> IO ExtMap
  34 parseExtMapFile fpath
  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'
  39                               in
  40                                 fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
  41
  42
  43 extMapP :: Parser [ (MIMEType, [String]) ]
  44 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
  45              eof
  46              return $ catMaybes xs
  47     where
  48       spc = oneOf " \t"
  49
  50       comment = do many spc
  51                    char '#'
  52                    many $ satisfy (/= '\n')
  53                    return Nothing
  54
  55       validLine = do many spc
  56                      mime <- mimeTypeP
  57                      many spc
  58                      exts <- sepBy token (many spc)
  59                      return $ Just (mime, exts)
  60
  61       emptyLine = oneOf " \t\n" >> return Nothing
  62
  63
  64 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
  65 compile = M.fromList . foldr (++) [] . map tr
  66     where
  67       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
  68       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
  69
  70
  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")]))
  79                      ]
  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) []]
  86                      ]
  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"
  91       in
  92         writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
  93     where
  94       records :: [HsExp]
  95       records = map record $ M.assocs extMap
  96
  97       record :: (String, MIMEType) -> HsExp
  98       record (ext, mime)
  99           = HsTuple [HsLit (HsString ext), mimeToExp mime]
 100
 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
 107
 108       appendParam :: HsExp -> (String, String) -> HsExp
 109       appendParam x param
 110           = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "<:>"))) $ paramToExp param
 111
 112       paramToExp :: (String, String) -> HsExp
 113       paramToExp (name, value)
 114           = HsInfixApp
 115             (HsLit (HsString name))
 116             (HsQVarOp (UnQual (HsSymbol "<=>")))
 117             (HsLit (HsString value))