]> gitweb @ CieloNegro.org - Lucu.git/blob - ImplantFile.hs
updates for new Crypto and dataenc package
[Lucu.git] / ImplantFile.hs
1 import           Codec.Binary.Base64
2 import           Codec.Compression.GZip
3 import           Control.Monad
4 import           Data.Bits
5 import qualified Data.ByteString.Lazy as Lazy (ByteString)
6 import qualified Data.ByteString.Lazy as L hiding (ByteString)
7 import           Data.Char
8 import           Data.Digest.SHA2
9 import           Data.Int
10 import           Data.Maybe
11 import           Data.Time
12 import           Data.Time.Clock.POSIX
13 import           Data.Word
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
21 import           System.Exit
22 import           System.Posix.Files
23 import           System.IO
24
25 data CmdOpt
26     = OptOutput FilePath
27     | OptModName String
28     | OptSymName String
29     | OptMIMEType String
30     | OptETag String
31     | OptHelp
32     deriving (Eq, Show)
33
34
35 options :: [OptDescr CmdOpt]
36 options = [ Option ['o'] ["output"]
37                        (ReqArg OptOutput "FILE")
38                        "Output to the FILE."
39
40           , Option ['m'] ["module"]
41                        (ReqArg OptModName "MODULE")
42                        "Specify the resulting module name. (required)"
43
44           , Option ['s'] ["symbol"]
45                        (ReqArg OptSymName "SYMBOL")
46                        "Specify the resulting symbol name."
47
48           , Option ['t'] ["mime-type"]
49                        (ReqArg OptMIMEType "TYPE")
50                        "Specify the MIME Type of the file."
51
52           , Option ['e'] ["etag"]
53                        (ReqArg OptETag "TAG")
54                        "Specify the ETag of the file."
55
56           , Option ['h'] ["help"]
57                        (NoArg OptHelp)
58                        "Print this message."
59           ]
60
61
62 printUsage :: IO ()
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.")
69                 putStrLn ""
70                 putStrLn "Usage:"
71                 putStrLn "  lucu-implant-file [OPTIONS...] FILE"
72                 putStrLn ""
73                 putStr $ usageInfo "Options:" options
74                 putStrLn ""
75
76
77 main :: IO ()
78 main = do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
79
80           when (not $ null errors)
81                    $ do mapM_ putStr errors
82                         exitWith $ ExitFailure 1
83
84           when (any (\ x -> x == OptHelp) opts)
85                    $ do printUsage
86                         exitWith ExitSuccess
87
88           when (null sources)
89                    $ do printUsage
90                         exitWith $ ExitFailure 1
91
92           when (length sources >= 2)
93                    $ error "too many input files."
94
95           generateHaskellSource opts (head sources)
96
97
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
107
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
114
115          header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
116              
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.Time")
124                                        False Nothing Nothing
125                         , HsImportDecl undefined (Module "Network.HTTP.Lucu")
126                                        False Nothing Nothing
127                         ]
128                         ++
129                         (if useGZip then
130                              [ HsImportDecl undefined (Module "Control.Monad")
131                                             False Nothing Nothing
132                              , HsImportDecl undefined (Module "Codec.Compression.GZip")
133                                             False Nothing Nothing
134                              ]
135                          else
136                              [])
137              decls    = declResourceDef
138                         ++
139                         declEntityTag
140                         ++
141                         declLastModified
142                         ++
143                         declContentType
144                         ++
145                         (if useGZip
146                          then declGZippedData
147                          else declRawData)
148
149              declResourceDef :: [HsDecl]
150              declResourceDef
151                  = [ HsTypeSig undefined [HsIdent symName]
152                                (HsQualType []
153                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
154                    , HsFunBind [HsMatch undefined (HsIdent symName)
155                                 [] (HsUnGuardedRhs defResourceDef) []]
156                    ]
157
158              defResourceDef :: HsExp
159              defResourceDef 
160                  = let defResGet = if useGZip
161                                    then defResGetGZipped
162                                    else defResGetRaw
163                    in 
164                      (HsRecConstr (UnQual (HsIdent "ResourceDef"))
165                       [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
166                                       (HsCon (UnQual (HsIdent "False")))
167                       , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
168                                       (HsCon (UnQual (HsIdent "False")))
169                       , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
170                       , HsFieldUpdate (UnQual (HsIdent "resHead"))
171                                       (HsCon (UnQual (HsIdent "Nothing")))
172                       , HsFieldUpdate (UnQual (HsIdent "resPost"))
173                                       (HsCon (UnQual (HsIdent "Nothing")))
174                       , HsFieldUpdate (UnQual (HsIdent "resPut"))
175                                       (HsCon (UnQual (HsIdent "Nothing")))
176                       , HsFieldUpdate (UnQual (HsIdent "resDelete"))
177                                       (HsCon (UnQual (HsIdent "Nothing")))
178                       ]
179                      )
180
181              defResGetGZipped :: HsExp
182              defResGetGZipped
183                  = let doExp = HsDo [ doFoundEntity
184                                     , doSetContentType
185                                     , bindMustGunzip
186                                     , doConditionalOutput
187                                     ]
188                        doFoundEntity
189                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
190                                                  (HsVar (UnQual (HsIdent "entityTag"))))
191                                           (HsVar (UnQual (HsIdent "lastModified"))))
192                        doSetContentType
193                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
194                                           (HsVar (UnQual (HsIdent "contentType"))))
195                        bindMustGunzip
196                            = HsGenerator undefined
197                              (HsPVar (HsIdent "mustGunzip"))
198                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
199                                      (HsVar (UnQual (HsIdent "not"))))
200                               (HsParen
201                                (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
202                                       (HsLit (HsString "gzip")))))
203                        doConditionalOutput
204                            = HsQualifier
205                              (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
206                                    expOutputGunzipped
207                                    expOutputGZipped)
208                        expOutputGunzipped
209                            = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
210                               (HsParen
211                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
212                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
213                        expOutputGZipped
214                            = HsDo [ doSetContentEncodingGZip
215                                   , doOutputGZipped
216                                   ]
217                        doSetContentEncodingGZip
218                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
219                                           (HsList [HsLit (HsString "gzip")]))
220                        doOutputGZipped
221                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
222                                           (HsVar (UnQual (HsIdent "gzippedData"))))
223                    in 
224                      HsApp (HsCon (UnQual (HsIdent "Just")))
225                            (HsParen doExp)
226
227              defResGetRaw :: HsExp
228              defResGetRaw
229                  = let doExp = HsDo [ doFoundEntity
230                                     , doSetContentType
231                                     , doOutputRawData
232                                     ]
233                        doFoundEntity
234                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
235                                                  (HsVar (UnQual (HsIdent "entityTag"))))
236                                           (HsVar (UnQual (HsIdent "lastModified"))))
237                        doSetContentType
238                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
239                                           (HsVar (UnQual (HsIdent "contentType"))))
240                        doOutputRawData
241                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
242                                           (HsVar (UnQual (HsIdent "rawData"))))
243                    in
244                      HsApp (HsCon (UnQual (HsIdent "Just")))
245                            (HsParen doExp)
246
247              declEntityTag :: [HsDecl]
248              declEntityTag
249                  = [ HsTypeSig undefined [HsIdent "entityTag"]
250                                (HsQualType []
251                                 (HsTyCon (UnQual (HsIdent "ETag"))))
252                    , HsFunBind [HsMatch undefined (HsIdent "entityTag")
253                                 [] (HsUnGuardedRhs defEntityTag) []]
254                    ]
255
256              defEntityTag :: HsExp
257              defEntityTag
258                  = HsApp (HsVar (UnQual (HsIdent "strongETag")))
259                    (HsLit (HsString eTag))
260
261              declLastModified :: [HsDecl]
262              declLastModified
263                  = [ HsTypeSig undefined [HsIdent "lastModified"]
264                                (HsQualType []
265                                 (HsTyCon (UnQual (HsIdent "UTCTime"))))
266                    , HsFunBind [HsMatch undefined (HsIdent "lastModified")
267                                 [] (HsUnGuardedRhs defLastModified) []]
268                    ]
269
270              defLastModified :: HsExp
271              defLastModified 
272                  = HsApp (HsVar (UnQual (HsIdent "read")))
273                    (HsLit (HsString $ show lastMod))
274                             
275
276              declContentType :: [HsDecl]
277              declContentType 
278                  = [ HsTypeSig undefined [HsIdent "contentType"]
279                                (HsQualType []
280                                 (HsTyCon (UnQual (HsIdent "MIMEType"))))
281                    , HsFunBind [HsMatch undefined (HsIdent "contentType")
282                                 [] (HsUnGuardedRhs defContentType) []]
283                    ]
284
285              defContentType :: HsExp
286              defContentType
287                  = HsApp (HsVar (UnQual (HsIdent "read")))
288                    (HsLit (HsString $ show mimeType))
289
290              declGZippedData :: [HsDecl]
291              declGZippedData 
292                  = [ HsTypeSig undefined [HsIdent "gzippedData"]
293                                (HsQualType []
294                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
295                    , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
296                                 [] (HsUnGuardedRhs defGZippedData) []]
297                    ]
298
299              defGZippedData :: HsExp
300              defGZippedData 
301                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
302                    (HsParen
303                     (HsApp (HsVar (UnQual (HsIdent "decode")))
304                      (HsLit (HsString gzippedB64))))
305
306              declRawData :: [HsDecl]
307              declRawData 
308                  = [ HsTypeSig undefined [HsIdent "rawData"]
309                                (HsQualType []
310                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
311                    , HsFunBind [HsMatch undefined (HsIdent "rawData")
312                                 [] (HsUnGuardedRhs defRawData) []]
313                    ]
314
315              defRawData :: HsExp
316              defRawData
317                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
318                    (HsParen
319                     (HsApp (HsVar (UnQual (HsIdent "decode")))
320                      (HsLit (HsString rawB64))))
321
322          hPutStrLn output header
323          hPutStrLn output (prettyPrint hsModule)
324          hClose output
325
326
327 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
328 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
329     = do localLastMod <- utcToLocalZonedTime lastMod
330          return ("{- DO NOT EDIT THIS FILE.\n" ++
331                  "   This file is automatically generated by the lucu-implant-file program.\n" ++
332                  "\n" ++
333                  "              Source: " ++ (if srcFile == "-"
334                                               then "(stdin)"
335                                               else srcFile) ++ "\n" ++
336                  "     Original Length: " ++ show originalLen ++ " bytes\n" ++
337                  (if useGZip
338                   then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
339                        "         Compression: gzip\n"
340                   else "         Compression: disabled\n") ++
341                  "           MIME Type: " ++ show mimeType ++ "\n" ++
342                  "                ETag: " ++ eTag ++ "\n" ++
343                  "       Last Modified: " ++ show localLastMod ++ "\n" ++
344                  " -}")
345
346
347 getModuleName :: [CmdOpt] -> IO String
348 getModuleName opts
349     = let modNameOpts = filter (\ x -> case x of
350                                          OptModName _ -> True
351                                          _            -> False) opts
352       in
353         case modNameOpts of
354           []                      -> error "a module name must be given."
355           (OptModName modName):[] -> return modName
356           _                       -> error "too many --module options."
357
358
359 getSymbolName :: [CmdOpt] -> String -> IO String
360 getSymbolName opts modName
361     = let symNameOpts    = filter (\ x -> case x of
362                                             OptSymName _ -> True
363                                             _            -> False) opts
364           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
365           -- 小文字にしたものを使ふ。
366           defaultSymName = mkDefault modName
367           mkDefault      = headToLower . getLastComp
368           headToLower    = \ str -> case str of
369                                       []     -> error "module name must not be empty"
370                                       (x:xs) -> toLower x : xs
371           getLastComp    = reverse . fst . break (== '.') . reverse
372       in
373         case symNameOpts of
374           []                      -> return defaultSymName
375           (OptSymName symName):[] -> return symName
376           _                       -> error "too many --symbol options."
377
378
379 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
380 getMIMEType opts srcFile
381     = let mimeTypeOpts = filter (\ x -> case x of
382                                           OptMIMEType _ -> True
383                                           _             -> False) opts
384           defaultType  = fromMaybe (read "application/octet-stream")
385                          $ guessTypeByFileName defaultExtensionMap srcFile
386       in
387         case mimeTypeOpts of
388           []                        -> return defaultType
389           (OptMIMEType mimeType):[] -> return $ read mimeType
390           _                         -> error "too many --mime-type options."
391
392
393 getLastModified :: FilePath -> IO UTCTime
394 getLastModified "-"   = getCurrentTime
395 getLastModified fpath = getFileStatus fpath
396                         >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
397
398
399 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
400 getETag opts input
401     = let eTagOpts = filter (\ x -> case x of
402                                       OptETag _ -> True
403                                       _         -> False) opts
404       in
405         case eTagOpts of
406           []               -> return mkETagFromInput
407           (OptETag str):[] -> return str
408           _                -> error "too many --etag options."
409     where
410       mkETagFromInput :: String
411       mkETagFromInput = "SHA-1:" ++ (toHex $ toOctets $ sha256 $ L.unpack input)
412
413       toHex :: [Word8] -> String
414       toHex []     = ""
415       toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs
416
417       hexByte :: Int -> String
418       hexByte n
419           = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
420
421       hex4bit :: Int -> Char
422       hex4bit n
423           | n < 10    = (chr $ ord '0' + n     )
424           | n < 16    = (chr $ ord 'a' + n - 10)
425           | otherwise = undefined
426
427
428 openInput :: FilePath -> IO Lazy.ByteString
429 openInput "-"   = L.getContents
430 openInput fpath = L.readFile fpath
431
432
433 openOutput :: [CmdOpt] -> IO Handle
434 openOutput opts
435     = let outputOpts = filter (\ x -> case x of
436                                         OptOutput _ -> True
437                                         _           -> False) opts
438       in
439         case outputOpts of
440           []                   -> return stdout
441           (OptOutput fpath):[] -> openFile fpath WriteMode
442           _                    -> error "two many --output options."
443
444
445 {-
446   作られるファイルの例 (壓縮されない場合):
447   ------------------------------------------------------------------------------
448   {- DO NOT EDIT THIS FILE.
449      This file is automatically generated by the lucu-implant-file program.
450      
451                 Source: baz.png
452        Original Length: 302 bytes
453      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
454            Compression: disabled
455              MIME Type: image/png
456                   ETag: d41d8cd98f00b204e9800998ecf8427e
457          Last Modified: 2007-11-05 13:53:42.231882 JST
458    -}
459   module Foo.Bar.Baz (baz) where
460   import Codec.Binary.Base64
461   import qualified Data.ByteString.Lazy as L
462   import Data.Time
463   import Network.HTTP.Lucu
464
465   baz :: ResourceDef
466   baz = ResourceDef {
467           resUsesNativeThread = False
468         , resIsGreedy         = False
469         , resGet
470             = Just (do foundEntity entityTag lastModified
471                        setContentType contentType
472                        outputLBS rawData)
473         , resHead   = Nothing
474         , resPost   = Nothing
475         , resPut    = Nothing
476         , resDelete = Nothing
477         }
478
479   entityTag :: ETag
480   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
481
482   lastModified :: UTCTime
483   lastModified = read "2007-11-05 04:47:56.008366 UTC"
484
485   contentType :: MIMEType
486   contentType = read "image/png"
487
488   rawData :: L.ByteString
489   rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")
490   ------------------------------------------------------------------------------
491
492   壓縮される場合は次のやうに變はる:
493   ------------------------------------------------------------------------------
494   -- import に追加
495   import Control.Monad
496   import Codec.Compression.GZip
497
498   -- ResourceDef は次のやうに變化
499   baz :: ResourceDef
500   baz = ResourceDef {
501           resUsesNativeThread = False
502         , resIsGreedy         = False
503         , resGet
504             = Just (do foundEntity entityTag lastModified
505                        setContentType contentType
506
507                        mustGunzip <- liftM not (isEncodingAcceptable "gzip")
508                        if mustGunzip then
509                            outputLBS (decompress gzippedData)
510                          else
511                            do setContentEncoding ["gzip"]
512                               outputLBS gzippedData
513         , resHead   = Nothing
514         , resPost   = Nothing
515         , resPut    = Nothing
516         , resDelete = Nothing
517         }
518   
519   -- rawData の代はりに gzippedData
520   gzippedData :: L.ByteString
521   gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")
522   ------------------------------------------------------------------------------
523  -}