-
-generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
-generateHaskellSource opts srcFile
- = do modName <- getModuleName opts
- symName <- getSymbolName opts modName
- mimeType <- getMIMEType opts srcFile
- lastMod <- getLastModified srcFile
- input <- openInput srcFile
- output <- openOutput opts
- eTag <- getETag opts input
-
- let gzippedData = compressWith BestCompression input
- originalLen = L.length input
- gzippedLen = L.length gzippedData
- useGZip = originalLen > gzippedLen
- rawB64 = encode $ L.unpack input
- gzippedB64 = encode $ L.unpack gzippedData
-
- header = mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-
- hsModule = HsModule undefined (Module modName) (Just exports) imports decls
- exports = [HsEVar (UnQual (HsIdent symName))]
- imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Base")
- False Nothing (Just (False, [HsIVar (HsIdent "LazyByteString")]))
- , HsImportDecl undefined (Module "Data.ByteString.Lazy")
- True (Just (Module "L")) Nothing
- , HsImportDecl undefined (Module "Network.HTTP.Lucu")
- False Nothing Nothing
- , HsImportDecl undefined (Module "System.Time")
- False Nothing Nothing
- ]
- ++
- (if useGZip then
- [ HsImportDecl undefined (Module "Control.Monad")
- False Nothing Nothing
- , HsImportDecl undefined (Module "Codec.Compression.GZip")
- False Nothing Nothing
- ]
- else
- [])
- decls = declResourceDef
- ++
- declEntityTag
- ++
- declLastModified
- ++
- declContentType
- ++
- (if useGZip
- then declGZippedData
- else declRawData)
-
- declResourceDef :: [HsDecl]
- declResourceDef
- = [ HsTypeSig undefined [HsIdent symName]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "ResourceDef"))))
- , HsFunBind [HsMatch undefined (HsIdent symName)
- [] (HsUnGuardedRhs defResourceDef) []]
- ]
-
- defResourceDef :: HsExp
- defResourceDef
- = let defResGet = if useGZip
- then defResGetGZipped
- else defResGetRaw
- in
- (HsRecConstr (UnQual (HsIdent "ResourceDef"))
- [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
- (HsCon (UnQual (HsIdent "False")))
- , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
- (HsCon (UnQual (HsIdent "False")))
- , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
- , HsFieldUpdate (UnQual (HsIdent "resHead"))
- (HsCon (UnQual (HsIdent "Nothing")))
- , HsFieldUpdate (UnQual (HsIdent "resPost"))
- (HsCon (UnQual (HsIdent "Nothing")))
- , HsFieldUpdate (UnQual (HsIdent "resPut"))
- (HsCon (UnQual (HsIdent "Nothing")))
- , HsFieldUpdate (UnQual (HsIdent "resDelete"))
- (HsCon (UnQual (HsIdent "Nothing")))
- ]
- )
-
- defResGetGZipped :: HsExp
- defResGetGZipped
- = let doExp = HsDo [ doFoundEntity
- , doSetContentType
- , bindMustGunzip
- , doConditionalOutput
- ]
- doFoundEntity
- = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
- (HsVar (UnQual (HsIdent "entityTag"))))
- (HsVar (UnQual (HsIdent "lastModified"))))
- doSetContentType
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
- (HsVar (UnQual (HsIdent "contentType"))))
- bindMustGunzip
- = HsGenerator undefined
- (HsPVar (HsIdent "mustGunzip"))
- (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
- (HsVar (UnQual (HsIdent "not"))))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
- (HsLit (HsString "gzip")))))
- doConditionalOutput
- = HsQualifier
- (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
- expOutputGunzipped
- expOutputGZipped)
- expOutputGunzipped
- = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "decompress")))
- (HsVar (UnQual (HsIdent "gzippedData"))))))
- expOutputGZipped
- = HsDo [ doSetContentEncodingGZip
- , doOutputGZipped
- ]
- doSetContentEncodingGZip
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
- (HsList [HsLit (HsString "gzip")]))
- doOutputGZipped
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
- (HsVar (UnQual (HsIdent "gzippedData"))))
- in
- HsApp (HsCon (UnQual (HsIdent "Just")))
- (HsParen doExp)
-
- defResGetRaw :: HsExp
- defResGetRaw
- = let doExp = HsDo [ doFoundEntity
- , doSetContentType
- , doOutputRawData
- ]
- doFoundEntity
- = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
- (HsVar (UnQual (HsIdent "entityTag"))))
- (HsVar (UnQual (HsIdent "lastModified"))))
- doSetContentType
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
- (HsVar (UnQual (HsIdent "contentType"))))
- doOutputRawData
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
- (HsVar (UnQual (HsIdent "rawData"))))
- in
- HsApp (HsCon (UnQual (HsIdent "Just")))
- (HsParen doExp)
-
- declEntityTag :: [HsDecl]
- declEntityTag
- = [ HsTypeSig undefined [HsIdent "entityTag"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "ETag"))))
- , HsFunBind [HsMatch undefined (HsIdent "entityTag")
- [] (HsUnGuardedRhs defEntityTag) []]
- ]
-
- defEntityTag :: HsExp
- defEntityTag
- = HsApp (HsVar (UnQual (HsIdent "strongETag")))
- (HsLit (HsString eTag))
-
- declLastModified :: [HsDecl]
- declLastModified
- = [ HsTypeSig undefined [HsIdent "lastModified"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "ClockTime"))))
- , HsFunBind [HsMatch undefined (HsIdent "lastModified")
- [] (HsUnGuardedRhs defLastModified) []]
- ]
-
- defLastModified :: HsExp
- defLastModified
- = let TOD a b = lastMod
- in
- (HsApp (HsApp (HsCon (UnQual (HsIdent "TOD")))
- (HsLit (HsInt a)))
- (HsLit (HsInt b)))
-
-
- declContentType :: [HsDecl]
- declContentType
- = [ HsTypeSig undefined [HsIdent "contentType"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "MIMEType"))))
- , HsFunBind [HsMatch undefined (HsIdent "contentType")
- [] (HsUnGuardedRhs defContentType) []]
- ]
-
- defContentType :: HsExp
- defContentType
- = HsApp (HsVar (UnQual (HsIdent "read")))
- (HsLit (HsString $ show mimeType))
-
- declGZippedData :: [HsDecl]
- declGZippedData
- = [ HsTypeSig undefined [HsIdent "gzippedData"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "LazyByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
- [] (HsUnGuardedRhs defGZippedData) []]
- ]
-
- defGZippedData :: HsExp
- defGZippedData
- = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "decode")))
- (HsLit (HsString gzippedB64))))
-
- declRawData :: [HsDecl]
- declRawData
- = [ HsTypeSig undefined [HsIdent "rawData"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "LazyByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "rawData")
- [] (HsUnGuardedRhs defRawData) []]
- ]
-
- defRawData :: HsExp
- defRawData
- = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
- (HsParen
- (HsApp (HsVar (UnQual (HsIdent "decode")))
- (HsLit (HsString rawB64))))
-
- hPutStrLn output header
- hPutStrLn output (prettyPrint hsModule)
- hClose output
-
-
-mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String
-mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
- = "{- DO NOT EDIT THIS FILE.\n" ++
- " This file is automatically generated by the lucu-implant-file program.\n" ++
- "\n" ++
- " Source: " ++ (if srcFile == "-"
- then "(stdin)"
- else srcFile) ++ "\n" ++
- " Original Length: " ++ show originalLen ++ " bytes\n" ++
- (if useGZip
- then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
- " Compression: gzip\n"
- else " Compression: disabled\n") ++
- " MIME Type: " ++ show mimeType ++ "\n" ++
- " ETag: " ++ eTag ++ "\n" ++
- " Last Modified: " ++ show lastMod ++ "\n" ++
- " -}"
-
-
-getModuleName :: [CmdOpt] -> IO String
-getModuleName opts
- = let modNameOpts = filter (\ x -> case x of
- OptModName _ -> True
- _ -> False) opts
- in
- case modNameOpts of
- [] -> error "a module name must be given."
- (OptModName modName):[] -> return modName
- _ -> error "too many --module options."
-
-
-getSymbolName :: [CmdOpt] -> String -> IO String
-getSymbolName opts modName
- = let symNameOpts = filter (\ x -> case x of
- OptSymName _ -> True
- _ -> False) opts
- -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
- -- 小文字にしたものを使ふ。
- defaultSymName = mkDefault modName
- mkDefault = headToLower . getLastComp
- headToLower = \ str -> case str of
- (x:xs) -> toLower x : xs
- getLastComp = reverse . fst . break (== '.') . reverse
- in
- case symNameOpts of
- [] -> return defaultSymName
- (OptSymName symName):[] -> return symName
- _ -> error "too many --symbol options."
-
-
-getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
-getMIMEType opts srcFile
- = let mimeTypeOpts = filter (\ x -> case x of
- OptMIMEType _ -> True
- _ -> False) opts
- defaultType = fromMaybe (read "application/octet-stream")
- $ guessTypeByFileName defaultExtensionMap srcFile
- in
- case mimeTypeOpts of
- [] -> return defaultType
- (OptMIMEType mimeType):[] -> return $ read mimeType
- _ -> error "too many --mime-type options."
-
-
-getLastModified :: FilePath -> IO ClockTime
-getLastModified "-" = getClockTime
-getLastModified fpath = getModificationTime fpath
-
-
-getETag :: [CmdOpt] -> LazyByteString -> IO String
-getETag opts input
- = let eTagOpts = filter (\ x -> case x of
- OptETag _ -> True
- _ -> False) opts
- in
- case eTagOpts of
- [] -> return mkETagFromInput
- (OptETag str):[] -> return str
- _ -> error "too many --etag options."