1 import Codec.Binary.Base64
2 import Codec.Compression.GZip
5 import Data.ByteString.Base (LazyByteString)
6 import qualified Data.ByteString.Lazy as L
8 import Data.Digest.SHA1
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
17 import System.Console.GetOpt
18 import System.Directory
19 import System.Environment
34 options :: [OptDescr CmdOpt]
35 options = [ Option ['o'] ["output"]
36 (ReqArg OptOutput "FILE")
39 , Option ['m'] ["module"]
40 (ReqArg OptModName "MODULE")
41 "Specify the resulting module name. (required)"
43 , Option ['s'] ["symbol"]
44 (ReqArg OptSymName "SYMBOL")
45 "Specify the resulting symbol name."
47 , Option ['t'] ["mime-type"]
48 (ReqArg OptMIMEType "TYPE")
49 "Specify the MIME Type of the file."
51 , Option ['e'] ["etag"]
52 (ReqArg OptETag "TAG")
53 "Specify the ETag of the file."
55 , Option ['h'] ["help"]
62 printUsage = do putStrLn ""
63 putStrLn "Description:"
64 putStrLn (" lucu-implant-file is an utility that generates " ++
65 "Haskell code containing an arbitrary file to " ++
66 "compile it directly into programs and serve it " ++
67 "statically with the Lucu HTTP server.")
70 putStrLn " lucu-implant-file [OPTIONS...] FILE"
72 putStr $ usageInfo "Options:" options
77 main = do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
79 when (not $ null errors)
80 $ do mapM_ putStr errors
81 exitWith $ ExitFailure 1
83 when (any (\ x -> x == OptHelp) opts)
89 exitWith $ ExitFailure 1
91 when (length sources >= 2)
92 $ error "too many input files."
94 generateHaskellSource opts (head sources)
97 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
98 generateHaskellSource opts srcFile
99 = do modName <- getModuleName opts
100 symName <- getSymbolName opts modName
101 mimeType <- getMIMEType opts srcFile
102 lastMod <- getLastModified srcFile
103 input <- openInput srcFile
104 output <- openOutput opts
105 eTag <- getETag opts input
107 let gzippedData = compressWith BestCompression input
108 originalLen = L.length input
109 gzippedLen = L.length gzippedData
110 useGZip = originalLen > gzippedLen
111 rawB64 = encode $ L.unpack input
112 gzippedB64 = encode $ L.unpack gzippedData
114 header = mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
116 hsModule = HsModule undefined (Module modName) (Just exports) imports decls
117 exports = [HsEVar (UnQual (HsIdent symName))]
118 imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
119 False Nothing Nothing
120 , HsImportDecl undefined (Module "Data.ByteString.Base")
121 False Nothing (Just (False, [HsIVar (HsIdent "LazyByteString")]))
122 , HsImportDecl undefined (Module "Data.ByteString.Lazy")
123 True (Just (Module "L")) Nothing
124 , HsImportDecl undefined (Module "Network.HTTP.Lucu")
125 False Nothing Nothing
126 , HsImportDecl undefined (Module "System.Time")
127 False Nothing Nothing
131 [ HsImportDecl undefined (Module "Control.Monad")
132 False Nothing Nothing
133 , HsImportDecl undefined (Module "Codec.Compression.GZip")
134 False Nothing Nothing
138 decls = declResourceDef
150 declResourceDef :: [HsDecl]
152 = [ HsTypeSig undefined [HsIdent symName]
154 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
155 , HsFunBind [HsMatch undefined (HsIdent symName)
156 [] (HsUnGuardedRhs defResourceDef) []]
159 defResourceDef :: HsExp
161 = let defResGet = if useGZip
162 then defResGetGZipped
165 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
166 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
167 (HsCon (UnQual (HsIdent "False")))
168 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
169 (HsCon (UnQual (HsIdent "False")))
170 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
171 , HsFieldUpdate (UnQual (HsIdent "resHead"))
172 (HsCon (UnQual (HsIdent "Nothing")))
173 , HsFieldUpdate (UnQual (HsIdent "resPost"))
174 (HsCon (UnQual (HsIdent "Nothing")))
175 , HsFieldUpdate (UnQual (HsIdent "resPut"))
176 (HsCon (UnQual (HsIdent "Nothing")))
177 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
178 (HsCon (UnQual (HsIdent "Nothing")))
182 defResGetGZipped :: HsExp
184 = let doExp = HsDo [ doFoundEntity
187 , doConditionalOutput
190 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
191 (HsVar (UnQual (HsIdent "entityTag"))))
192 (HsVar (UnQual (HsIdent "lastModified"))))
194 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
195 (HsVar (UnQual (HsIdent "contentType"))))
197 = HsGenerator undefined
198 (HsPVar (HsIdent "mustGunzip"))
199 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
200 (HsVar (UnQual (HsIdent "not"))))
202 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
203 (HsLit (HsString "gzip")))))
206 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
210 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
212 (HsApp (HsVar (UnQual (HsIdent "decompress")))
213 (HsVar (UnQual (HsIdent "gzippedData"))))))
215 = HsDo [ doSetContentEncodingGZip
218 doSetContentEncodingGZip
219 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
220 (HsList [HsLit (HsString "gzip")]))
222 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
223 (HsVar (UnQual (HsIdent "gzippedData"))))
225 HsApp (HsCon (UnQual (HsIdent "Just")))
228 defResGetRaw :: HsExp
230 = let doExp = HsDo [ doFoundEntity
235 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
236 (HsVar (UnQual (HsIdent "entityTag"))))
237 (HsVar (UnQual (HsIdent "lastModified"))))
239 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
240 (HsVar (UnQual (HsIdent "contentType"))))
242 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
243 (HsVar (UnQual (HsIdent "rawData"))))
245 HsApp (HsCon (UnQual (HsIdent "Just")))
248 declEntityTag :: [HsDecl]
250 = [ HsTypeSig undefined [HsIdent "entityTag"]
252 (HsTyCon (UnQual (HsIdent "ETag"))))
253 , HsFunBind [HsMatch undefined (HsIdent "entityTag")
254 [] (HsUnGuardedRhs defEntityTag) []]
257 defEntityTag :: HsExp
259 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
260 (HsLit (HsString eTag))
262 declLastModified :: [HsDecl]
264 = [ HsTypeSig undefined [HsIdent "lastModified"]
266 (HsTyCon (UnQual (HsIdent "ClockTime"))))
267 , HsFunBind [HsMatch undefined (HsIdent "lastModified")
268 [] (HsUnGuardedRhs defLastModified) []]
271 defLastModified :: HsExp
273 = let TOD a b = lastMod
275 (HsApp (HsApp (HsCon (UnQual (HsIdent "TOD")))
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 (UnQual (HsIdent "LazyByteString"))))
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 "decode")))
308 (HsLit (HsString gzippedB64))))
310 declRawData :: [HsDecl]
312 = [ HsTypeSig undefined [HsIdent "rawData"]
314 (HsTyCon (UnQual (HsIdent "LazyByteString"))))
315 , HsFunBind [HsMatch undefined (HsIdent "rawData")
316 [] (HsUnGuardedRhs defRawData) []]
321 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
323 (HsApp (HsVar (UnQual (HsIdent "decode")))
324 (HsLit (HsString rawB64))))
326 hPutStrLn output header
327 hPutStrLn output (prettyPrint hsModule)
331 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String
332 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
333 = "{- DO NOT EDIT THIS FILE.\n" ++
334 " This file is automatically generated by the lucu-implant-file program.\n" ++
336 " Source: " ++ (if srcFile == "-"
338 else srcFile) ++ "\n" ++
339 " Original Length: " ++ show originalLen ++ " bytes\n" ++
341 then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
342 " Compression: gzip\n"
343 else " Compression: disabled\n") ++
344 " MIME Type: " ++ show mimeType ++ "\n" ++
345 " ETag: " ++ eTag ++ "\n" ++
346 " Last Modified: " ++ show lastMod ++ "\n" ++
350 getModuleName :: [CmdOpt] -> IO String
352 = let modNameOpts = filter (\ x -> case x of
357 [] -> error "a module name must be given."
358 (OptModName modName):[] -> return modName
359 _ -> error "too many --module options."
362 getSymbolName :: [CmdOpt] -> String -> IO String
363 getSymbolName opts modName
364 = let symNameOpts = filter (\ x -> case x of
367 -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
369 defaultSymName = mkDefault modName
370 mkDefault = headToLower . getLastComp
371 headToLower = \ str -> case str of
372 (x:xs) -> toLower x : xs
373 getLastComp = reverse . fst . break (== '.') . reverse
376 [] -> return defaultSymName
377 (OptSymName symName):[] -> return symName
378 _ -> error "too many --symbol options."
381 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
382 getMIMEType opts srcFile
383 = let mimeTypeOpts = filter (\ x -> case x of
384 OptMIMEType _ -> True
386 defaultType = fromMaybe (read "application/octet-stream")
387 $ guessTypeByFileName defaultExtensionMap srcFile
390 [] -> return defaultType
391 (OptMIMEType mimeType):[] -> return $ read mimeType
392 _ -> error "too many --mime-type options."
395 getLastModified :: FilePath -> IO ClockTime
396 getLastModified "-" = getClockTime
397 getLastModified fpath = getModificationTime fpath
400 getETag :: [CmdOpt] -> LazyByteString -> IO String
402 = let eTagOpts = filter (\ x -> case x of
407 [] -> return mkETagFromInput
408 (OptETag str):[] -> return str
409 _ -> error "too many --etag options."
411 mkETagFromInput :: String
412 mkETagFromInput = "SHA-1:" ++ (toHex $ hash $ L.unpack input)
414 toHex :: [Word8] -> String
416 toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs
418 hexByte :: Int -> String
420 = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
422 hex4bit :: Int -> Char
424 | n < 10 = (chr $ ord '0' + n )
425 | n < 16 = (chr $ ord 'a' + n - 10)
428 openInput :: FilePath -> IO LazyByteString
429 openInput "-" = L.getContents
430 openInput fpath = L.readFile fpath
433 openOutput :: [CmdOpt] -> IO Handle
435 = let outputOpts = filter (\ x -> case x of
441 (OptOutput fpath):[] -> openFile fpath WriteMode
442 _ -> error "two many --output options."
446 作られるファイルの例 (壓縮されない場合):
447 ------------------------------------------------------------------------------
448 {- DO NOT EDIT THIS FILE.
449 This file is automatically generated by the lucu-implant-file program.
452 Original Length: 302 bytes
453 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
454 Compression: disabled
456 ETag: d41d8cd98f00b204e9800998ecf8427e
457 Last Modified: Wed, 03 Oct 2007 00:55:45 JST
459 module Foo.Bar.Baz (baz) where
460 import Codec.Binary.Base64
461 import Data.ByteString.Base (LazyByteString)
462 import qualified Data.ByteString.Lazy as L
463 import Network.HTTP.Lucu
468 resUsesNativeThread = False
469 , resIsGreedy = False
471 = Just (do foundEntity entityTag lastModified
472 setContentType contentType
477 , resDelete = Nothing
481 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
483 lastModified :: ClockTime
484 lastModified = TOD 1191340545 0
486 contentType :: MIMEType
487 contentType = read "image/png"
489 rawData :: LazyByteString
490 rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")
491 ------------------------------------------------------------------------------
494 ------------------------------------------------------------------------------
497 import Codec.Compression.GZip
499 -- ResourceDef は次のやうに變化
502 resUsesNativeThread = False
503 , resIsGreedy = False
505 = Just (do foundEntity entityTag lastModified
506 setContentType contentType
508 mustGunzip <- liftM not (isEncodingAcceptable "gzip")
510 outputLBS (decompress gzippedData)
512 do setContentEncoding ["gzip"]
513 outputLBS gzippedData
517 , resDelete = Nothing
520 -- rawData の代はりに gzippedData
521 gzippedData :: LazyByteString
522 gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")
523 ------------------------------------------------------------------------------