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          mimeType ← getMIMEType opts srcFile
 112          lastMod  ← getLastModified srcFile
 113          input    ← openInput srcFile
 114          output   ← openOutput opts
 115          eTag     ← 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 mimeType eTag lastMod
 126
 127          let hsModule = mkModule modName symName imports decls
 128              imports  = mkImports useGZip
 129              decls    = concat ([ resourceDecl symName useGZip
 130                                 , entityTagDecl eTag
 131                                 , lastModifiedDecl lastMod
 132                                 , contentTypeDecl mimeType
 133                                 ]
 134                                 ⧺
 135                                 if useGZip then
 136                                     [ gunzipAndPutChunkDecl
 137                                     , dataDecl (name "gzippedData") gzippedB64
 138                                     ]
 139                                 else
 140                                     [ dataDecl (name "rawData") rawB64 ]
 141                                )
 142
 143          hPutStrLn output header
 144          hPutStrLn output (prettyPrint hsModule)
 145          hClose output
 146
 147 mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module
 148 mkModule modName symName imports decls
 149     = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
 150           exports   = [ EVar (UnQual symName) ]
 151       in
 152         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 153
 154 mkImports ∷ Bool → [ImportDecl]
 155 mkImports useGZip
 156     = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
 157                    True False Nothing (Just (ModuleName "B64")) Nothing
 158       , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
 159                    True False Nothing (Just (ModuleName "Lazy")) Nothing
 160       , ImportDecl (⊥) (ModuleName "Data.Time")
 161                    False False Nothing Nothing Nothing
 162       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
 163                    False False Nothing Nothing Nothing
 164       ]
 165       ⧺
 166       if useGZip then
 167           [ ImportDecl (⊥) (ModuleName "Blaze.ByteString.Builder.ByteString")
 168                        True False Nothing (Just (ModuleName "BB")) Nothing
 169           , ImportDecl (⊥) (ModuleName "Codec.Compression.Zlib.Internal")
 170                        False False Nothing Nothing Nothing
 171           , ImportDecl (⊥) (ModuleName "Data.Text")
 172                        True False Nothing (Just (ModuleName "T")) Nothing
 173           ]
 174       else
 175           []
 176
 177 resourceDecl ∷ Name → Bool → [Decl]
 178 resourceDecl symName useGZip
 179     = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
 180       , nameBind (⊥) symName valExp
 181       ]
 182     where
 183       valExp ∷ Exp
 184       valExp = RecUpdate (function "emptyResource")
 185                [ FieldUpdate (UnQual (name "resGet" )) resGet
 186                , FieldUpdate (UnQual (name "resHead")) resHead
 187                ]
 188
 189       resGet ∷ Exp
 190       resGet | useGZip   = resGetGZipped
 191              | otherwise = resGetRaw
 192
 193 resHead ∷ Exp
 194 resHead
 195     = function "Just" `app`
 196       paren (doE [ foundEntityStmt
 197                  , setContentTypeStmt
 198                  ])
 199
 200 resGetGZipped ∷ Exp
 201 resGetGZipped
 202     = function "Just" `app`
 203       paren (doE [ foundEntityStmt
 204                  , setContentTypeStmt
 205                  , bindGZipStmt
 206                  , conditionalOutputStmt
 207                  ])
 208     where
 209       condVarName ∷ Name
 210       condVarName = name "gzipAllowed"
 211
 212       dataVarName ∷ Name
 213       dataVarName = name "gzippedData"
 214
 215       bindGZipStmt ∷ Stmt
 216       bindGZipStmt
 217           = genStmt (⊥)
 218             (pvar condVarName)
 219             (function "isEncodingAcceptable" `app` strE "gzip")
 220
 221       conditionalOutputStmt ∷ Stmt
 222       conditionalOutputStmt
 223           = qualStmt $
 224             If (var condVarName)
 225                (doE [ setContentEncodingGZipStmt
 226                     , outputStmt (var dataVarName)
 227                     ])
 228                (function "gunzipAndPutChunk" `app` var dataVarName)
 229
 230 resGetRaw ∷ Exp
 231 resGetRaw
 232     = function "Just" `app`
 233       paren (doE [ foundEntityStmt
 234                  , setContentTypeStmt
 235                  , outputStmt (function "rawData")
 236                  ])
 237
 238 setContentEncodingGZipStmt ∷ Stmt
 239 setContentEncodingGZipStmt
 240     = qualStmt
 241       ( function "setContentEncoding"
 242         `app`
 243         listE [ strE "gzip" ]
 244       )
 245
 246 foundEntityStmt ∷ Stmt
 247 foundEntityStmt
 248     = qualStmt $
 249       metaFunction "foundEntity"
 250                        [ var (name "entityTag")
 251                        , var (name "lastModified")
 252                        ]
 253
 254 setContentTypeStmt ∷ Stmt
 255 setContentTypeStmt
 256     = qualStmt
 257       ( function "setContentType"
 258         `app`
 259         function "contentType"
 260       )
 261
 262 outputStmt ∷ Exp → Stmt
 263 outputStmt e
 264     = qualStmt $ function "putChunk" `app` e
 265
 266 entityTagDecl ∷ ETag → [Decl]
 267 entityTagDecl eTag
 268     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
 269       , nameBind (⊥) varName valExp
 270       ]
 271     where
 272       varName ∷ Name
 273       varName = name "entityTag"
 274
 275       valExp ∷ Exp
 276       valExp = function "parseETag" `app` strE (eTagToString eTag)
 277
 278 lastModifiedDecl ∷ UTCTime → [Decl]
 279 lastModifiedDecl lastMod
 280     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
 281       , nameBind (⊥) varName valExp
 282       ]
 283     where
 284       varName ∷ Name
 285       varName = name "lastModified"
 286
 287       valExp ∷ Exp
 288       valExp = function "read" `app` strE (show lastMod)
 289
 290 contentTypeDecl ∷ MIMEType → [Decl]
 291 contentTypeDecl mime
 292     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
 293       , nameBind (⊥) varName valExp
 294       ]
 295     where
 296       varName ∷ Name
 297       varName = name "contentType"
 298
 299       valExp ∷ Exp
 300       valExp = function "parseMIMEType" `app` strE (mimeToString mime)
 301
 302       mimeToString ∷ MIMEType → String
 303       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 304
 305 gunzipAndPutChunkDecl ∷ [Decl]
 306 gunzipAndPutChunkDecl
 307     = [ TypeSig (⊥) [funName]
 308                     (TyFun (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
 309                            tyResourceUnit)
 310       , sfun (⊥) funName [] (UnGuardedRhs funExp) (binds goDecl)
 311       ]
 312     where
 313       funName ∷ Name
 314       funName = name "gunzipAndPutChunk"
 315
 316       goName ∷ Name
 317       goName = name "go"
 318
 319       tyResourceUnit ∷ Type
 320       tyResourceUnit
 321           = TyApp (TyCon (UnQual (name "Resource")))
 322                   (TyTuple Boxed [])
 323
 324       funExp ∷ Exp
 325       funExp = var goName
 326                `app`
 327                function "."
 328                `app`
 329                metaFunction "decompressWithErrors"
 330                                 [ function "gzipFormat"
 331                                 , function "defaultDecompressParams"
 332                                 ]
 333
 334       goDecl ∷ [Decl]
 335       goDecl = [ TypeSig (⊥) [goName]
 336                              (TyFun (TyCon (UnQual (name "DecompressStream")))
 337                                     tyResourceUnit)
 338                , FunBind [ Match (⊥) goName [pvar (name "StreamEnd")]
 339                                  Nothing (UnGuardedRhs endExp) (binds [])
 340                          , Match (⊥) goName [pApp (name "StreamChunk")
 341                                                   [ pvar (name "x")
 342                                                   , pvar (name "xs") ]]
 343                                  Nothing (UnGuardedRhs chunkExp) (binds [])
 344                          , Match (⊥) goName [pApp (name "StreamError")
 345                                                    [ wildcard
 346                                                    , pvar (name "msg") ]]
 347                                  Nothing (UnGuardedRhs errorExp) (binds [])
 348                          ]
 349                ]
 350
 351       endExp ∷ Exp
 352       endExp = function "return" `app` tuple []
 353
 354       chunkExp ∷ Exp
 355       chunkExp = function "putBuilder"
 356                  `app`
 357                  paren ( qvar (ModuleName "BB") (name "fromByteString")
 358                          `app`
 359                          var (name "x")
 360                        )
 361                  `app`
 362                  function ">>"
 363                  `app`
 364                  function "go" `app` var (name "xs")
 365
 366       errorExp ∷ Exp
 367       errorExp = metaFunction "abort"
 368                  [ var (name "InternalServerError")
 369                  , listE []
 370                  , function "Just"
 371                    `app`
 372                    paren ( qvar (ModuleName "T") (name "pack")
 373                            `app`
 374                            paren ( strE "gunzip: "
 375                                    `app`
 376                                    function "++"
 377                                    `app`
 378                                    var (name "msg")
 379                                  )
 380                          )
 381                  ]
 382
 383 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
 384 dataDecl varName chunks
 385     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
 386       , nameBind (⊥) varName valExp
 387       ]
 388     where
 389       valExp ∷ Exp
 390       valExp = qvar (ModuleName "Lazy") (name "fromChunks")
 391                `app`
 392                listE (chunkToExp <$> chunks)
 393
 394       chunkToExp ∷ Strict.ByteString → Exp
 395       chunkToExp chunk
 396           = qvar (ModuleName "B64") (name "decodeLenient")
 397             `app`
 398             strE (Strict.unpack chunk)
 399
 400 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
 401 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 402     = do localLastMod ← utcToLocalZonedTime lastMod
 403          return $ concat
 404                     [ "{- DO NOT EDIT THIS FILE.\n"
 405                     , "   This file is automatically generated by the lucu-implant-file program.\n"
 406                     , "\n"
 407                     , "              Source: ", if srcFile ≡ "-" then
 408                                                     "(stdin)"
 409                                                 else
 410                                                     srcFile
 411                     , "\n"
 412                     , "     Original Length: ", show originalLen, " bytes\n"
 413                     , if useGZip then
 414                           "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
 415                           "         Compression: gzip\n"
 416                       else
 417                           "         Compression: disabled\n"
 418                     , "           MIME Type: ", mimeTypeToString mimeType, "\n"
 419                     , "                ETag: ", eTagToString eTag, "\n"
 420                     , "       Last Modified: ", show localLastMod, "\n"
 421                     , " -}"
 422                     ]
 423
 424 eTagToString ∷ ETag → String
 425 eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
 426
 427 mimeTypeToString ∷ MIMEType → String
 428 mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 429
 430 getModuleName ∷ [CmdOpt] → IO ModuleName
 431 getModuleName opts
 432     = case modNameOpts of
 433         []                    → fail "a module name must be given."
 434         OptModName modName:[] → return $ ModuleName modName
 435         _                     → fail "too many --module options."
 436     where
 437       modNameOpts ∷ [CmdOpt]
 438       modNameOpts = filter (\ x → case x of
 439                                      OptModName _ → True
 440                                      _            → False) opts
 441
 442 getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
 443 getSymbolName opts (ModuleName modName)
 444     = case symNameOpts of
 445         []                    → return defaultSymName
 446         OptSymName symName:[] → return $ name symName
 447         _                     → fail "too many --symbol options."
 448     where
 449       symNameOpts ∷ [CmdOpt]
 450       symNameOpts = filter (\ x → case x of
 451                                      OptSymName _ → True
 452                                      _            → False) opts
 453
 454       defaultSymName ∷ Name
 455       defaultSymName
 456           = name $ headToLower $ getLastComp modName
 457
 458       headToLower ∷ String → String
 459       headToLower []     = error "module name must not be empty"
 460       headToLower (x:xs) = toLower x : xs
 461
 462       getLastComp ∷ String → String
 463       getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
 464
 465 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 466 getMIMEType opts srcFile
 467     = case mimeTypeOpts of
 468         []  → return defaultType
 469         OptMIMEType ty:[]
 470             → case A.fromChars ty of
 471                  Just a  → return $ parseMIMEType a
 472                  Nothing → fail "MIME type must not contain any non-ASCII letters."
 473         _   → fail "too many --mime-type options."
 474     where
 475       mimeTypeOpts ∷ [CmdOpt]
 476       mimeTypeOpts
 477           = filter (\ x → case x of
 478                              OptMIMEType _ → True
 479                              _             → False) opts
 480
 481       octetStream ∷ MIMEType
 482       octetStream = parseMIMEType "application/octet-stream"
 483
 484       defaultType ∷ MIMEType
 485       defaultType = fromMaybe octetStream
 486                     $ guessTypeByFileName defaultExtensionMap srcFile
 487
 488 getLastModified ∷ FilePath → IO UTCTime
 489 getLastModified "-"   = getCurrentTime
 490 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
 491                         <$>
 492                         getFileStatus fpath
 493
 494 getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
 495 getETag opts input
 496     = case eTagOpts of
 497         []             → return mkETagFromInput
 498         OptETag str:[] → return $ strToETag str
 499         _              → fail "too many --etag options."
 500     where
 501       eTagOpts ∷ [CmdOpt]
 502       eTagOpts = filter (\ x → case x of
 503                                   OptETag _ → True
 504                                   _         → False) opts
 505
 506       mkETagFromInput ∷ ETag
 507       mkETagFromInput
 508           = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
 509
 510       strToETag ∷ String → ETag
 511       strToETag str
 512           = case A.fromChars str of
 513               Just a  → strongETag a
 514               Nothing → error "ETag must not contain any non-ASCII letters."
 515
 516 openInput ∷ FilePath → IO Lazy.ByteString
 517 openInput "-"   = Lazy.getContents
 518 openInput fpath = Lazy.readFile fpath
 519
 520 openOutput ∷ [CmdOpt] → IO Handle
 521 openOutput opts
 522     = case outputOpts of
 523         []                 → return stdout
 524         OptOutput fpath:[] → openFile fpath WriteMode
 525         _                  → fail "two many --output options."
 526     where
 527       outputOpts ∷ [CmdOpt]
 528       outputOpts = filter (\ x → case x of
 529                                     OptOutput _ → True
 530                                     _           → False) opts
 531
 532 {-
 533   作られるファイルの例 (壓縮されない場合):
 534   ------------------------------------------------------------------------------
 535   {- DO NOT EDIT THIS FILE.
 536      This file is automatically generated by the lucu-implant-file program.
 537
 538                 Source: baz.png
 539        Original Length: 302 bytes
 540      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 541            Compression: disabled
 542              MIME Type: image/png
 543                   ETag: "d41d8cd98f00b204e9800998ecf8427e"
 544          Last Modified: 2007-11-05 13:53:42.231882 JST
 545    -}
 546   {-# LANGUAGE OverloadedStrings #-}
 547   module Foo.Bar.Baz (baz) where
 548   import qualified Data.ByteString.Base64 as B64
 549   import qualified Data.ByteString.Lazy as Lazy
 550   import Data.Time
 551   import Network.HTTP.Lucu
 552
 553   baz ∷ ResourceDef
 554   baz = ResourceDef {
 555           resUsesNativeThread = False
 556         , resIsGreedy         = False
 557         , resGet
 558             = Just $ do foundEntity entityTag lastModified
 559                         setContentType contentType
 560                         putChunk rawData
 561         , resHead
 562             = Just $ do foundEntity entityTag lastModified
 563                         setContentType contentType
 564         , resPost   = Nothing
 565         , resPut    = Nothing
 566         , resDelete = Nothing
 567         }
 568
 569   entityTag ∷ ETag
 570   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 571
 572   lastModified ∷ UTCTime
 573   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 574
 575   contentType ∷ MIMEType
 576   contentType = parseMIMEType "image/png"
 577
 578   rawData ∷ Lazy.ByteString
 579   rawData = Lazy.fromChunks
 580             [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
 581             , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
 582             ]
 583   ------------------------------------------------------------------------------
 584
 585   壓縮される場合は次のやうに變はる:
 586   ------------------------------------------------------------------------------
 587   -- import に追加
 588   import qualified Blaze.ByteString.Builder.ByteString as BB
 589   import Codec.Compression.Zlib.Internal
 590   import qualified Data.Text as T
 591
 592   -- ResourceDef は次のやうに變化
 593   baz ∷ ResourceDef
 594   baz = ResourceDef {
 595           resUsesNativeThread = False
 596         , resIsGreedy         = False
 597         , resGet
 598             = Just $ do foundEntity entityTag lastModified
 599                         setContentType contentType
 600
 601                         gzipAllowed ← isEncodingAcceptable "gzip"
 602                         if gzipAllowed then
 603                             do setContentEncoding ["gzip"]
 604                                putChunk gzippedData
 605                         else
 606                             gunzipAndPutChunk gzippedData
 607         , resHead
 608             = Just $ do foundEntity entityTag lastModified
 609                         setContentType contentType
 610         , resPost   = Nothing
 611         , resPut    = Nothing
 612         , resDelete = Nothing
 613         }
 614
 615   -- 追加
 616   gunzipAndPutChunk :: Lazy.ByteString -> Resource ()
 617   gunzipAndPutChunk = go . decompressWithErrors gzipFormat defaultDecompressParams
 618       where
 619         go :: DecompressStream -> Resource ()
 620         go StreamEnd = return ()
 621         go (StreamChunk x xs) = putBuilder (BB.fromByteString x) >> go xs
 622         go (StreamError _ msg) = abort InternalServerError [] (Just (T.pack ("gunzip: " ++ msg)))
 623
 624   -- rawData の代はりに gzippedData
 625   gzippedData ∷ Lazy.ByteString
 626   gzippedData = Lazy.fromChunks
 627                 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
 628                 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
 629                 ]
 630   ------------------------------------------------------------------------------
 631  -}