1 import Codec.Binary.Base64
2 import Codec.Compression.GZip
5 import qualified Data.ByteString.Lazy as Lazy (ByteString)
6 import qualified Data.ByteString.Lazy as L hiding (ByteString)
11 import Data.Time.Clock.POSIX
12 import Language.Haskell.Pretty
13 import Language.Haskell.Syntax
14 import Network.HTTP.Lucu.MIMEType
15 import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
16 import Network.HTTP.Lucu.MIMEType.Guess
18 import OpenSSL.EVP.Digest
19 import System.Console.GetOpt
20 import System.Environment
22 import System.Posix.Files
35 options :: [OptDescr CmdOpt]
36 options = [ Option ['o'] ["output"]
37 (ReqArg OptOutput "FILE")
40 , Option ['m'] ["module"]
41 (ReqArg OptModName "MODULE")
42 "Specify the resulting module name. (required)"
44 , Option ['s'] ["symbol"]
45 (ReqArg OptSymName "SYMBOL")
46 "Specify the resulting symbol name."
48 , Option ['t'] ["mime-type"]
49 (ReqArg OptMIMEType "TYPE")
50 "Specify the MIME Type of the file."
52 , Option ['e'] ["etag"]
53 (ReqArg OptETag "TAG")
54 "Specify the ETag of the file."
56 , Option ['h'] ["help"]
63 printUsage = do putStrLn ""
64 putStrLn "Description:"
65 putStrLn (" lucu-implant-file is an utility that generates " ++
66 "Haskell code containing an arbitrary file to " ++
67 "compile it directly into programs and serve it " ++
68 "statically with the Lucu HTTP server.")
71 putStrLn " lucu-implant-file [OPTIONS...] FILE"
73 putStr $ usageInfo "Options:" options
79 do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
82 $ do mapM_ putStr errors
83 exitWith $ ExitFailure 1
85 when (any (== OptHelp) opts)
91 exitWith $ ExitFailure 1
93 when (length sources >= 2)
94 $ error "too many input files."
96 generateHaskellSource opts (head sources)
99 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
100 generateHaskellSource opts srcFile
101 = do modName <- getModuleName opts
102 symName <- getSymbolName opts modName
103 mimeType <- getMIMEType opts srcFile
104 lastMod <- getLastModified srcFile
105 input <- openInput srcFile
106 output <- openOutput opts
107 eTag <- getETag opts input
109 let compParams = defaultCompressParams { compressLevel = bestCompression }
110 gzippedData = compressWith compParams input
111 originalLen = L.length input
112 gzippedLen = L.length gzippedData
113 useGZip = originalLen > gzippedLen
114 rawB64 = encode $ L.unpack input
115 gzippedB64 = encode $ L.unpack gzippedData
117 header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
119 let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
120 exports = [HsEVar (UnQual (HsIdent symName))]
121 imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
122 False Nothing Nothing
123 , HsImportDecl undefined (Module "Data.ByteString.Lazy")
124 True (Just (Module "L")) Nothing
125 , HsImportDecl undefined (Module "Data.Maybe")
126 False Nothing Nothing
127 , HsImportDecl undefined (Module "Data.Time")
128 False Nothing Nothing
129 , HsImportDecl undefined (Module "Network.HTTP.Lucu")
130 False Nothing Nothing
134 [ HsImportDecl undefined (Module "Control.Monad")
135 False Nothing Nothing
136 , HsImportDecl undefined (Module "Codec.Compression.GZip")
137 False Nothing Nothing
141 decls = declResourceDef
153 declResourceDef :: [HsDecl]
155 = [ HsTypeSig undefined [HsIdent symName]
157 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
158 , HsFunBind [HsMatch undefined (HsIdent symName)
159 [] (HsUnGuardedRhs defResourceDef) []]
162 defResourceDef :: HsExp
164 = let defResGet = if useGZip
165 then defResGetGZipped
168 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
169 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
170 (HsCon (UnQual (HsIdent "False")))
171 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
172 (HsCon (UnQual (HsIdent "False")))
173 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
174 , HsFieldUpdate (UnQual (HsIdent "resHead"))
175 (HsCon (UnQual (HsIdent "Nothing")))
176 , HsFieldUpdate (UnQual (HsIdent "resPost"))
177 (HsCon (UnQual (HsIdent "Nothing")))
178 , HsFieldUpdate (UnQual (HsIdent "resPut"))
179 (HsCon (UnQual (HsIdent "Nothing")))
180 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
181 (HsCon (UnQual (HsIdent "Nothing")))
185 defResGetGZipped :: HsExp
187 = let doExp = HsDo [ doFoundEntity
190 , doConditionalOutput
193 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
194 (HsVar (UnQual (HsIdent "entityTag"))))
195 (HsVar (UnQual (HsIdent "lastModified"))))
197 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
198 (HsVar (UnQual (HsIdent "contentType"))))
200 = HsGenerator undefined
201 (HsPVar (HsIdent "mustGunzip"))
202 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
203 (HsVar (UnQual (HsIdent "not"))))
205 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
206 (HsLit (HsString "gzip")))))
209 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
213 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
215 (HsApp (HsVar (UnQual (HsIdent "decompress")))
216 (HsVar (UnQual (HsIdent "gzippedData"))))))
218 = HsDo [ doSetContentEncodingGZip
221 doSetContentEncodingGZip
222 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
223 (HsList [HsLit (HsString "gzip")]))
225 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
226 (HsVar (UnQual (HsIdent "gzippedData"))))
228 HsApp (HsCon (UnQual (HsIdent "Just")))
231 defResGetRaw :: HsExp
233 = let doExp = HsDo [ doFoundEntity
238 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
239 (HsVar (UnQual (HsIdent "entityTag"))))
240 (HsVar (UnQual (HsIdent "lastModified"))))
242 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
243 (HsVar (UnQual (HsIdent "contentType"))))
245 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
246 (HsVar (UnQual (HsIdent "rawData"))))
248 HsApp (HsCon (UnQual (HsIdent "Just")))
251 declEntityTag :: [HsDecl]
253 = [ HsTypeSig undefined [HsIdent "entityTag"]
255 (HsTyCon (UnQual (HsIdent "ETag"))))
256 , HsFunBind [HsMatch undefined (HsIdent "entityTag")
257 [] (HsUnGuardedRhs defEntityTag) []]
260 defEntityTag :: HsExp
262 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
263 (HsLit (HsString eTag))
265 declLastModified :: [HsDecl]
267 = [ HsTypeSig undefined [HsIdent "lastModified"]
269 (HsTyCon (UnQual (HsIdent "UTCTime"))))
270 , HsFunBind [HsMatch undefined (HsIdent "lastModified")
271 [] (HsUnGuardedRhs defLastModified) []]
274 defLastModified :: HsExp
276 = HsApp (HsVar (UnQual (HsIdent "read")))
277 (HsLit (HsString $ show lastMod))
280 declContentType :: [HsDecl]
282 = [ HsTypeSig undefined [HsIdent "contentType"]
284 (HsTyCon (UnQual (HsIdent "MIMEType"))))
285 , HsFunBind [HsMatch undefined (HsIdent "contentType")
286 [] (HsUnGuardedRhs defContentType) []]
289 defContentType :: HsExp
291 = HsApp (HsVar (UnQual (HsIdent "read")))
292 (HsLit (HsString $ show mimeType))
294 declGZippedData :: [HsDecl]
296 = [ HsTypeSig undefined [HsIdent "gzippedData"]
298 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
299 , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
300 [] (HsUnGuardedRhs defGZippedData) []]
303 defGZippedData :: HsExp
305 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
307 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
309 (HsApp (HsVar (UnQual (HsIdent "decode")))
310 (HsLit (HsString gzippedB64))))))
312 declRawData :: [HsDecl]
314 = [ HsTypeSig undefined [HsIdent "rawData"]
316 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
317 , HsFunBind [HsMatch undefined (HsIdent "rawData")
318 [] (HsUnGuardedRhs defRawData) []]
323 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
325 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
327 (HsApp (HsVar (UnQual (HsIdent "decode")))
328 (HsLit (HsString rawB64))))))
330 hPutStrLn output header
331 hPutStrLn output (prettyPrint hsModule)
335 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
336 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
337 = do localLastMod <- utcToLocalZonedTime lastMod
338 return ("{- DO NOT EDIT THIS FILE.\n" ++
339 " This file is automatically generated by the lucu-implant-file program.\n" ++
341 " Source: " ++ (if srcFile == "-"
343 else srcFile) ++ "\n" ++
344 " Original Length: " ++ show originalLen ++ " bytes\n" ++
346 then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
347 " Compression: gzip\n"
348 else " Compression: disabled\n") ++
349 " MIME Type: " ++ show mimeType ++ "\n" ++
350 " ETag: " ++ eTag ++ "\n" ++
351 " Last Modified: " ++ show localLastMod ++ "\n" ++
355 getModuleName :: [CmdOpt] -> IO String
357 = let modNameOpts = filter (\ x -> case x of
362 [] -> error "a module name must be given."
363 (OptModName modName):[] -> return modName
364 _ -> error "too many --module options."
367 getSymbolName :: [CmdOpt] -> String -> IO String
368 getSymbolName opts modName
369 = let symNameOpts = filter (\ x -> case x of
372 -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
374 defaultSymName = mkDefault modName
375 mkDefault = headToLower . getLastComp
376 headToLower str = case str of
377 [] -> error "module name must not be empty"
378 (x:xs) -> toLower x : xs
379 getLastComp = reverse . fst . break (== '.') . reverse
382 [] -> return defaultSymName
383 (OptSymName symName):[] -> return symName
384 _ -> error "too many --symbol options."
387 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
388 getMIMEType opts srcFile
389 = let mimeTypeOpts = filter (\ x -> case x of
390 OptMIMEType _ -> True
392 defaultType = fromMaybe (read "application/octet-stream")
393 $ guessTypeByFileName defaultExtensionMap srcFile
396 [] -> return defaultType
397 (OptMIMEType mimeType):[] -> return $ read mimeType
398 _ -> error "too many --mime-type options."
401 getLastModified :: FilePath -> IO UTCTime
402 getLastModified "-" = getCurrentTime
403 getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)
404 $ getFileStatus fpath
407 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
409 = let eTagOpts = filter (\ x -> case x of
414 [] -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1")
415 (OptETag str):[] -> return str
416 _ -> error "too many --etag options."
418 mkETagFromInput :: Digest -> String
419 mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
421 toHex :: String -> String
422 toHex = foldr ((++) . hexByte . fromEnum) ""
424 hexByte :: Int -> String
426 = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
427 , hex4bit ( n .&. 0x0F)
430 hex4bit :: Int -> Char
432 | n < 10 = chr $ ord '0' + n
433 | n < 16 = chr $ ord 'a' + n - 10
434 | otherwise = undefined
437 openInput :: FilePath -> IO Lazy.ByteString
438 openInput "-" = L.getContents
439 openInput fpath = L.readFile fpath
442 openOutput :: [CmdOpt] -> IO Handle
444 = let outputOpts = filter (\ x -> case x of
450 (OptOutput fpath):[] -> openFile fpath WriteMode
451 _ -> error "two many --output options."
455 作られるファイルの例 (壓縮されない場合):
456 ------------------------------------------------------------------------------
457 {- DO NOT EDIT THIS FILE.
458 This file is automatically generated by the lucu-implant-file program.
461 Original Length: 302 bytes
462 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
463 Compression: disabled
465 ETag: d41d8cd98f00b204e9800998ecf8427e
466 Last Modified: 2007-11-05 13:53:42.231882 JST
468 module Foo.Bar.Baz (baz) where
469 import Codec.Binary.Base64
470 import qualified Data.ByteString.Lazy as L
473 import Network.HTTP.Lucu
477 resUsesNativeThread = False
478 , resIsGreedy = False
480 = Just (do foundEntity entityTag lastModified
481 setContentType contentType
486 , resDelete = Nothing
490 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
492 lastModified :: UTCTime
493 lastModified = read "2007-11-05 04:47:56.008366 UTC"
495 contentType :: MIMEType
496 contentType = read "image/png"
498 rawData :: L.ByteString
499 rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
500 ------------------------------------------------------------------------------
503 ------------------------------------------------------------------------------
506 import Codec.Compression.GZip
508 -- ResourceDef は次のやうに變化
511 resUsesNativeThread = False
512 , resIsGreedy = False
514 = Just (do foundEntity entityTag lastModified
515 setContentType contentType
517 mustGunzip <- liftM not (isEncodingAcceptable "gzip")
519 outputLBS (decompress gzippedData)
521 do setContentEncoding ["gzip"]
522 outputLBS gzippedData
526 , resDelete = Nothing
529 -- rawData の代はりに gzippedData
530 gzippedData :: L.ByteString
531 gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
532 ------------------------------------------------------------------------------