]> gitweb @ CieloNegro.org - Lucu.git/blob - ImplantFile.hs
c253c2abd05395b3311dba1fd9d3ed999d37d89b
[Lucu.git] / ImplantFile.hs
1 {-# LANGUAGE
2     OverloadedStrings
3   , UnicodeSyntax
4   #-}
5 module Main where
6 import Codec.Compression.GZip
7 import Control.Applicative
8 import Control.Monad
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
13 import Data.Char
14 import Data.Digest.Pure.SHA
15 import Data.Int
16 import Data.Maybe
17 import Data.Time
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
30 import System.Exit
31 import System.Posix.Files
32 import System.IO
33
34 data CmdOpt
35     = OptOutput FilePath
36     | OptModName String
37     | OptSymName String
38     | OptMIMEType String
39     | OptETag String
40     | OptHelp
41     deriving (Eq, Show)
42
43 options ∷ [OptDescr CmdOpt]
44 options = [ Option "o" ["output"]
45                        (ReqArg OptOutput "FILE")
46                        "Output to the FILE."
47
48           , Option "m" ["module"]
49                        (ReqArg OptModName "MODULE")
50                        "Specify the resulting module name. (required)"
51
52           , Option "s" ["symbol"]
53                        (ReqArg OptSymName "SYMBOL")
54                        "Specify the resulting symbol name."
55
56           , Option "t" ["mime-type"]
57                        (ReqArg OptMIMEType "TYPE")
58                        "Specify the MIME Type of the file."
59
60           , Option "e" ["etag"]
61                        (ReqArg OptETag "TAG")
62                        "Specify the ETag of the file."
63
64           , Option "h" ["help"]
65                        (NoArg OptHelp)
66                        "Print this message."
67           ]
68
69 printUsage ∷ IO ()
70 printUsage = do mapM_ putStrLn msg
71                 putStr $ usageInfo "Options:" options
72                 putStrLn ""
73     where
74       msg = [ ""
75             , "Description:"
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."
80                      ]
81             , ""
82             , "Usage:"
83             , "  lucu-implant-file [OPTIONS...] FILE"
84             , ""
85             ]
86
87 main ∷ IO ()
88 main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
89
90           unless (null errors)
91               $ do mapM_ putStr errors
92                    exitWith $ ExitFailure 1
93
94           when (any (≡ OptHelp) opts)
95               $ do printUsage
96                    exitWith ExitSuccess
97
98           when (null sources)
99                $ do printUsage
100                     exitWith $ ExitFailure 1
101
102           when (length sources ≥ 2)
103                $ fail "too many input files."
104
105           generateHaskellSource opts (head sources)
106
107 generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
108 generateHaskellSource opts srcFile
109     = do modName ← getModuleName opts
110          symName ← getSymbolName opts modName
111          mType   ← getMIMEType opts srcFile
112          lastMod ← getLastModified srcFile
113          input   ← openInput srcFile
114          output  ← openOutput opts
115          tag     ← getETag opts input
116
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
124
125          header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod
126
127          let hsModule = mkModule modName symName imports decls
128              imports  = mkImports useGZip
129              decls    = concat [ resourceDecl symName useGZip
130                                , entityTagDecl tag
131                                , lastModifiedDecl lastMod
132                                , contentTypeDecl mType
133                                , if useGZip then
134                                      dataDecl (name "gzippedData") gzippedB64
135                                  else
136                                      dataDecl (name "rawData") rawB64
137                                ]
138
139          hPutStrLn output header
140          hPutStrLn output (prettyPrint hsModule)
141          hClose output
142
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) ]
147       in
148         Module (⊥) modName modPragma Nothing (Just exports) imports decls
149
150 mkImports ∷ Bool → [ImportDecl]
151 mkImports useGZip
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
160       ]
161       ⧺
162       [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
163                    False False Nothing Nothing Nothing
164         | useGZip ]
165
166 resourceDecl ∷ Name → Bool → [Decl]
167 resourceDecl symName useGZip
168     = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
169       , nameBind (⊥) symName valExp
170       ]
171     where
172       valExp ∷ Exp
173       valExp = RecUpdate (function "emptyResource")
174                [ FieldUpdate (UnQual (name "resGet" )) resGet
175                , FieldUpdate (UnQual (name "resHead")) resHead
176                ]
177
178       resGet ∷ Exp
179       resGet | useGZip   = resGetGZipped
180              | otherwise = resGetRaw
181
182 resHead ∷ Exp
183 resHead
184     = function "Just" `app`
185       paren (doE [ foundEntityStmt
186                  , setContentTypeStmt
187                  ])
188
189 resGetGZipped ∷ Exp
190 resGetGZipped
191     = function "Just" `app`
192       paren (doE [ foundEntityStmt
193                  , setContentTypeStmt
194                  , bindGZipStmt
195                  , conditionalOutputStmt
196                  ])
197     where
198       condVarName ∷ Name
199       condVarName = name "gzipAllowed"
200
201       dataVarName ∷ Name
202       dataVarName = name "gzippedData"
203
204       bindGZipStmt ∷ Stmt
205       bindGZipStmt
206           = genStmt (⊥)
207             (pvar condVarName)
208             (function "isEncodingAcceptable" `app` strE "gzip")
209
210       conditionalOutputStmt ∷ Stmt
211       conditionalOutputStmt
212           = qualStmt $
213             If (var condVarName)
214                (doE [ setContentEncodingGZipStmt
215                     , putChunksStmt (var dataVarName)
216                     ])
217                (putChunksExp
218                 (paren
219                  (function "decompress" `app` var dataVarName)))
220
221 resGetRaw ∷ Exp
222 resGetRaw
223     = function "Just" `app`
224       paren (doE [ foundEntityStmt
225                  , setContentTypeStmt
226                  , putChunksStmt (function "rawData")
227                  ])
228
229 setContentEncodingGZipStmt ∷ Stmt
230 setContentEncodingGZipStmt
231     = qualStmt
232       ( function "setContentEncoding"
233         `app`
234         listE [ strE "gzip" ]
235       )
236
237 foundEntityStmt ∷ Stmt
238 foundEntityStmt
239     = qualStmt $
240       metaFunction "foundEntity"
241                        [ var (name "entityTag")
242                        , var (name "lastModified")
243                        ]
244
245 setContentTypeStmt ∷ Stmt
246 setContentTypeStmt
247     = qualStmt
248       ( function "setContentType"
249         `app`
250         function "contentType"
251       )
252
253 putChunksExp ∷ Exp → Exp
254 putChunksExp = app (function "putChunks")
255
256 putChunksStmt ∷ Exp → Stmt
257 putChunksStmt = qualStmt ∘ putChunksExp
258
259 entityTagDecl ∷ ETag → [Decl]
260 entityTagDecl tag
261     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
262       , nameBind (⊥) varName valExp
263       ]
264     where
265       varName ∷ Name
266       varName = name "entityTag"
267
268       valExp ∷ Exp
269       valExp = function "parseETag" `app` strE (eTagToString tag)
270
271 lastModifiedDecl ∷ UTCTime → [Decl]
272 lastModifiedDecl lastMod
273     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
274       , nameBind (⊥) varName valExp
275       , InlineSig (⊥) False AlwaysActive (UnQual varName)
276       ]
277     where
278       varName ∷ Name
279       varName = name "lastModified"
280
281       valExp ∷ Exp
282       valExp = function "read" `app` strE (show lastMod)
283
284 contentTypeDecl ∷ MIMEType → [Decl]
285 contentTypeDecl mime
286     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
287       , nameBind (⊥) varName valExp
288       , InlineSig (⊥) False AlwaysActive (UnQual varName)
289       ]
290     where
291       varName ∷ Name
292       varName = name "contentType"
293
294       valExp ∷ Exp
295       valExp = function "parseMIMEType" `app` strE (mimeToString mime)
296
297       mimeToString ∷ MIMEType → String
298       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
299
300 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
301 dataDecl varName chunks
302     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
303       , nameBind (⊥) varName valExp
304       , InlineSig (⊥) False AlwaysActive (UnQual varName)
305       ]
306     where
307       valExp ∷ Exp
308       valExp = qvar (ModuleName "Lazy") (name "fromChunks")
309                `app`
310                listE (chunkToExp <$> chunks)
311
312       chunkToExp ∷ Strict.ByteString → Exp
313       chunkToExp chunk
314           = qvar (ModuleName "B64") (name "decodeLenient")
315             `app`
316             strE (Strict.unpack chunk)
317
318 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
319 mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod
320     = do localLastMod ← utcToLocalZonedTime lastMod
321          return $ concat
322                     [ "{- DO NOT EDIT THIS FILE.\n"
323                     , "   This file is automatically generated by the lucu-implant-file program.\n"
324                     , "\n"
325                     , "              Source: ", if srcFile ≡ "-" then
326                                                     "(stdin)"
327                                                 else
328                                                     srcFile
329                     , "\n"
330                     , "     Original Length: ", show originalLen, " bytes\n"
331                     , if useGZip then
332                           "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
333                           "         Compression: gzip\n"
334                       else
335                           "         Compression: disabled\n"
336                     , "           MIME Type: ", mimeTypeToString mType, "\n"
337                     , "                ETag: ", eTagToString tag, "\n"
338                     , "       Last Modified: ", show localLastMod, "\n"
339                     , " -}"
340                     ]
341
342 eTagToString ∷ ETag → String
343 eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
344
345 mimeTypeToString ∷ MIMEType → String
346 mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
347
348 getModuleName ∷ [CmdOpt] → IO ModuleName
349 getModuleName opts
350     = case modNameOpts of
351         []                    → fail "a module name must be given."
352         OptModName modName:[] → return $ ModuleName modName
353         _                     → fail "too many --module options."
354     where
355       modNameOpts ∷ [CmdOpt]
356       modNameOpts = filter (\ x → case x of
357                                      OptModName _ → True
358                                      _            → False) opts
359
360 getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
361 getSymbolName opts (ModuleName modName)
362     = case symNameOpts of
363         []                    → return defaultSymName
364         OptSymName symName:[] → return $ name symName
365         _                     → fail "too many --symbol options."
366     where
367       symNameOpts ∷ [CmdOpt]
368       symNameOpts = filter (\ x → case x of
369                                      OptSymName _ → True
370                                      _            → False) opts
371
372       defaultSymName ∷ Name
373       defaultSymName
374           = name $ headToLower $ getLastComp modName
375
376       headToLower ∷ String → String
377       headToLower []     = error "module name must not be empty"
378       headToLower (x:xs) = toLower x : xs
379
380       getLastComp ∷ String → String
381       getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
382
383 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
384 getMIMEType opts srcFile
385     = case mimeTypeOpts of
386         []  → return defaultType
387         OptMIMEType ty:[]
388             → case A.fromChars ty of
389                  Just a  → return $ parseMIMEType a
390                  Nothing → fail "MIME type must not contain any non-ASCII letters."
391         _   → fail "too many --mime-type options."
392     where
393       mimeTypeOpts ∷ [CmdOpt]
394       mimeTypeOpts
395           = filter (\ x → case x of
396                              OptMIMEType _ → True
397                              _             → False) opts
398
399       octetStream ∷ MIMEType
400       octetStream = parseMIMEType "application/octet-stream"
401
402       defaultType ∷ MIMEType
403       defaultType = fromMaybe octetStream
404                     $ guessTypeByFileName defaultExtensionMap srcFile
405
406 getLastModified ∷ FilePath → IO UTCTime
407 getLastModified "-"   = getCurrentTime
408 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
409                         <$>
410                         getFileStatus fpath
411
412 getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
413 getETag opts input
414     = case eTagOpts of
415         []             → return mkETagFromInput
416         OptETag str:[] → return $ strToETag str
417         _              → fail "too many --etag options."
418     where
419       eTagOpts ∷ [CmdOpt]
420       eTagOpts = filter (\ x → case x of
421                                   OptETag _ → True
422                                   _         → False) opts
423
424       mkETagFromInput ∷ ETag
425       mkETagFromInput
426           = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
427
428       strToETag ∷ String → ETag
429       strToETag str
430           = case A.fromChars str of
431               Just a  → strongETag a
432               Nothing → error "ETag must not contain any non-ASCII letters."
433
434 openInput ∷ FilePath → IO Lazy.ByteString
435 openInput "-"   = Lazy.getContents
436 openInput fpath = Lazy.readFile fpath
437
438 openOutput ∷ [CmdOpt] → IO Handle
439 openOutput opts
440     = case outputOpts of
441         []                 → return stdout
442         OptOutput fpath:[] → openFile fpath WriteMode
443         _                  → fail "two many --output options."
444     where
445       outputOpts ∷ [CmdOpt]
446       outputOpts = filter (\ x → case x of
447                                     OptOutput _ → True
448                                     _           → False) opts
449
450 {-
451   作られるファイルの例 (壓縮されない場合):
452   ------------------------------------------------------------------------------
453   {- DO NOT EDIT THIS FILE.
454      This file is automatically generated by the lucu-implant-file program.
455      
456                 Source: baz.png
457        Original Length: 302 bytes
458      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
459            Compression: disabled
460              MIME Type: image/png
461                   ETag: "d41d8cd98f00b204e9800998ecf8427e"
462          Last Modified: 2007-11-05 13:53:42.231882 JST
463    -}
464   {-# LANGUAGE OverloadedStrings #-}
465   module Foo.Bar.Baz (baz) where
466   import qualified Data.ByteString.Base64 as B64
467   import qualified Data.ByteString.Lazy as Lazy
468   import Data.Time
469   import Network.HTTP.Lucu
470
471   baz ∷ ResourceDef
472   baz = ResourceDef {
473           resUsesNativeThread = False
474         , resIsGreedy         = False
475         , resGet
476             = Just $ do foundEntity entityTag lastModified
477                         setContentType contentType
478                         putChunk rawData
479         , resHead
480             = Just $ do foundEntity entityTag lastModified
481                         setContentType contentType
482         , resPost   = Nothing
483         , resPut    = Nothing
484         , resDelete = Nothing
485         }
486
487   entityTag ∷ ETag
488   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
489
490   lastModified ∷ UTCTime
491   {-# NOINLINE lastModified #-}
492   lastModified = read "2007-11-05 04:47:56.008366 UTC"
493
494   contentType ∷ MIMEType
495   {-# NOINLINE contentType #-}
496   contentType = parseMIMEType "image/png"
497
498   rawData ∷ Lazy.ByteString
499   {-# NOINLINE rawData #-}
500   rawData = Lazy.fromChunks
501             [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
502             , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
503             ]
504   ------------------------------------------------------------------------------
505
506   壓縮される場合は次のやうに變はる:
507   ------------------------------------------------------------------------------
508   -- import に追加
509   import Codec.Compression.Zlib
510
511   -- ResourceDef は次のやうに變化
512   baz ∷ ResourceDef
513   baz = ResourceDef {
514           resUsesNativeThread = False
515         , resIsGreedy         = False
516         , resGet
517             = Just $ do foundEntity entityTag lastModified
518                         setContentType contentType
519
520                         gzipAllowed ← isEncodingAcceptable "gzip"
521                         if gzipAllowed then
522                             do setContentEncoding ["gzip"]
523                                putChunks gzippedData
524                         else
525                             putChunks (decompress gzippedData)
526         , resHead
527             = Just $ do foundEntity entityTag lastModified
528                         setContentType contentType
529         , resPost   = Nothing
530         , resPut    = Nothing
531         , resDelete = Nothing
532         }
533
534   -- rawData の代はりに gzippedData
535   gzippedData ∷ Lazy.ByteString
536   {-# NOINLINE gzippedData #-}
537   gzippedData = Lazy.fromChunks
538                 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
539                 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
540                 ]
541   ------------------------------------------------------------------------------
542  -}