Network/HTTP/Lucu/MIMEType/Guess.hs

   1 module Network.HTTP.Lucu.MIMEType.Guess
   2     ( parseExtMapFile  -- FilePath -> IO (Map String MIMEType)
   3     , outputExtMapAsHS -- Map String MIMEType -> FilePath -> IO ()
   4     )
   5     where
   6
   7 import qualified Data.ByteString.Lazy.Char8 as B
   8 import           Data.ByteString.Lazy.Char8 (ByteString)
   9 import qualified Data.Map as M
  10 import           Data.Map (Map)
  11 import           Data.Maybe
  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
  17 import           System.IO
  18
  19 import Debug.Trace
  20
  21 parseExtMapFile :: FilePath -> IO (Map String MIMEType)
  22 parseExtMapFile fpath
  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'
  27                               in
  28                                 fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
  29
  30
  31 extMapP :: Parser [ (MIMEType, [String]) ]
  32 extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
  33              eof
  34              return $ catMaybes xs
  35     where
  36       spc = oneOf " \t"
  37
  38       comment = do many spc
  39                    char '#'
  40                    many $ satisfy (/= '\n')
  41                    return Nothing
  42
  43       validLine = do many spc
  44                      mime <- mimeTypeP
  45                      many spc
  46                      exts <- sepBy token (many spc)
  47                      return $ Just (mime, exts)
  48
  49       emptyLine = oneOf " \t\n" >> return Nothing
  50
  51
  52 compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
  53 compile = M.fromList . foldr (++) [] . map tr
  54     where
  55       tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
  56       tr (mime, exts) = [ (ext, mime) | ext <- exts ]
  57
  58
  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")]))
  67                      ]
  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) []]
  74                      ]
  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"
  79       in
  80         writeFile fpath $ comment ++ prettyPrint hsModule ++ "\n"
  81     where
  82       records :: [HsExp]
  83       records = map record $ M.assocs extMap
  84
  85       record :: (String, MIMEType) -> HsExp
  86       record (ext, mime)
  87           = HsTuple [HsLit (HsString ext), mimeToExp mime]
  88
  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
  95
  96       appendParam :: HsExp -> (String, String) -> HsExp
  97       appendParam x param
  98           = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "+:+"))) $ paramToExp param
  99
 100       paramToExp :: (String, String) -> HsExp
 101       paramToExp (name, value)
 102           = HsInfixApp
 103             (HsLit (HsString name))
 104             (HsQVarOp (UnQual (HsSymbol "+=+")))
 105             (HsLit (HsString value))