6 import Codec.Compression.GZip
7 import Control.Applicative
9 import qualified Data.Ascii as A
10 import qualified Data.ByteString.Base64 as B64
11 import qualified Data.ByteString.Char8 as Strict
12 import qualified Data.ByteString.Lazy as Lazy
14 import Data.Digest.Pure.SHA
18 import Data.Time.Clock.POSIX
19 import Language.Haskell.Exts.Build
20 import Language.Haskell.Exts.Extension
21 import Language.Haskell.Exts.Pretty
22 import Language.Haskell.Exts.Syntax
23 import Network.HTTP.Lucu.ETag
24 import Network.HTTP.Lucu.MIMEType
25 import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
26 import Network.HTTP.Lucu.MIMEType.Guess
27 import Prelude.Unicode
28 import System.Console.GetOpt
29 import System.Environment
31 import System.Posix.Files
43 options ∷ [OptDescr CmdOpt]
44 options = [ Option ['o'] ["output"]
45 (ReqArg OptOutput "FILE")
48 , Option ['m'] ["module"]
49 (ReqArg OptModName "MODULE")
50 "Specify the resulting module name. (required)"
52 , Option ['s'] ["symbol"]
53 (ReqArg OptSymName "SYMBOL")
54 "Specify the resulting symbol name."
56 , Option ['t'] ["mime-type"]
57 (ReqArg OptMIMEType "TYPE")
58 "Specify the MIME Type of the file."
60 , Option ['e'] ["etag"]
61 (ReqArg OptETag "TAG")
62 "Specify the ETag of the file."
64 , Option ['h'] ["help"]
70 printUsage = do mapM_ putStrLn msg
71 putStr $ usageInfo "Options:" options
76 , concat [ " lucu-implant-file is an utility that generates "
77 , "Haskell code containing an arbitrary file to "
78 , "compile it directly into programs and serve it "
79 , "statically with the Lucu HTTP server."
83 , " lucu-implant-file [OPTIONS...] FILE"
88 main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
91 $ do mapM_ putStr errors
92 exitWith $ ExitFailure 1
94 when (any (≡ OptHelp) opts)
100 exitWith $ ExitFailure 1
102 when (length sources ≥ 2)
103 $ fail "too many input files."
105 generateHaskellSource opts (head sources)
107 generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
108 generateHaskellSource opts srcFile
109 = do modName ← getModuleName opts
110 symName ← getSymbolName opts modName
111 mimeType ← getMIMEType opts srcFile
112 lastMod ← getLastModified srcFile
113 input ← openInput srcFile
114 output ← openOutput opts
115 eTag ← getETag opts input
117 let compParams = defaultCompressParams { compressLevel = bestCompression }
118 gzippedData = compressWith compParams input
119 originalLen = Lazy.length input
120 gzippedLen = Lazy.length gzippedData
121 useGZip = originalLen > gzippedLen
122 rawB64 = B64.encode <$> Lazy.toChunks input
123 gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData
125 header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
127 let hsModule = mkModule modName symName imports decls
128 imports = mkImports useGZip
129 decls = concat [ resourceDecl symName useGZip
131 , lastModifiedDecl lastMod
132 , contentTypeDecl mimeType
134 dataDecl (name "gzippedData") gzippedB64
136 dataDecl (name "rawData") rawB64
139 hPutStrLn output header
140 hPutStrLn output (prettyPrint hsModule)
143 mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module
144 mkModule modName symName imports decls
145 = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
146 exports = [ EVar (UnQual symName) ]
148 Module (⊥) modName modPragma Nothing (Just exports) imports decls
150 mkImports ∷ Bool → [ImportDecl]
152 = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
153 True False Nothing (Just (ModuleName "B64")) Nothing
154 , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
155 True False Nothing (Just (ModuleName "Lazy")) Nothing
156 , ImportDecl (⊥) (ModuleName "Data.Time")
157 False False Nothing Nothing Nothing
158 , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
159 False False Nothing Nothing Nothing
163 [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
164 False False Nothing Nothing Nothing
169 resourceDecl ∷ Name → Bool → [Decl]
170 resourceDecl symName useGZip
171 = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
172 , nameBind (⊥) symName valExp
176 valExp = RecUpdate (var $ name "emptyResource")
177 [ FieldUpdate (UnQual (name "resGet" )) resGet
178 , FieldUpdate (UnQual (name "resHead")) resHead
182 resGet | useGZip = resGetGZipped
183 | otherwise = resGetRaw
187 = infixApp (var $ name "Just")
189 (doE [ foundEntityStmt
195 = infixApp (var $ name "Just")
197 (doE [ foundEntityStmt
200 , conditionalOutputStmt
204 condVarName = name "gzipAllowed"
207 dataVarName = name "gzippedData"
213 (metaFunction "isEncodingAcceptable" [strE "gzip"])
215 conditionalOutputStmt ∷ Stmt
216 conditionalOutputStmt
219 (doE [ setContentEncodingGZipStmt
220 , outputStmt (var dataVarName)
222 (metaFunction "output"
223 [paren (metaFunction "decompress" [var dataVarName])])
227 = infixApp (var $ name "Just")
229 (doE [ foundEntityStmt
231 , outputStmt (var $ name "rawData")
234 setContentEncodingGZipStmt ∷ Stmt
235 setContentEncodingGZipStmt
237 metaFunction "setContentEncoding" $
238 [ listE [ strE "gzip" ] ]
240 foundEntityStmt ∷ Stmt
243 metaFunction "foundEntity" $
244 [ var $ name "entityTag"
245 , var $ name "lastModified"
248 setContentTypeStmt ∷ Stmt
251 metaFunction "setContentType" $
252 [var $ name "contentType"]
254 outputStmt ∷ Exp → Stmt
257 metaFunction "output" [e]
259 entityTagDecl ∷ ETag → [Decl]
261 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
262 , nameBind (⊥) varName valExp
266 varName = name "entityTag"
269 valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
271 lastModifiedDecl ∷ UTCTime → [Decl]
272 lastModifiedDecl lastMod
273 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
274 , nameBind (⊥) varName valExp
278 varName = name "lastModified"
281 valExp = metaFunction "read" [strE $ show lastMod]
283 contentTypeDecl ∷ MIMEType → [Decl]
285 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
286 , nameBind (⊥) varName valExp
290 varName = name "contentType"
293 valExp = metaFunction "parseMIMEType" [strE $ mimeToString mime]
295 mimeToString ∷ MIMEType → String
296 mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
298 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
299 dataDecl varName chunks
300 = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
301 , nameBind (⊥) varName valExp
305 valExp = qvar (ModuleName "Lazy") (name "fromChunks")
307 listE (chunkToExp <$> chunks)
309 chunkToExp ∷ Strict.ByteString → Exp
311 = qvar (ModuleName "B64") (name "decodeLenient")
313 strE (Strict.unpack chunk)
315 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
316 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
317 = do localLastMod ← utcToLocalZonedTime lastMod
319 [ "{- DO NOT EDIT THIS FILE.\n"
320 , " This file is automatically generated by the lucu-implant-file program.\n"
322 , " Source: ", if srcFile ≡ "-" then
327 , " Original Length: ", show originalLen, " bytes\n"
329 " Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
330 " Compression: gzip\n"
332 " Compression: disabled\n"
333 , " MIME Type: ", show mimeType, "\n"
334 , " ETag: ", eTagToString eTag, "\n"
335 , " Last Modified: ", show localLastMod, "\n"
339 eTagToString ∷ ETag → String
340 eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
342 getModuleName ∷ [CmdOpt] → IO ModuleName
344 = case modNameOpts of
345 [] → fail "a module name must be given."
346 (OptModName modName):[] → return $ ModuleName modName
347 _ → fail "too many --module options."
349 modNameOpts ∷ [CmdOpt]
350 modNameOpts = filter (\ x → case x of
354 getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
355 getSymbolName opts (ModuleName modName)
356 = case symNameOpts of
357 [] → return defaultSymName
358 (OptSymName symName):[] → return $ name symName
359 _ → fail "too many --symbol options."
361 symNameOpts ∷ [CmdOpt]
362 symNameOpts = filter (\ x → case x of
366 defaultSymName ∷ Name
368 = name $ headToLower $ getLastComp modName
370 headToLower ∷ String → String
371 headToLower [] = error "module name must not be empty"
372 headToLower (x:xs) = toLower x : xs
374 getLastComp ∷ String → String
375 getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
377 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
378 getMIMEType opts srcFile
379 = case mimeTypeOpts of
380 [] → return defaultType
382 → case A.fromChars ty of
383 Just a → return $ parseMIMEType a
384 Nothing → fail "MIME type must not contain any non-ASCII letters."
385 _ → fail "too many --mime-type options."
387 mimeTypeOpts ∷ [CmdOpt]
389 = filter (\ x → case x of
393 octetStream ∷ MIMEType
394 octetStream = parseMIMEType "application/octet-stream"
396 defaultType ∷ MIMEType
397 defaultType = fromMaybe octetStream
398 $ guessTypeByFileName defaultExtensionMap srcFile
400 getLastModified ∷ FilePath → IO UTCTime
401 getLastModified "-" = getCurrentTime
402 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
406 getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
409 [] → return $ mkETagFromInput
410 (OptETag str):[] → return $ strToETag str
411 _ → fail "too many --etag options."
414 eTagOpts = filter (\ x → case x of
418 mkETagFromInput ∷ ETag
420 = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
422 strToETag ∷ String → ETag
424 = case A.fromChars str of
425 Just a → strongETag a
426 Nothing → error "ETag must not contain any non-ASCII letters."
428 openInput ∷ FilePath → IO Lazy.ByteString
429 openInput "-" = Lazy.getContents
430 openInput fpath = Lazy.readFile fpath
432 openOutput ∷ [CmdOpt] → IO Handle
436 (OptOutput fpath):[] → openFile fpath WriteMode
437 _ → fail "two many --output options."
439 outputOpts ∷ [CmdOpt]
440 outputOpts = filter (\ x → case x of
445 作られるファイルの例 (壓縮されない場合):
446 ------------------------------------------------------------------------------
447 {- DO NOT EDIT THIS FILE.
448 This file is automatically generated by the lucu-implant-file program.
451 Original Length: 302 bytes
452 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
453 Compression: disabled
455 ETag: "d41d8cd98f00b204e9800998ecf8427e"
456 Last Modified: 2007-11-05 13:53:42.231882 JST
458 {-# LANGUAGE OverloadedStrings #-}
459 module Foo.Bar.Baz (baz) where
460 import qualified Data.ByteString.Base64 as B64
461 import qualified Data.ByteString.Lazy as Lazy
463 import Network.HTTP.Lucu
467 resUsesNativeThread = False
468 , resIsGreedy = False
470 = Just $ do foundEntity entityTag lastModified
471 setContentType contentType
474 = Just $ do foundEntity entityTag lastModified
475 setContentType contentType
478 , resDelete = Nothing
482 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
484 lastModified ∷ UTCTime
485 lastModified = read "2007-11-05 04:47:56.008366 UTC"
487 contentType ∷ MIMEType
488 contentType = parseMIMEType "image/png"
490 rawData ∷ Lazy.ByteString
491 rawData = Lazy.fromChunks
492 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
493 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
495 ------------------------------------------------------------------------------
498 ------------------------------------------------------------------------------
500 import Codec.Compression.GZip
502 -- ResourceDef は次のやうに變化
505 resUsesNativeThread = False
506 , resIsGreedy = False
508 = Just $ do foundEntity entityTag lastModified
509 setContentType contentType
511 gzipAllowed ← isEncodingAcceptable "gzip"
513 do setContentEncoding ["gzip"]
516 output (decompress gzippedData)
518 = Just $ do foundEntity entityTag lastModified
519 setContentType contentType
522 , resDelete = Nothing
525 -- rawData の代はりに gzippedData
526 gzippedData ∷ Lazy.ByteString
527 gzippedData = Lazy.fromChunks
528 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
529 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
531 ------------------------------------------------------------------------------