5 import Codec.Compression.GZip
6 import Control.Applicative
8 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
17 import Data.Time.Clock.POSIX
18 import Language.Haskell.Exts.Build
19 import Language.Haskell.Exts.Extension
20 import Language.Haskell.Exts.Pretty
21 import Language.Haskell.Exts.Syntax
22 import Network.HTTP.Lucu.ETag
23 import Network.HTTP.Lucu.MIMEType
24 import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
25 import Network.HTTP.Lucu.MIMEType.Guess
26 import Prelude.Unicode
27 import System.Console.GetOpt
28 import System.Environment
30 import System.Posix.Files
42 options ∷ [OptDescr CmdOpt]
43 options = [ Option ['o'] ["output"]
44 (ReqArg OptOutput "FILE")
47 , Option ['m'] ["module"]
48 (ReqArg OptModName "MODULE")
49 "Specify the resulting module name. (required)"
51 , Option ['s'] ["symbol"]
52 (ReqArg OptSymName "SYMBOL")
53 "Specify the resulting symbol name."
55 , Option ['t'] ["mime-type"]
56 (ReqArg OptMIMEType "TYPE")
57 "Specify the MIME Type of the file."
59 , Option ['e'] ["etag"]
60 (ReqArg OptETag "TAG")
61 "Specify the ETag of the file."
63 , Option ['h'] ["help"]
69 printUsage = do mapM_ putStrLn msg
70 putStr $ usageInfo "Options:" options
75 , concat [ " lucu-implant-file is an utility that generates "
76 , "Haskell code containing an arbitrary file to "
77 , "compile it directly into programs and serve it "
78 , "statically with the Lucu HTTP server."
82 , " lucu-implant-file [OPTIONS...] FILE"
87 main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
90 $ do mapM_ putStr errors
91 exitWith $ ExitFailure 1
93 when (any (≡ OptHelp) opts)
99 exitWith $ ExitFailure 1
101 when (length sources ≥ 2)
102 $ error "too many input files."
104 generateHaskellSource opts (head sources)
106 generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
107 generateHaskellSource opts srcFile
108 = do modName ← getModuleName opts
109 symName ← getSymbolName opts modName
110 mimeType ← getMIMEType opts srcFile
111 lastMod ← getLastModified srcFile
112 input ← openInput srcFile
113 output ← openOutput opts
114 eTag ← getETag opts input
116 let compParams = defaultCompressParams { compressLevel = bestCompression }
117 gzippedData = compressWith compParams input
118 originalLen = Lazy.length input
119 gzippedLen = Lazy.length gzippedData
120 useGZip = originalLen > gzippedLen
121 rawB64 = B64.encode <$> Lazy.toChunks input
122 gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData
124 header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
126 let hsModule = mkModule (ModuleName modName) (name symName) imports decls
127 imports = mkImports useGZip
128 decls = concat [ declResourceDef
130 , lastModifiedDecl lastMod
131 , contentTypeDecl mimeType
133 dataDecl (name "gzippedData") gzippedB64
135 dataDecl (name "rawData") rawB64
138 = [ HsTypeSig (⊥) [HsIdent symName]
140 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
141 , HsFunBind [HsMatch (⊥) (HsIdent symName)
142 [] (HsUnGuardedRhs defResourceDef) []]
145 defResourceDef ∷ HsExp
147 = let defResGet = if useGZip
148 then defResGetGZipped
151 (HsRecConstr (UnQual (HsIdent "ResourceDef"))
152 [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
153 (HsCon (UnQual (HsIdent "False")))
154 , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
155 (HsCon (UnQual (HsIdent "False")))
156 , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
157 , HsFieldUpdate (UnQual (HsIdent "resHead"))
158 (HsCon (UnQual (HsIdent "Nothing")))
159 , HsFieldUpdate (UnQual (HsIdent "resPost"))
160 (HsCon (UnQual (HsIdent "Nothing")))
161 , HsFieldUpdate (UnQual (HsIdent "resPut"))
162 (HsCon (UnQual (HsIdent "Nothing")))
163 , HsFieldUpdate (UnQual (HsIdent "resDelete"))
164 (HsCon (UnQual (HsIdent "Nothing")))
168 defResGetGZipped ∷ HsExp
170 = let doExp = HsDo [ foundEntityStmt
173 , doConditionalOutput
177 (HsPVar (HsIdent "mustGunzip"))
178 (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
179 (HsVar (UnQual (HsIdent "not"))))
181 (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
182 (HsLit (HsString "gzip")))))
185 (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
189 = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
191 (HsApp (HsVar (UnQual (HsIdent "decompress")))
192 (HsVar (UnQual (HsIdent "gzippedData"))))))
194 = HsDo [ setContentEncodingGZipStmt
195 , outputStmt (var $ name "gzippedData")
198 HsApp (HsCon (UnQual (HsIdent "Just")))
201 hPutStrLn output header
202 hPutStrLn output (prettyPrint hsModule)
205 mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
206 mkModule modName symName imports decls
207 = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
210 exports = [ EVar (UnQual symName)
213 Module (⊥) modName modPragma Nothing (Just exports) imports decls
215 mkImports ∷ Bool → [ImportDecl]
217 = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
218 True False (Just (ModuleName "B64")) Nothing
219 , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
220 True False (Just (ModuleName "Lazy")) Nothing
221 , ImportDecl (⊥) (ModuleName "Data.Time")
222 False False Nothing Nothing
223 , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
224 False False Nothing Nothing
228 [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
229 False False Nothing Nothing
236 = infixApp (var $ name "Just")
238 (doE [ foundEntityStmt
244 = infixApp (var $ name "Just")
246 (doE [ foundEntityStmt
248 , outputStmt (var $ name "rawData")
251 setContentEncodingGZipStmt ∷ Stmt
252 setContentEncodingGZipStmt
254 metaFunction "setContentEncoding" $
255 [ listE [ strE "gzip" ] ]
257 foundEntityStmt ∷ Stmt
260 metaFunction "foundEntity" $
261 [ var $ name "entityTag"
262 , var $ name "lastModified"
265 setContentTypeStmt ∷ Stmt
268 metaFunction "setContentType" $
269 [var $ name "contentType"]
271 outputStmt ∷ Exp → Stmt
274 metaFunction "output" [e]
276 entityTagDecl ∷ ETag → [Decl]
278 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
279 , nameBind (⊥) varName valExp
283 varName = name "entityTag"
286 valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
288 eTagToString ∷ ETag → String
289 eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
291 lastModifiedDecl ∷ UTCTime → [Decl]
292 lastModifiedDecl lastMod
293 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
294 , nameBind (⊥) varName valExp
298 varName = name "lastModified"
301 valExp = metaFunction "read" [strE $ show lastMod]
303 contentTypeDecl ∷ MIMEType → [Decl]
305 = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
306 , nameBind (⊥) varName valExp
310 varName = name "contentType"
313 valExp = metaFunction "parseMIMEType" [mimeToString mime]
315 mimeToString ∷ MIMEType → String
316 mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
318 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
319 dataDecl varName chunks
320 = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
321 , nameBind (⊥) varName valExp
325 valExp = qvar (ModuleName "Lazy") (name "fromChunks")
327 listE (chunkToExp <$> chunks)
329 chunkToExp ∷ Strict.ByteString → Exp
331 = qvar (ModuleName "B64") (name "decodeLenient")
333 strE (Strict.unpack chunk)
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 = case mimeTypeOpts of
390 [] → return defaultType
391 (OptMIMEType ty):[] → return $ read ty
392 _ → error "too many --mime-type options."
394 mimeTypeOpts ∷ [CmdOpt]
396 = filter (\ x → case x of
400 octetStream ∷ MIMEType
401 octetStream = parseMIMEType "application/octet-stream"
403 defaultType ∷ MIMEType
404 defaultType = fromMaybe octetStream
405 $ guessTypeByFileName defaultExtensionMap srcFile
408 getLastModified ∷ FilePath → IO UTCTime
409 getLastModified "-" = getCurrentTime
410 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
415 getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
417 = let eTagOpts = filter (\ x → case x of
422 [] → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
423 (OptETag str):[] → return str
424 _ → error "too many --etag options."
426 mkETagFromInput ∷ Digest → String
427 mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
429 toHex ∷ String → String
430 toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
432 hexByte ∷ Int → String
434 = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
435 , hex4bit ( n .&. 0x0F)
440 | n < 10 = chr $ ord '0' + n
441 | n < 16 = chr $ ord 'a' + n - 10
445 openInput ∷ FilePath → IO Lazy.ByteString
446 openInput "-" = Lazy.getContents
447 openInput fpath = Lazy.readFile fpath
450 openOutput ∷ [CmdOpt] → IO Handle
452 = let outputOpts = filter (\ x → case x of
458 (OptOutput fpath):[] → openFile fpath WriteMode
459 _ → error "two many --output options."
462 作られるファイルの例 (壓縮されない場合):
463 ------------------------------------------------------------------------------
464 {- DO NOT EDIT THIS FILE.
465 This file is automatically generated by the lucu-implant-file program.
468 Original Length: 302 bytes
469 Compressed Length: 453 bytes -- これは Compression: disabled の時には無い
470 Compression: disabled
472 ETag: d41d8cd98f00b204e9800998ecf8427e
473 Last Modified: 2007-11-05 13:53:42.231882 JST
475 {-# LANGUAGE OverloadedStrings #-}
476 module Foo.Bar.Baz (baz) where
477 import qualified Data.ByteString.Base64 as B64
478 import qualified Data.ByteString.Lazy as Lazy
480 import Network.HTTP.Lucu
484 resUsesNativeThread = False
485 , resIsGreedy = False
487 = Just $ do foundEntity entityTag lastModified
488 setContentType contentType
491 = Just $ do foundEntity entityTag lastModified
492 setContentType contentType
495 , resDelete = Nothing
499 entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
501 lastModified ∷ UTCTime
502 lastModified = read "2007-11-05 04:47:56.008366 UTC"
504 contentType ∷ MIMEType
505 contentType = parseMIMEType "image/png"
507 rawData ∷ Lazy.ByteString
508 rawData = Lazy.fromChunks
509 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
510 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
512 ------------------------------------------------------------------------------
515 ------------------------------------------------------------------------------
517 import Codec.Compression.GZip
519 -- ResourceDef は次のやうに變化
522 resUsesNativeThread = False
523 , resIsGreedy = False
525 = Just $ do foundEntity entityTag lastModified
526 setContentType contentType
528 gzip ← isEncodingAcceptable "gzip"
530 do setContentEncoding ["gzip"]
533 output (decompress gzippedData)
535 = Just $ do foundEntity entityTag lastModified
536 setContentType contentType
539 , resDelete = Nothing
542 -- rawData の代はりに gzippedData
543 gzippedData ∷ Lazy.ByteString
544 gzippedData = Lazy.fromChunks
545 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
546 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
548 ------------------------------------------------------------------------------