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)
8 import Data.Digest.SHA2
12 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
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
78 main = do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
80 when (not $ null errors)
81 $ do mapM_ putStr errors
82 exitWith $ ExitFailure 1
84 when (any (\ x -> x == OptHelp) opts)
90 exitWith $ ExitFailure 1
92 when (length sources >= 2)
93 $ error "too many input files."
95 generateHaskellSource opts (head sources)
98 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
99 generateHaskellSource opts srcFile
100 = do modName <- getModuleName opts
101 symName <- getSymbolName opts modName
102 mimeType <- getMIMEType opts srcFile
103 lastMod <- getLastModified srcFile
104 input <- openInput srcFile
105 output <- openOutput opts
106 eTag <- getETag opts input
108 let gzippedData = compressWith BestCompression input
109 originalLen = L.length input
110 gzippedLen = L.length gzippedData
111 useGZip = originalLen > gzippedLen
112 rawB64 = encode $ L.unpack input
113 gzippedB64 = encode $ L.unpack gzippedData
115 header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
117 let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
118 exports = [HsEVar (UnQual (HsIdent symName))]
119 imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
120 False Nothing Nothing
121 , HsImportDecl undefined (Module "Data.ByteString.Lazy")
122 True (Just (Module "L")) Nothing
123 , HsImportDecl undefined (Module "Data.Maybe")
124 False Nothing Nothing
125 , HsImportDecl undefined (Module "Data.Time")
126 False Nothing Nothing
127 , HsImportDecl undefined (Module "Network.HTTP.Lucu")
128 False Nothing Nothing
132 [ HsImportDecl undefined (Module "Control.Monad")
133 False Nothing Nothing
134 , HsImportDecl undefined (Module "Codec.Compression.GZip")
135 False Nothing Nothing
139 decls = declResourceDef
151 declResourceDef :: [HsDecl]
153 = [ HsTypeSig undefined [HsIdent symName]
155 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
156 , HsFunBind [HsMatch undefined (HsIdent symName)
157 [] (HsUnGuardedRhs defResourceDef) []]
160 defResourceDef :: HsExp
162 = let defResGet = if useGZip
163 then defResGetGZipped
166 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
167 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
168 (HsCon (UnQual (HsIdent "False")))
169 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
170 (HsCon (UnQual (HsIdent "False")))
171 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
172 , HsFieldUpdate (UnQual (HsIdent "resHead"))
173 (HsCon (UnQual (HsIdent "Nothing")))
174 , HsFieldUpdate (UnQual (HsIdent "resPost"))
175 (HsCon (UnQual (HsIdent "Nothing")))
176 , HsFieldUpdate (UnQual (HsIdent "resPut"))
177 (HsCon (UnQual (HsIdent "Nothing")))
178 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
179 (HsCon (UnQual (HsIdent "Nothing")))
183 defResGetGZipped :: HsExp
185 = let doExp = HsDo [ doFoundEntity
188 , doConditionalOutput
191 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
192 (HsVar (UnQual (HsIdent "entityTag"))))
193 (HsVar (UnQual (HsIdent "lastModified"))))
195 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
196 (HsVar (UnQual (HsIdent "contentType"))))
198 = HsGenerator undefined
199 (HsPVar (HsIdent "mustGunzip"))
200 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
201 (HsVar (UnQual (HsIdent "not"))))
203 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
204 (HsLit (HsString "gzip")))))
207 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
211 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
213 (HsApp (HsVar (UnQual (HsIdent "decompress")))
214 (HsVar (UnQual (HsIdent "gzippedData"))))))
216 = HsDo [ doSetContentEncodingGZip
219 doSetContentEncodingGZip
220 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
221 (HsList [HsLit (HsString "gzip")]))
223 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
224 (HsVar (UnQual (HsIdent "gzippedData"))))
226 HsApp (HsCon (UnQual (HsIdent "Just")))
229 defResGetRaw :: HsExp
231 = let doExp = HsDo [ doFoundEntity
236 = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
237 (HsVar (UnQual (HsIdent "entityTag"))))
238 (HsVar (UnQual (HsIdent "lastModified"))))
240 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
241 (HsVar (UnQual (HsIdent "contentType"))))
243 = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
244 (HsVar (UnQual (HsIdent "rawData"))))
246 HsApp (HsCon (UnQual (HsIdent "Just")))
249 declEntityTag :: [HsDecl]
251 = [ HsTypeSig undefined [HsIdent "entityTag"]
253 (HsTyCon (UnQual (HsIdent "ETag"))))
254 , HsFunBind [HsMatch undefined (HsIdent "entityTag")
255 [] (HsUnGuardedRhs defEntityTag) []]
258 defEntityTag :: HsExp
260 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
261 (HsLit (HsString eTag))
263 declLastModified :: [HsDecl]
265 = [ HsTypeSig undefined [HsIdent "lastModified"]
267 (HsTyCon (UnQual (HsIdent "UTCTime"))))
268 , HsFunBind [HsMatch undefined (HsIdent "lastModified")
269 [] (HsUnGuardedRhs defLastModified) []]
272 defLastModified :: HsExp
274 = HsApp (HsVar (UnQual (HsIdent "read")))
275 (HsLit (HsString $ show lastMod))
278 declContentType :: [HsDecl]
280 = [ HsTypeSig undefined [HsIdent "contentType"]
282 (HsTyCon (UnQual (HsIdent "MIMEType"))))
283 , HsFunBind [HsMatch undefined (HsIdent "contentType")
284 [] (HsUnGuardedRhs defContentType) []]
287 defContentType :: HsExp
289 = HsApp (HsVar (UnQual (HsIdent "read")))
290 (HsLit (HsString $ show mimeType))
292 declGZippedData :: [HsDecl]
294 = [ HsTypeSig undefined [HsIdent "gzippedData"]
296 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
297 , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
298 [] (HsUnGuardedRhs defGZippedData) []]
301 defGZippedData :: HsExp
303 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
305 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
307 (HsApp (HsVar (UnQual (HsIdent "decode")))
308 (HsLit (HsString gzippedB64))))))
310 declRawData :: [HsDecl]
312 = [ HsTypeSig undefined [HsIdent "rawData"]
314 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
315 , HsFunBind [HsMatch undefined (HsIdent "rawData")
316 [] (HsUnGuardedRhs defRawData) []]
321 = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
323 (HsApp (HsVar (UnQual (HsIdent "fromJust")))
325 (HsApp (HsVar (UnQual (HsIdent "decode")))
326 (HsLit (HsString rawB64))))))
328 hPutStrLn output header
329 hPutStrLn output (prettyPrint hsModule)
333 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
334 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
335 = do localLastMod <- utcToLocalZonedTime lastMod
336 return ("{- DO NOT EDIT THIS FILE.\n" ++
337 " This file is automatically generated by the lucu-implant-file program.\n" ++
339 " Source: " ++ (if srcFile == "-"
341 else srcFile) ++ "\n" ++
342 " Original Length: " ++ show originalLen ++ " bytes\n" ++
344 then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
345 " Compression: gzip\n"
346 else " Compression: disabled\n") ++
347 " MIME Type: " ++ show mimeType ++ "\n" ++
348 " ETag: " ++ eTag ++ "\n" ++
349 " Last Modified: " ++ show localLastMod ++ "\n" ++
353 getModuleName :: [CmdOpt] -> IO String
355 = let modNameOpts = filter (\ x -> case x of
360 [] -> error "a module name must be given."
361 (OptModName modName):[] -> return modName
362 _ -> error "too many --module options."
365 getSymbolName :: [CmdOpt] -> String -> IO String
366 getSymbolName opts modName
367 = let symNameOpts = filter (\ x -> case x of
370 -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
372 defaultSymName = mkDefault modName
373 mkDefault = headToLower . getLastComp
374 headToLower = \ str -> case str of
375 [] -> error "module name must not be empty"
376 (x:xs) -> toLower x : xs
377 getLastComp = reverse . fst . break (== '.') . reverse
380 [] -> return defaultSymName
381 (OptSymName symName):[] -> return symName
382 _ -> error "too many --symbol options."
385 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
386 getMIMEType opts srcFile
387 = let mimeTypeOpts = filter (\ x -> case x of
388 OptMIMEType _ -> True
390 defaultType = fromMaybe (read "application/octet-stream")
391 $ guessTypeByFileName defaultExtensionMap srcFile
394 [] -> return defaultType
395 (OptMIMEType mimeType):[] -> return $ read mimeType
396 _ -> error "too many --mime-type options."
399 getLastModified :: FilePath -> IO UTCTime
400 getLastModified "-" = getCurrentTime
401 getLastModified fpath = getFileStatus fpath
402 >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
405 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
407 = let eTagOpts = filter (\ x -> case x of
412 [] -> return mkETagFromInput
413 (OptETag str):[] -> return str
414 _ -> error "too many --etag options."
416 mkETagFromInput :: String
417 mkETagFromInput = "SHA-1:" ++ (toHex $ toOctets $ sha256 $ L.unpack input)
419 toHex :: [Word8] -> String
421 toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs
423 hexByte :: Int -> String
425 = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
427 hex4bit :: Int -> Char
429 | n < 10 = (chr $ ord '0' + n )
430 | n < 16 = (chr $ ord 'a' + n - 10)
431 | otherwise = undefined
434 openInput :: FilePath -> IO Lazy.ByteString
435 openInput "-" = L.getContents
436 openInput fpath = L.readFile fpath
439 openOutput :: [CmdOpt] -> IO Handle
441 = let outputOpts = filter (\ x -> case x of
447 (OptOutput fpath):[] -> openFile fpath WriteMode
448 _ -> error "two many --output options."
452 作られるファイルの例 (壓縮されない場合):
453 ------------------------------------------------------------------------------
454 {- DO NOT EDIT THIS FILE.
455 This file is automatically generated by the lucu-implant-file program.
458 Original Length: 302 bytes
459 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
460 Compression: disabled
462 ETag: d41d8cd98f00b204e9800998ecf8427e
463 Last Modified: 2007-11-05 13:53:42.231882 JST
465 module Foo.Bar.Baz (baz) where
466 import Codec.Binary.Base64
467 import qualified Data.ByteString.Lazy as L
470 import Network.HTTP.Lucu
474 resUsesNativeThread = False
475 , resIsGreedy = False
477 = Just (do foundEntity entityTag lastModified
478 setContentType contentType
483 , resDelete = Nothing
487 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
489 lastModified :: UTCTime
490 lastModified = read "2007-11-05 04:47:56.008366 UTC"
492 contentType :: MIMEType
493 contentType = read "image/png"
495 rawData :: L.ByteString
496 rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
497 ------------------------------------------------------------------------------
500 ------------------------------------------------------------------------------
503 import Codec.Compression.GZip
505 -- ResourceDef は次のやうに變化
508 resUsesNativeThread = False
509 , resIsGreedy = False
511 = Just (do foundEntity entityTag lastModified
512 setContentType contentType
514 mustGunzip <- liftM not (isEncodingAcceptable "gzip")
516 outputLBS (decompress gzippedData)
518 do setContentEncoding ["gzip"]
519 outputLBS gzippedData
523 , resDelete = Nothing
526 -- rawData の代はりに gzippedData
527 gzippedData :: L.ByteString
528 gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
529 ------------------------------------------------------------------------------