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
162 [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
163 False False Nothing Nothing Nothing
167 resourceDecl ∷ Name → Bool → [Decl]
168 resourceDecl symName useGZip
169 = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
170 , nameBind (⊥) symName valExp
174 valExp = RecUpdate (var $ name "emptyResource")
175 [ FieldUpdate (UnQual (name "resGet" )) resGet
176 , FieldUpdate (UnQual (name "resHead")) resHead
180 resGet | useGZip = resGetGZipped
181 | otherwise = resGetRaw
185 = function "Just" `app`
186 paren (doE [ foundEntityStmt
192 = function "Just" `app`
193 paren (doE [ foundEntityStmt
196 , conditionalOutputStmt
200 condVarName = name "gzipAllowed"
203 dataVarName = name "gzippedData"
209 (function "isEncodingAcceptable" `app` strE "gzip")
211 conditionalOutputStmt ∷ Stmt
212 conditionalOutputStmt
215 (doE [ setContentEncodingGZipStmt
216 , outputStmt (var dataVarName)
220 paren (function "decompress" `app` var dataVarName)
225 = function "Just" `app`
226 paren (doE [ foundEntityStmt
228 , outputStmt (var $ name "rawData")
231 setContentEncodingGZipStmt ∷ Stmt
232 setContentEncodingGZipStmt
234 ( function "setContentEncoding"
236 listE [ strE "gzip" ]
239 foundEntityStmt ∷ Stmt
242 metaFunction "foundEntity"
243 [ var $ name "entityTag"
244 , var $ name "lastModified"
247 setContentTypeStmt ∷ Stmt
250 ( function "setContentType"
252 var (name "contentType")
255 outputStmt ∷ Exp → Stmt
257 = qualStmt $ function "output" `app` e
259 entityTagDecl ∷ ETag → [Decl]
261 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
262 , nameBind (⊥) varName valExp
266 varName = name "entityTag"
269 valExp = function "parseETag" `app` 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 = function "read" `app` strE (show lastMod)
283 contentTypeDecl ∷ MIMEType → [Decl]
285 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
286 , nameBind (⊥) varName valExp
290 varName = name "contentType"
293 valExp = function "parseMIMEType" `app` 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: ", mimeTypeToString 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 mimeTypeToString ∷ MIMEType → String
343 mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
345 getModuleName ∷ [CmdOpt] → IO ModuleName
347 = case modNameOpts of
348 [] → fail "a module name must be given."
349 OptModName modName:[] → return $ ModuleName modName
350 _ → fail "too many --module options."
352 modNameOpts ∷ [CmdOpt]
353 modNameOpts = filter (\ x → case x of
357 getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
358 getSymbolName opts (ModuleName modName)
359 = case symNameOpts of
360 [] → return defaultSymName
361 OptSymName symName:[] → return $ name symName
362 _ → fail "too many --symbol options."
364 symNameOpts ∷ [CmdOpt]
365 symNameOpts = filter (\ x → case x of
369 defaultSymName ∷ Name
371 = name $ headToLower $ getLastComp modName
373 headToLower ∷ String → String
374 headToLower [] = error "module name must not be empty"
375 headToLower (x:xs) = toLower x : xs
377 getLastComp ∷ String → String
378 getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
380 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
381 getMIMEType opts srcFile
382 = case mimeTypeOpts of
383 [] → return defaultType
385 → case A.fromChars ty of
386 Just a → return $ parseMIMEType a
387 Nothing → fail "MIME type must not contain any non-ASCII letters."
388 _ → fail "too many --mime-type options."
390 mimeTypeOpts ∷ [CmdOpt]
392 = filter (\ x → case x of
396 octetStream ∷ MIMEType
397 octetStream = parseMIMEType "application/octet-stream"
399 defaultType ∷ MIMEType
400 defaultType = fromMaybe octetStream
401 $ guessTypeByFileName defaultExtensionMap srcFile
403 getLastModified ∷ FilePath → IO UTCTime
404 getLastModified "-" = getCurrentTime
405 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
409 getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
412 [] → return mkETagFromInput
413 OptETag str:[] → return $ strToETag str
414 _ → fail "too many --etag options."
417 eTagOpts = filter (\ x → case x of
421 mkETagFromInput ∷ ETag
423 = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
425 strToETag ∷ String → ETag
427 = case A.fromChars str of
428 Just a → strongETag a
429 Nothing → error "ETag must not contain any non-ASCII letters."
431 openInput ∷ FilePath → IO Lazy.ByteString
432 openInput "-" = Lazy.getContents
433 openInput fpath = Lazy.readFile fpath
435 openOutput ∷ [CmdOpt] → IO Handle
439 OptOutput fpath:[] → openFile fpath WriteMode
440 _ → fail "two many --output options."
442 outputOpts ∷ [CmdOpt]
443 outputOpts = filter (\ x → case x of
448 作られるファイルの例 (壓縮されない場合):
449 ------------------------------------------------------------------------------
450 {- DO NOT EDIT THIS FILE.
451 This file is automatically generated by the lucu-implant-file program.
454 Original Length: 302 bytes
455 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
456 Compression: disabled
458 ETag: "d41d8cd98f00b204e9800998ecf8427e"
459 Last Modified: 2007-11-05 13:53:42.231882 JST
461 {-# LANGUAGE OverloadedStrings #-}
462 module Foo.Bar.Baz (baz) where
463 import qualified Data.ByteString.Base64 as B64
464 import qualified Data.ByteString.Lazy as Lazy
466 import Network.HTTP.Lucu
470 resUsesNativeThread = False
471 , resIsGreedy = False
473 = Just $ do foundEntity entityTag lastModified
474 setContentType contentType
477 = Just $ do foundEntity entityTag lastModified
478 setContentType contentType
481 , resDelete = Nothing
485 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
487 lastModified ∷ UTCTime
488 lastModified = read "2007-11-05 04:47:56.008366 UTC"
490 contentType ∷ MIMEType
491 contentType = parseMIMEType "image/png"
493 rawData ∷ Lazy.ByteString
494 rawData = Lazy.fromChunks
495 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
496 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
498 ------------------------------------------------------------------------------
501 ------------------------------------------------------------------------------
503 import Codec.Compression.GZip
505 -- ResourceDef は次のやうに變化
508 resUsesNativeThread = False
509 , resIsGreedy = False
511 = Just $ do foundEntity entityTag lastModified
512 setContentType contentType
514 gzipAllowed ← isEncodingAcceptable "gzip"
516 do setContentEncoding ["gzip"]
519 output (decompress gzippedData)
521 = Just $ do foundEntity entityTag lastModified
522 setContentType contentType
525 , resDelete = Nothing
528 -- rawData の代はりに gzippedData
529 gzippedData ∷ Lazy.ByteString
530 gzippedData = Lazy.fromChunks
531 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
532 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
534 ------------------------------------------------------------------------------