1 import Codec.Compression.GZip
4 import qualified Data.ByteString as BS
5 import qualified Data.ByteString.Base64 as B64
6 import qualified Data.ByteString.Char8 as C8
7 import qualified Data.ByteString.Lazy as Lazy (ByteString)
8 import qualified Data.ByteString.Lazy as LS hiding (ByteString)
13 import Data.Time.Clock.POSIX
14 import Language.Haskell.Pretty
15 import Language.Haskell.Syntax
16 import Network.HTTP.Lucu.MIMEType
17 import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
18 import Network.HTTP.Lucu.MIMEType.Guess
20 import OpenSSL.EVP.Digest
21 import System.Console.GetOpt
22 import System.Environment
24 import System.Posix.Files
37 options :: [OptDescr CmdOpt]
38 options = [ Option ['o'] ["output"]
39 (ReqArg OptOutput "FILE")
42 , Option ['m'] ["module"]
43 (ReqArg OptModName "MODULE")
44 "Specify the resulting module name. (required)"
46 , Option ['s'] ["symbol"]
47 (ReqArg OptSymName "SYMBOL")
48 "Specify the resulting symbol name."
50 , Option ['t'] ["mime-type"]
51 (ReqArg OptMIMEType "TYPE")
52 "Specify the MIME Type of the file."
54 , Option ['e'] ["etag"]
55 (ReqArg OptETag "TAG")
56 "Specify the ETag of the file."
58 , Option ['h'] ["help"]
65 printUsage = do putStrLn ""
66 putStrLn "Description:"
67 putStrLn (" lucu-implant-file is an utility that generates " ++
68 "Haskell code containing an arbitrary file to " ++
69 "compile it directly into programs and serve it " ++
70 "statically with the Lucu HTTP server.")
73 putStrLn " lucu-implant-file [OPTIONS...] FILE"
75 putStr $ usageInfo "Options:" options
81 do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
84 $ do mapM_ putStr errors
85 exitWith $ ExitFailure 1
87 when (any (== OptHelp) opts)
93 exitWith $ ExitFailure 1
95 when (length sources >= 2)
96 $ error "too many input files."
98 generateHaskellSource opts (head sources)
101 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
102 generateHaskellSource opts srcFile
103 = do modName <- getModuleName opts
104 symName <- getSymbolName opts modName
105 mimeType <- getMIMEType opts srcFile
106 lastMod <- getLastModified srcFile
107 input <- openInput srcFile
108 output <- openOutput opts
109 eTag <- getETag opts input
111 let compParams = defaultCompressParams { compressLevel = bestCompression }
112 gzippedData = compressWith compParams input
113 originalLen = LS.length input
114 gzippedLen = LS.length gzippedData
115 useGZip = originalLen > gzippedLen
116 rawB64 = B64.encode $ BS.concat $ LS.toChunks input
117 gzippedB64 = B64.encode $ BS.concat $ LS.toChunks gzippedData
119 header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
121 let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
122 exports = [HsEVar (UnQual (HsIdent symName))]
123 imports = [ HsImportDecl undefined (Module "Data.ByteString.Base64")
124 True (Just (Module "B64")) Nothing
125 , HsImportDecl undefined (Module "Data.ByteString.Char8")
126 True (Just (Module "C8")) Nothing
127 , HsImportDecl undefined (Module "Data.ByteString.Lazy")
128 True (Just (Module "LS")) Nothing
129 , HsImportDecl undefined (Module "Data.Time")
130 False Nothing Nothing
131 , HsImportDecl undefined (Module "Network.HTTP.Lucu")
132 False Nothing Nothing
136 [ HsImportDecl undefined (Module "Control.Monad")
137 False Nothing Nothing
138 , HsImportDecl undefined (Module "Codec.Compression.GZip")
139 False Nothing Nothing
143 decls = declResourceDef
155 declResourceDef :: [HsDecl]
157 = [ HsTypeSig undefined [HsIdent symName]
159 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
160 , HsFunBind [HsMatch undefined (HsIdent symName)
161 [] (HsUnGuardedRhs defResourceDef) []]
164 defResourceDef :: HsExp
166 = let defResGet = if useGZip
167 then defResGetGZipped
170 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
171 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
172 (HsCon (UnQual (HsIdent "False")))
173 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
174 (HsCon (UnQual (HsIdent "False")))
175 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
176 , HsFieldUpdate (UnQual (HsIdent "resHead"))
177 (HsCon (UnQual (HsIdent "Nothing")))
178 , HsFieldUpdate (UnQual (HsIdent "resPost"))
179 (HsCon (UnQual (HsIdent "Nothing")))
180 , HsFieldUpdate (UnQual (HsIdent "resPut"))
181 (HsCon (UnQual (HsIdent "Nothing")))
182 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
183 (HsCon (UnQual (HsIdent "Nothing")))
187 defResGetGZipped :: HsExp
189 = let doExp = HsDo [ doFoundEntity
192 , doConditionalOutput
195 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
196 (HsVar (UnQual (HsIdent "entityTag"))))
197 (HsVar (UnQual (HsIdent "lastModified"))))
199 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
200 (HsVar (UnQual (HsIdent "contentType"))))
202 = HsGenerator undefined
203 (HsPVar (HsIdent "mustGunzip"))
204 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
205 (HsVar (UnQual (HsIdent "not"))))
207 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
208 (HsLit (HsString "gzip")))))
211 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
215 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
217 (HsApp (HsVar (UnQual (HsIdent "decompress")))
218 (HsVar (UnQual (HsIdent "gzippedData"))))))
220 = HsDo [ doSetContentEncodingGZip
223 doSetContentEncodingGZip
224 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
225 (HsList [HsLit (HsString "gzip")]))
227 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
228 (HsVar (UnQual (HsIdent "gzippedData"))))
230 HsApp (HsCon (UnQual (HsIdent "Just")))
233 defResGetRaw :: HsExp
235 = let doExp = HsDo [ doFoundEntity
240 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
241 (HsVar (UnQual (HsIdent "entityTag"))))
242 (HsVar (UnQual (HsIdent "lastModified"))))
244 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
245 (HsVar (UnQual (HsIdent "contentType"))))
247 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
248 (HsVar (UnQual (HsIdent "rawData"))))
250 HsApp (HsCon (UnQual (HsIdent "Just")))
253 declEntityTag :: [HsDecl]
255 = [ HsTypeSig undefined [HsIdent "entityTag"]
257 (HsTyCon (UnQual (HsIdent "ETag"))))
258 , HsFunBind [HsMatch undefined (HsIdent "entityTag")
259 [] (HsUnGuardedRhs defEntityTag) []]
262 defEntityTag :: HsExp
264 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
265 (HsLit (HsString eTag))
267 declLastModified :: [HsDecl]
269 = [ HsTypeSig undefined [HsIdent "lastModified"]
271 (HsTyCon (UnQual (HsIdent "UTCTime"))))
272 , HsFunBind [HsMatch undefined (HsIdent "lastModified")
273 [] (HsUnGuardedRhs defLastModified) []]
276 defLastModified :: HsExp
278 = HsApp (HsVar (UnQual (HsIdent "read")))
279 (HsLit (HsString $ show lastMod))
282 declContentType :: [HsDecl]
284 = [ HsTypeSig undefined [HsIdent "contentType"]
286 (HsTyCon (UnQual (HsIdent "MIMEType"))))
287 , HsFunBind [HsMatch undefined (HsIdent "contentType")
288 [] (HsUnGuardedRhs defContentType) []]
291 defContentType :: HsExp
293 = HsApp (HsVar (UnQual (HsIdent "read")))
294 (HsLit (HsString $ show mimeType))
296 declGZippedData :: [HsDecl]
298 = [ HsTypeSig undefined [HsIdent "gzippedData"]
300 (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
301 , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
302 [] (HsUnGuardedRhs defGZippedData) []]
305 defGZippedData :: HsExp
307 = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
308 (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
310 (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
311 (HsLit (HsString $ C8.unpack gzippedB64))))])
313 declRawData :: [HsDecl]
315 = [ HsTypeSig undefined [HsIdent "rawData"]
317 (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
318 , HsFunBind [HsMatch undefined (HsIdent "rawData")
319 [] (HsUnGuardedRhs defRawData) []]
324 = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
325 (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
327 (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
328 (HsLit (HsString $ C8.unpack 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 "-" = LS.getContents
439 openInput fpath = LS.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 qualified Data.ByteString.Base64 as B64
470 import qualified Data.ByteString.Char8 as C8
471 import qualified Data.ByteString.Lazy as LS
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 :: LS.ByteString
499 rawData = LS.fromChunks [B64.decodeLenient (C8.pack "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 :: LS.ByteString
531 gzippedData = LS.fromChunks [B64.decodeLenient (C8.pack "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")]
532 ------------------------------------------------------------------------------