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 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 = getFileStatus fpath
404 >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
407 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
409 = let eTagOpts = filter (\ x -> case x of
414 [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust
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 :: [Char] -> String
423 toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs
425 hexByte :: Int -> String
427 = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
429 hex4bit :: Int -> Char
431 | n < 10 = (chr $ ord '0' + n )
432 | n < 16 = (chr $ ord 'a' + n - 10)
433 | otherwise = undefined
436 openInput :: FilePath -> IO Lazy.ByteString
437 openInput "-" = L.getContents
438 openInput fpath = L.readFile fpath
441 openOutput :: [CmdOpt] -> IO Handle
443 = let outputOpts = filter (\ x -> case x of
449 (OptOutput fpath):[] -> openFile fpath WriteMode
450 _ -> error "two many --output options."
454 作られるファイルの例 (壓縮されない場合):
455 ------------------------------------------------------------------------------
456 {- DO NOT EDIT THIS FILE.
457 This file is automatically generated by the lucu-implant-file program.
460 Original Length: 302 bytes
461 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
462 Compression: disabled
464 ETag: d41d8cd98f00b204e9800998ecf8427e
465 Last Modified: 2007-11-05 13:53:42.231882 JST
467 module Foo.Bar.Baz (baz) where
468 import Codec.Binary.Base64
469 import qualified Data.ByteString.Lazy as L
472 import Network.HTTP.Lucu
476 resUsesNativeThread = False
477 , resIsGreedy = False
479 = Just (do foundEntity entityTag lastModified
480 setContentType contentType
485 , resDelete = Nothing
489 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
491 lastModified :: UTCTime
492 lastModified = read "2007-11-05 04:47:56.008366 UTC"
494 contentType :: MIMEType
495 contentType = read "image/png"
497 rawData :: L.ByteString
498 rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
499 ------------------------------------------------------------------------------
502 ------------------------------------------------------------------------------
505 import Codec.Compression.GZip
507 -- ResourceDef は次のやうに變化
510 resUsesNativeThread = False
511 , resIsGreedy = False
513 = Just (do foundEntity entityTag lastModified
514 setContentType contentType
516 mustGunzip <- liftM not (isEncodingAcceptable "gzip")
518 outputLBS (decompress gzippedData)
520 do setContentEncoding ["gzip"]
521 outputLBS gzippedData
525 , resDelete = Nothing
528 -- rawData の代はりに gzippedData
529 gzippedData :: L.ByteString
530 gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
531 ------------------------------------------------------------------------------