ImplantFile.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 module Main where
   5 import Codec.Compression.GZip
   6 import Control.Applicative
   7 import Control.Monad
   8 import qualified Data.Ascii as A
   9 import Data.Bits
  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.Int
  15 import Data.Maybe
  16 import Data.Time
  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
  29 import System.Exit
  30 import System.Posix.Files
  31 import System.IO
  32
  33 data CmdOpt
  34     = OptOutput FilePath
  35     | OptModName String
  36     | OptSymName String
  37     | OptMIMEType String
  38     | OptETag String
  39     | OptHelp
  40     deriving (Eq, Show)
  41
  42 options ∷ [OptDescr CmdOpt]
  43 options = [ Option ['o'] ["output"]
  44                        (ReqArg OptOutput "FILE")
  45                        "Output to the FILE."
  46
  47           , Option ['m'] ["module"]
  48                        (ReqArg OptModName "MODULE")
  49                        "Specify the resulting module name. (required)"
  50
  51           , Option ['s'] ["symbol"]
  52                        (ReqArg OptSymName "SYMBOL")
  53                        "Specify the resulting symbol name."
  54
  55           , Option ['t'] ["mime-type"]
  56                        (ReqArg OptMIMEType "TYPE")
  57                        "Specify the MIME Type of the file."
  58
  59           , Option ['e'] ["etag"]
  60                        (ReqArg OptETag "TAG")
  61                        "Specify the ETag of the file."
  62
  63           , Option ['h'] ["help"]
  64                        (NoArg OptHelp)
  65                        "Print this message."
  66           ]
  67
  68 printUsage ∷ IO ()
  69 printUsage = do mapM_ putStrLn msg
  70                 putStr $ usageInfo "Options:" options
  71                 putStrLn ""
  72     where
  73       msg = [ ""
  74             , "Description:"
  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."
  79                      ]
  80             , ""
  81             , "Usage:"
  82             , "  lucu-implant-file [OPTIONS...] FILE"
  83             , ""
  84             ]
  85
  86 main ∷ IO ()
  87 main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
  88
  89           unless (null errors)
  90               $ do mapM_ putStr errors
  91                    exitWith $ ExitFailure 1
  92
  93           when (any (≡ OptHelp) opts)
  94               $ do printUsage
  95                    exitWith ExitSuccess
  96
  97           when (null sources)
  98                $ do printUsage
  99                     exitWith $ ExitFailure 1
 100
 101           when (length sources ≥ 2)
 102                $ error "too many input files."
 103
 104           generateHaskellSource opts (head sources)
 105
 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
 115
 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
 123
 124          header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 125
 126          let hsModule = mkModule (ModuleName modName) (name symName) imports decls
 127              imports  = mkImports useGZip
 128              decls    = concat [ declResourceDef
 129                                , entityTagDecl eTag
 130                                , lastModifiedDecl lastMod
 131                                , contentTypeDecl mimeType
 132                                , if useGZip then
 133                                      dataDecl (name "gzippedData") gzippedB64
 134                                  else
 135                                      dataDecl (name "rawData") rawB64
 136                                ]
 137              declResourceDef
 138                  = [ HsTypeSig (⊥) [HsIdent symName]
 139                                (HsQualType []
 140                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
 141                    , HsFunBind [HsMatch (⊥) (HsIdent symName)
 142                                 [] (HsUnGuardedRhs defResourceDef) []]
 143                    ]
 144
 145              defResourceDef ∷ HsExp
 146              defResourceDef
 147                  = let defResGet = if useGZip
 148                                    then defResGetGZipped
 149                                    else resGetRaw
 150                    in
 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")))
 165                       ]
 166                      )
 167
 168              defResGetGZipped ∷ HsExp
 169              defResGetGZipped
 170                  = let doExp = HsDo [ foundEntityStmt
 171                                     , setContentTypeStmt
 172                                     , bindMustGunzip
 173                                     , doConditionalOutput
 174                                     ]
 175                        bindMustGunzip
 176                            = HsGenerator (⊥)
 177                              (HsPVar (HsIdent "mustGunzip"))
 178                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
 179                                      (HsVar (UnQual (HsIdent "not"))))
 180                               (HsParen
 181                                (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
 182                                       (HsLit (HsString "gzip")))))
 183                        doConditionalOutput
 184                            = HsQualifier
 185                              (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
 186                                    expOutputGunzipped
 187                                    expOutputGZipped)
 188                        expOutputGunzipped
 189                            = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 190                               (HsParen
 191                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
 192                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
 193                        expOutputGZipped
 194                            = HsDo [ setContentEncodingGZipStmt
 195                                   , outputStmt (var $ name "gzippedData")
 196                                   ]
 197                    in
 198                      HsApp (HsCon (UnQual (HsIdent "Just")))
 199                            (HsParen doExp)
 200
 201          hPutStrLn output header
 202          hPutStrLn output (prettyPrint hsModule)
 203          hClose output
 204
 205 mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
 206 mkModule modName symName imports decls
 207     = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
 208                                            ]
 209                       ]
 210           exports   = [ EVar (UnQual symName)
 211                       ]
 212       in
 213         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 214
 215 mkImports ∷ Bool → [ImportDecl]
 216 mkImports useGZip
 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
 225       ]
 226       ⧺
 227       if useGZip then
 228           [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
 229                        False False Nothing Nothing
 230           ]
 231       else
 232           []
 233
 234 resHead ∷ Exp
 235 resHead
 236     = infixApp (var $ name "Just")
 237                (op  $ name "$"   )
 238                (doE [ foundEntityStmt
 239                     , setContentTypeStmt
 240                     ])
 241
 242 resGetRaw ∷ Exp
 243 resGetRaw
 244     = infixApp (var $ name "Just")
 245                (op  $ name "$"   )
 246                (doE [ foundEntityStmt
 247                     , setContentTypeStmt
 248                     , outputStmt (var $ name "rawData")
 249                     ])
 250
 251 setContentEncodingGZipStmt ∷ Stmt
 252 setContentEncodingGZipStmt
 253     = qualStmt $
 254       metaFunction "setContentEncoding" $
 255       [ listE [ strE "gzip" ] ]
 256
 257 foundEntityStmt ∷ Stmt
 258 foundEntityStmt
 259     = qualStmt $
 260       metaFunction "foundEntity" $
 261       [ var $ name "entityTag"
 262       , var $ name "lastModified"
 263       ]
 264
 265 setContentTypeStmt ∷ Stmt
 266 setContentTypeStmt
 267     = qualStmt $
 268       metaFunction "setContentType" $
 269       [var $ name "contentType"]
 270
 271 outputStmt ∷ Exp → Stmt
 272 outputStmt e
 273     = qualStmt $
 274       metaFunction "output" [e]
 275
 276 entityTagDecl ∷ ETag → [Decl]
 277 entityTagDecl eTag
 278     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
 279       , nameBind (⊥) varName valExp
 280       ]
 281     where
 282       varName ∷ Name
 283       varName = name "entityTag"
 284
 285       valExp ∷ Exp
 286       valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
 287
 288       eTagToString ∷ ETag → String
 289       eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
 290
 291 lastModifiedDecl ∷ UTCTime → [Decl]
 292 lastModifiedDecl lastMod
 293     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
 294       , nameBind (⊥) varName valExp
 295       ]
 296     where
 297       varName ∷ Name
 298       varName = name "lastModified"
 299
 300       valExp ∷ Exp
 301       valExp = metaFunction "read" [strE $ show lastMod]
 302
 303 contentTypeDecl ∷ MIMEType → [Decl]
 304 contentTypeDecl mime
 305     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
 306       , nameBind (⊥) varName valExp
 307       ]
 308     where
 309       varName ∷ Name
 310       varName = name "contentType"
 311
 312       valExp ∷ Exp
 313       valExp = metaFunction "parseMIMEType" [mimeToString mime]
 314
 315       mimeToString ∷ MIMEType → String
 316       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 317
 318 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
 319 dataDecl varName chunks
 320     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
 321       , nameBind (⊥) varName valExp
 322       ]
 323     where
 324       valExp ∷ Exp
 325       valExp = qvar (ModuleName "Lazy") (name "fromChunks")
 326                `app`
 327                listE (chunkToExp <$> chunks)
 328
 329       chunkToExp ∷ Strict.ByteString → Exp
 330       chunkToExp chunk
 331           = qvar (ModuleName "B64") (name "decodeLenient")
 332             `app`
 333             strE (Strict.unpack chunk)
 334
 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" ++
 340                  "\n" ++
 341                  "              Source: " ++ (if srcFile ≡ "-"
 342                                               then "(stdin)"
 343                                               else srcFile) ++ "\n" ++
 344                  "     Original Length: " ++ show originalLen ++ " bytes\n" ++
 345                  (if useGZip
 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" ++
 352                  " -}")
 353
 354
 355 getModuleName ∷ [CmdOpt] → IO String
 356 getModuleName opts
 357     = let modNameOpts = filter (\ x → case x of
 358                                          OptModName _ → True
 359                                          _            → False) opts
 360       in
 361         case modNameOpts of
 362           []                      → error "a module name must be given."
 363           (OptModName modName):[] → return modName
 364           _                       → error "too many --module options."
 365
 366
 367 getSymbolName ∷ [CmdOpt] → String → IO String
 368 getSymbolName opts modName
 369     = let symNameOpts    = filter (\ x → case x of
 370                                             OptSymName _ → True
 371                                             _            → False) opts
 372           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
 373           -- 小文字にしたものを使ふ。
 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
 380       in
 381         case symNameOpts of
 382           []                      → return defaultSymName
 383           (OptSymName symName):[] → return symName
 384           _                       → error "too many --symbol options."
 385
 386
 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."
 393     where
 394       mimeTypeOpts ∷ [CmdOpt]
 395       mimeTypeOpts
 396           = filter (\ x → case x of
 397                              OptMIMEType _ → True
 398                              _             → False) opts
 399
 400       octetStream ∷ MIMEType
 401       octetStream = parseMIMEType "application/octet-stream"
 402
 403       defaultType ∷ MIMEType
 404       defaultType = fromMaybe octetStream
 405                     $ guessTypeByFileName defaultExtensionMap srcFile
 406
 407
 408 getLastModified ∷ FilePath → IO UTCTime
 409 getLastModified "-"   = getCurrentTime
 410 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
 411                         <$>
 412                         getFileStatus fpath
 413
 414
 415 getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
 416 getETag opts input
 417     = let eTagOpts = filter (\ x → case x of
 418                                       OptETag _ → True
 419                                       _         → False) opts
 420       in
 421         case eTagOpts of
 422           []               → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
 423           (OptETag str):[] → return str
 424           _                → error "too many --etag options."
 425     where
 426       mkETagFromInput ∷ Digest → String
 427       mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
 428
 429       toHex ∷ String → String
 430       toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
 431
 432       hexByte ∷ Int → String
 433       hexByte n
 434           = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
 435             , hex4bit ( n             .&. 0x0F)
 436             ]
 437
 438       hex4bit ∷ Int → Char
 439       hex4bit n
 440           | n < 10    = chr $ ord '0' + n
 441           | n < 16    = chr $ ord 'a' + n - 10
 442           | otherwise = (⊥)
 443
 444
 445 openInput ∷ FilePath → IO Lazy.ByteString
 446 openInput "-"   = Lazy.getContents
 447 openInput fpath = Lazy.readFile fpath
 448
 449
 450 openOutput ∷ [CmdOpt] → IO Handle
 451 openOutput opts
 452     = let outputOpts = filter (\ x → case x of
 453                                         OptOutput _ → True
 454                                         _           → False) opts
 455       in
 456         case outputOpts of
 457           []                   → return stdout
 458           (OptOutput fpath):[] → openFile fpath WriteMode
 459           _                    → error "two many --output options."
 460
 461 {-
 462   作られるファイルの例 (壓縮されない場合):
 463   ------------------------------------------------------------------------------
 464   {- DO NOT EDIT THIS FILE.
 465      This file is automatically generated by the lucu-implant-file program.
 466
 467                 Source: baz.png
 468        Original Length: 302 bytes
 469      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 470            Compression: disabled
 471              MIME Type: image/png
 472                   ETag: d41d8cd98f00b204e9800998ecf8427e
 473          Last Modified: 2007-11-05 13:53:42.231882 JST
 474    -}
 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
 479   import Data.Time
 480   import Network.HTTP.Lucu
 481
 482   baz ∷ ResourceDef
 483   baz = ResourceDef {
 484           resUsesNativeThread = False
 485         , resIsGreedy         = False
 486         , resGet
 487             = Just $ do foundEntity entityTag lastModified
 488                         setContentType contentType
 489                         output rawData
 490         , resHead
 491             = Just $ do foundEntity entityTag lastModified
 492                         setContentType contentType
 493         , resPost   = Nothing
 494         , resPut    = Nothing
 495         , resDelete = Nothing
 496         }
 497
 498   entityTag ∷ ETag
 499   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 500
 501   lastModified ∷ UTCTime
 502   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 503
 504   contentType ∷ MIMEType
 505   contentType = parseMIMEType "image/png"
 506
 507   rawData ∷ Lazy.ByteString
 508   rawData = Lazy.fromChunks
 509             [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
 510             , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
 511             ]
 512   ------------------------------------------------------------------------------
 513
 514   壓縮される場合は次のやうに變はる:
 515   ------------------------------------------------------------------------------
 516   -- import に追加
 517   import Codec.Compression.GZip
 518
 519   -- ResourceDef は次のやうに變化
 520   baz ∷ ResourceDef
 521   baz = ResourceDef {
 522           resUsesNativeThread = False
 523         , resIsGreedy         = False
 524         , resGet
 525             = Just $ do foundEntity entityTag lastModified
 526                         setContentType contentType
 527
 528                         gzip ← isEncodingAcceptable "gzip"
 529                         if gzip then
 530                             do setContentEncoding ["gzip"]
 531                                output gzippedData
 532                         else
 533                             output (decompress gzippedData)
 534         , resHead
 535             = Just $ do foundEntity entityTag lastModified
 536                         setContentType contentType
 537         , resPost   = Nothing
 538         , resPut    = Nothing
 539         , resDelete = Nothing
 540         }
 541
 542   -- rawData の代はりに gzippedData
 543   gzippedData ∷ Lazy.ByteString
 544   gzippedData = Lazy.fromChunks
 545                 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
 546                 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
 547                 ]
 548   ------------------------------------------------------------------------------
 549  -}