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
81 when (not $ null errors)
82 $ do mapM_ putStr errors
83 exitWith $ ExitFailure 1
85 when (any (\ x -> x == 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 gzippedData = compressWith BestCompression input
110 originalLen = L.length input
111 gzippedLen = L.length gzippedData
112 useGZip = originalLen > gzippedLen
113 rawB64 = encode $ L.unpack input
114 gzippedB64 = encode $ L.unpack gzippedData
116 header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
118 let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
119 exports = [HsEVar (UnQual (HsIdent symName))]
120 imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
121 False Nothing Nothing
122 , HsImportDecl undefined (Module "Data.ByteString.Lazy")
123 True (Just (Module "L")) Nothing
124 , HsImportDecl undefined (Module "Data.Maybe")
125 False Nothing Nothing
126 , HsImportDecl undefined (Module "Data.Time")
127 False Nothing Nothing
128 , HsImportDecl undefined (Module "Network.HTTP.Lucu")
129 False Nothing Nothing
133 [ HsImportDecl undefined (Module "Control.Monad")
134 False Nothing Nothing
135 , HsImportDecl undefined (Module "Codec.Compression.GZip")
136 False Nothing Nothing
140 decls = declResourceDef
152 declResourceDef :: [HsDecl]
154 = [ HsTypeSig undefined [HsIdent symName]
156 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
157 , HsFunBind [HsMatch undefined (HsIdent symName)
158 [] (HsUnGuardedRhs defResourceDef) []]
161 defResourceDef :: HsExp
163 = let defResGet = if useGZip
164 then defResGetGZipped
167 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
168 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
169 (HsCon (UnQual (HsIdent "False")))
170 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
171 (HsCon (UnQual (HsIdent "False")))
172 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
173 , HsFieldUpdate (UnQual (HsIdent "resHead"))
174 (HsCon (UnQual (HsIdent "Nothing")))
175 , HsFieldUpdate (UnQual (HsIdent "resPost"))
176 (HsCon (UnQual (HsIdent "Nothing")))
177 , HsFieldUpdate (UnQual (HsIdent "resPut"))
178 (HsCon (UnQual (HsIdent "Nothing")))
179 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
180 (HsCon (UnQual (HsIdent "Nothing")))
184 defResGetGZipped :: HsExp
186 = let doExp = HsDo [ doFoundEntity
189 , doConditionalOutput
192 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
193 (HsVar (UnQual (HsIdent "entityTag"))))
194 (HsVar (UnQual (HsIdent "lastModified"))))
196 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
197 (HsVar (UnQual (HsIdent "contentType"))))
199 = HsGenerator undefined
200 (HsPVar (HsIdent "mustGunzip"))
201 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
202 (HsVar (UnQual (HsIdent "not"))))
204 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
205 (HsLit (HsString "gzip")))))
208 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
212 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
214 (HsApp (HsVar (UnQual (HsIdent "decompress")))
215 (HsVar (UnQual (HsIdent "gzippedData"))))))
217 = HsDo [ doSetContentEncodingGZip
220 doSetContentEncodingGZip
221 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
222 (HsList [HsLit (HsString "gzip")]))
224 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
225 (HsVar (UnQual (HsIdent "gzippedData"))))
227 HsApp (HsCon (UnQual (HsIdent "Just")))
230 defResGetRaw :: HsExp
232 = let doExp = HsDo [ doFoundEntity
237 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
238 (HsVar (UnQual (HsIdent "entityTag"))))
239 (HsVar (UnQual (HsIdent "lastModified"))))
241 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
242 (HsVar (UnQual (HsIdent "contentType"))))
244 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
245 (HsVar (UnQual (HsIdent "rawData"))))
247 HsApp (HsCon (UnQual (HsIdent "Just")))
250 declEntityTag :: [HsDecl]
252 = [ HsTypeSig undefined [HsIdent "entityTag"]
254 (HsTyCon (UnQual (HsIdent "ETag"))))
255 , HsFunBind [HsMatch undefined (HsIdent "entityTag")
256 [] (HsUnGuardedRhs defEntityTag) []]
259 defEntityTag :: HsExp
261 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
262 (HsLit (HsString eTag))
264 declLastModified :: [HsDecl]
266 = [ HsTypeSig undefined [HsIdent "lastModified"]
268 (HsTyCon (UnQual (HsIdent "UTCTime"))))
269 , HsFunBind [HsMatch undefined (HsIdent "lastModified")
270 [] (HsUnGuardedRhs defLastModified) []]
273 defLastModified :: HsExp
275 = HsApp (HsVar (UnQual (HsIdent "read")))
276 (HsLit (HsString $ show lastMod))
279 declContentType :: [HsDecl]
281 = [ HsTypeSig undefined [HsIdent "contentType"]
283 (HsTyCon (UnQual (HsIdent "MIMEType"))))
284 , HsFunBind [HsMatch undefined (HsIdent "contentType")
285 [] (HsUnGuardedRhs defContentType) []]
288 defContentType :: HsExp
290 = HsApp (HsVar (UnQual (HsIdent "read")))
291 (HsLit (HsString $ show mimeType))
293 declGZippedData :: [HsDecl]
295 = [ HsTypeSig undefined [HsIdent "gzippedData"]
297 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
298 , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
299 [] (HsUnGuardedRhs defGZippedData) []]
302 defGZippedData :: HsExp
304 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
306 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
308 (HsApp (HsVar (UnQual (HsIdent "decode")))
309 (HsLit (HsString gzippedB64))))))
311 declRawData :: [HsDecl]
313 = [ HsTypeSig undefined [HsIdent "rawData"]
315 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
316 , HsFunBind [HsMatch undefined (HsIdent "rawData")
317 [] (HsUnGuardedRhs defRawData) []]
322 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
324 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
326 (HsApp (HsVar (UnQual (HsIdent "decode")))
327 (HsLit (HsString rawB64))))))
329 hPutStrLn output header
330 hPutStrLn output (prettyPrint hsModule)
334 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
335 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
336 = do localLastMod <- utcToLocalZonedTime lastMod
337 return ("{- DO NOT EDIT THIS FILE.\n" ++
338 " This file is automatically generated by the lucu-implant-file program.\n" ++
340 " Source: " ++ (if srcFile == "-"
342 else srcFile) ++ "\n" ++
343 " Original Length: " ++ show originalLen ++ " bytes\n" ++
345 then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
346 " Compression: gzip\n"
347 else " Compression: disabled\n") ++
348 " MIME Type: " ++ show mimeType ++ "\n" ++
349 " ETag: " ++ eTag ++ "\n" ++
350 " Last Modified: " ++ show localLastMod ++ "\n" ++
354 getModuleName :: [CmdOpt] -> IO String
356 = let modNameOpts = filter (\ x -> case x of
361 [] -> error "a module name must be given."
362 (OptModName modName):[] -> return modName
363 _ -> error "too many --module options."
366 getSymbolName :: [CmdOpt] -> String -> IO String
367 getSymbolName opts modName
368 = let symNameOpts = filter (\ x -> case x of
371 -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
373 defaultSymName = mkDefault modName
374 mkDefault = headToLower . getLastComp
375 headToLower = \ str -> case str of
376 [] -> error "module name must not be empty"
377 (x:xs) -> toLower x : xs
378 getLastComp = reverse . fst . break (== '.') . reverse
381 [] -> return defaultSymName
382 (OptSymName symName):[] -> return symName
383 _ -> error "too many --symbol options."
386 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
387 getMIMEType opts srcFile
388 = let mimeTypeOpts = filter (\ x -> case x of
389 OptMIMEType _ -> True
391 defaultType = fromMaybe (read "application/octet-stream")
392 $ guessTypeByFileName defaultExtensionMap srcFile
395 [] -> return defaultType
396 (OptMIMEType mimeType):[] -> return $ read mimeType
397 _ -> error "too many --mime-type options."
400 getLastModified :: FilePath -> IO UTCTime
401 getLastModified "-" = getCurrentTime
402 getLastModified fpath = getFileStatus fpath
403 >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
406 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
408 = let eTagOpts = filter (\ x -> case x of
413 [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust
414 (OptETag str):[] -> return str
415 _ -> error "too many --etag options."
417 mkETagFromInput :: Digest -> String
418 mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input)
420 toHex :: [Char] -> String
422 toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs
424 hexByte :: Int -> String
426 = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
428 hex4bit :: Int -> Char
430 | n < 10 = (chr $ ord '0' + n )
431 | n < 16 = (chr $ ord 'a' + n - 10)
432 | otherwise = undefined
435 openInput :: FilePath -> IO Lazy.ByteString
436 openInput "-" = L.getContents
437 openInput fpath = L.readFile fpath
440 openOutput :: [CmdOpt] -> IO Handle
442 = let outputOpts = filter (\ x -> case x of
448 (OptOutput fpath):[] -> openFile fpath WriteMode
449 _ -> error "two many --output options."
453 作られるファイルの例 (壓縮されない場合):
454 ------------------------------------------------------------------------------
455 {- DO NOT EDIT THIS FILE.
456 This file is automatically generated by the lucu-implant-file program.
459 Original Length: 302 bytes
460 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
461 Compression: disabled
463 ETag: d41d8cd98f00b204e9800998ecf8427e
464 Last Modified: 2007-11-05 13:53:42.231882 JST
466 module Foo.Bar.Baz (baz) where
467 import Codec.Binary.Base64
468 import qualified Data.ByteString.Lazy as L
471 import Network.HTTP.Lucu
475 resUsesNativeThread = False
476 , resIsGreedy = False
478 = Just (do foundEntity entityTag lastModified
479 setContentType contentType
484 , resDelete = Nothing
488 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
490 lastModified :: UTCTime
491 lastModified = read "2007-11-05 04:47:56.008366 UTC"
493 contentType :: MIMEType
494 contentType = read "image/png"
496 rawData :: L.ByteString
497 rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
498 ------------------------------------------------------------------------------
501 ------------------------------------------------------------------------------
504 import Codec.Compression.GZip
506 -- ResourceDef は次のやうに變化
509 resUsesNativeThread = False
510 , resIsGreedy = False
512 = Just (do foundEntity entityTag lastModified
513 setContentType contentType
515 mustGunzip <- liftM not (isEncodingAcceptable "gzip")
517 outputLBS (decompress gzippedData)
519 do setContentEncoding ["gzip"]
520 outputLBS gzippedData
524 , resDelete = Nothing
527 -- rawData の代はりに gzippedData
528 gzippedData :: L.ByteString
529 gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
530 ------------------------------------------------------------------------------