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                                , 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
 167 resourceDecl ∷ Name → Bool → [Decl]
 168 resourceDecl symName useGZip
 169     = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
 170       , nameBind (⊥) symName valExp
 171       ]
 172     where
 173       valExp ∷ Exp
 174       valExp = RecUpdate (var $ name "emptyResource")
 175                [ FieldUpdate (UnQual (name "resGet" )) resGet
 176                , FieldUpdate (UnQual (name "resHead")) resHead
 177                ]
 178
 179       resGet ∷ Exp
 180       resGet | useGZip   = resGetGZipped
 181              | otherwise = resGetRaw
 182
 183 resHead ∷ Exp
 184 resHead
 185     = function "Just" `app`
 186       paren (doE [ foundEntityStmt
 187                  , setContentTypeStmt
 188                  ])
 189
 190 resGetGZipped ∷ Exp
 191 resGetGZipped
 192     = function "Just" `app`
 193       paren (doE [ foundEntityStmt
 194                  , setContentTypeStmt
 195                  , bindGZipStmt
 196                  , conditionalOutputStmt
 197                  ])
 198     where
 199       condVarName ∷ Name
 200       condVarName = name "gzipAllowed"
 201
 202       dataVarName ∷ Name
 203       dataVarName = name "gzippedData"
 204
 205       bindGZipStmt ∷ Stmt
 206       bindGZipStmt
 207           = genStmt (⊥)
 208             (pvar condVarName)
 209             (function "isEncodingAcceptable" `app` strE "gzip")
 210
 211       conditionalOutputStmt ∷ Stmt
 212       conditionalOutputStmt
 213           = qualStmt $
 214             If (var condVarName)
 215                (doE [ setContentEncodingGZipStmt
 216                     , outputStmt (var dataVarName)
 217                     ])
 218                ( function "output"
 219                  `app`
 220                  paren (function "decompress" `app` var dataVarName)
 221                )
 222
 223 resGetRaw ∷ Exp
 224 resGetRaw
 225     = function "Just" `app`
 226       paren (doE [ foundEntityStmt
 227                  , setContentTypeStmt
 228                  , outputStmt (var $ name "rawData")
 229                  ])
 230
 231 setContentEncodingGZipStmt ∷ Stmt
 232 setContentEncodingGZipStmt
 233     = qualStmt
 234       ( function "setContentEncoding"
 235         `app`
 236         listE [ strE "gzip" ]
 237       )
 238
 239 foundEntityStmt ∷ Stmt
 240 foundEntityStmt
 241     = qualStmt $
 242       metaFunction "foundEntity"
 243                        [ var $ name "entityTag"
 244                        , var $ name "lastModified"
 245                        ]
 246
 247 setContentTypeStmt ∷ Stmt
 248 setContentTypeStmt
 249     = qualStmt
 250       ( function "setContentType"
 251         `app`
 252         var (name "contentType")
 253       )
 254
 255 outputStmt ∷ Exp → Stmt
 256 outputStmt e
 257     = qualStmt $ function "output" `app` e
 258
 259 entityTagDecl ∷ ETag → [Decl]
 260 entityTagDecl eTag
 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 eTag)
 270
 271 lastModifiedDecl ∷ UTCTime → [Decl]
 272 lastModifiedDecl lastMod
 273     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
 274       , nameBind (⊥) varName valExp
 275       ]
 276     where
 277       varName ∷ Name
 278       varName = name "lastModified"
 279
 280       valExp ∷ Exp
 281       valExp = function "read" `app` strE (show lastMod)
 282
 283 contentTypeDecl ∷ MIMEType → [Decl]
 284 contentTypeDecl mime
 285     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
 286       , nameBind (⊥) varName valExp
 287       ]
 288     where
 289       varName ∷ Name
 290       varName = name "contentType"
 291
 292       valExp ∷ Exp
 293       valExp = function "parseMIMEType" `app` strE (mimeToString mime)
 294
 295       mimeToString ∷ MIMEType → String
 296       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 297
 298 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
 299 dataDecl varName chunks
 300     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
 301       , nameBind (⊥) varName valExp
 302       ]
 303     where
 304       valExp ∷ Exp
 305       valExp = qvar (ModuleName "Lazy") (name "fromChunks")
 306                `app`
 307                listE (chunkToExp <$> chunks)
 308
 309       chunkToExp ∷ Strict.ByteString → Exp
 310       chunkToExp chunk
 311           = qvar (ModuleName "B64") (name "decodeLenient")
 312             `app`
 313             strE (Strict.unpack chunk)
 314
 315 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
 316 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 317     = do localLastMod ← utcToLocalZonedTime lastMod
 318          return $ concat
 319                     [ "{- DO NOT EDIT THIS FILE.\n"
 320                     , "   This file is automatically generated by the lucu-implant-file program.\n"
 321                     , "\n"
 322                     , "              Source: ", if srcFile ≡ "-" then
 323                                                     "(stdin)"
 324                                                 else
 325                                                     srcFile
 326                     , "\n"
 327                     , "     Original Length: ", show originalLen, " bytes\n"
 328                     , if useGZip then
 329                           "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
 330                           "         Compression: gzip\n"
 331                       else
 332                           "         Compression: disabled\n"
 333                     , "           MIME Type: ", mimeTypeToString mimeType, "\n"
 334                     , "                ETag: ", eTagToString eTag, "\n"
 335                     , "       Last Modified: ", show localLastMod, "\n"
 336                     , " -}"
 337                     ]
 338
 339 eTagToString ∷ ETag → String
 340 eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
 341
 342 mimeTypeToString ∷ MIMEType → String
 343 mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 344
 345 getModuleName ∷ [CmdOpt] → IO ModuleName
 346 getModuleName opts
 347     = case modNameOpts of
 348         []                    → fail "a module name must be given."
 349         OptModName modName:[] → return $ ModuleName modName
 350         _                     → fail "too many --module options."
 351     where
 352       modNameOpts ∷ [CmdOpt]
 353       modNameOpts = filter (\ x → case x of
 354                                      OptModName _ → True
 355                                      _            → False) opts
 356
 357 getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
 358 getSymbolName opts (ModuleName modName)
 359     = case symNameOpts of
 360         []                    → return defaultSymName
 361         OptSymName symName:[] → return $ name symName
 362         _                     → fail "too many --symbol options."
 363     where
 364       symNameOpts ∷ [CmdOpt]
 365       symNameOpts = filter (\ x → case x of
 366                                      OptSymName _ → True
 367                                      _            → False) opts
 368
 369       defaultSymName ∷ Name
 370       defaultSymName
 371           = name $ headToLower $ getLastComp modName
 372
 373       headToLower ∷ String → String
 374       headToLower []     = error "module name must not be empty"
 375       headToLower (x:xs) = toLower x : xs
 376
 377       getLastComp ∷ String → String
 378       getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
 379
 380 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 381 getMIMEType opts srcFile
 382     = case mimeTypeOpts of
 383         []  → return defaultType
 384         OptMIMEType ty:[]
 385             → case A.fromChars ty of
 386                  Just a  → return $ parseMIMEType a
 387                  Nothing → fail "MIME type must not contain any non-ASCII letters."
 388         _   → fail "too many --mime-type options."
 389     where
 390       mimeTypeOpts ∷ [CmdOpt]
 391       mimeTypeOpts
 392           = filter (\ x → case x of
 393                              OptMIMEType _ → True
 394                              _             → False) opts
 395
 396       octetStream ∷ MIMEType
 397       octetStream = parseMIMEType "application/octet-stream"
 398
 399       defaultType ∷ MIMEType
 400       defaultType = fromMaybe octetStream
 401                     $ guessTypeByFileName defaultExtensionMap srcFile
 402
 403 getLastModified ∷ FilePath → IO UTCTime
 404 getLastModified "-"   = getCurrentTime
 405 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
 406                         <$>
 407                         getFileStatus fpath
 408
 409 getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
 410 getETag opts input
 411     = case eTagOpts of
 412         []             → return mkETagFromInput
 413         OptETag str:[] → return $ strToETag str
 414         _              → fail "too many --etag options."
 415     where
 416       eTagOpts ∷ [CmdOpt]
 417       eTagOpts = filter (\ x → case x of
 418                                   OptETag _ → True
 419                                   _         → False) opts
 420
 421       mkETagFromInput ∷ ETag
 422       mkETagFromInput
 423           = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
 424
 425       strToETag ∷ String → ETag
 426       strToETag str
 427           = case A.fromChars str of
 428               Just a  → strongETag a
 429               Nothing → error "ETag must not contain any non-ASCII letters."
 430
 431 openInput ∷ FilePath → IO Lazy.ByteString
 432 openInput "-"   = Lazy.getContents
 433 openInput fpath = Lazy.readFile fpath
 434
 435 openOutput ∷ [CmdOpt] → IO Handle
 436 openOutput opts
 437     = case outputOpts of
 438         []                 → return stdout
 439         OptOutput fpath:[] → openFile fpath WriteMode
 440         _                  → fail "two many --output options."
 441     where
 442       outputOpts ∷ [CmdOpt]
 443       outputOpts = filter (\ x → case x of
 444                                     OptOutput _ → True
 445                                     _           → False) opts
 446
 447 {-
 448   作られるファイルの例 (壓縮されない場合):
 449   ------------------------------------------------------------------------------
 450   {- DO NOT EDIT THIS FILE.
 451      This file is automatically generated by the lucu-implant-file program.
 452
 453                 Source: baz.png
 454        Original Length: 302 bytes
 455      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 456            Compression: disabled
 457              MIME Type: image/png
 458                   ETag: "d41d8cd98f00b204e9800998ecf8427e"
 459          Last Modified: 2007-11-05 13:53:42.231882 JST
 460    -}
 461   {-# LANGUAGE OverloadedStrings #-}
 462   module Foo.Bar.Baz (baz) where
 463   import qualified Data.ByteString.Base64 as B64
 464   import qualified Data.ByteString.Lazy as Lazy
 465   import Data.Time
 466   import Network.HTTP.Lucu
 467
 468   baz ∷ ResourceDef
 469   baz = ResourceDef {
 470           resUsesNativeThread = False
 471         , resIsGreedy         = False
 472         , resGet
 473             = Just $ do foundEntity entityTag lastModified
 474                         setContentType contentType
 475                         output rawData
 476         , resHead
 477             = Just $ do foundEntity entityTag lastModified
 478                         setContentType contentType
 479         , resPost   = Nothing
 480         , resPut    = Nothing
 481         , resDelete = Nothing
 482         }
 483
 484   entityTag ∷ ETag
 485   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 486
 487   lastModified ∷ UTCTime
 488   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 489
 490   contentType ∷ MIMEType
 491   contentType = parseMIMEType "image/png"
 492
 493   rawData ∷ Lazy.ByteString
 494   rawData = Lazy.fromChunks
 495             [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
 496             , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
 497             ]
 498   ------------------------------------------------------------------------------
 499
 500   壓縮される場合は次のやうに變はる:
 501   ------------------------------------------------------------------------------
 502   -- import に追加
 503   import Codec.Compression.GZip
 504
 505   -- ResourceDef は次のやうに變化
 506   baz ∷ ResourceDef
 507   baz = ResourceDef {
 508           resUsesNativeThread = False
 509         , resIsGreedy         = False
 510         , resGet
 511             = Just $ do foundEntity entityTag lastModified
 512                         setContentType contentType
 513
 514                         gzipAllowed ← isEncodingAcceptable "gzip"
 515                         if gzipAllowed then
 516                             do setContentEncoding ["gzip"]
 517                                output gzippedData
 518                         else
 519                             output (decompress gzippedData)
 520         , resHead
 521             = Just $ do foundEntity entityTag lastModified
 522                         setContentType contentType
 523         , resPost   = Nothing
 524         , resPut    = Nothing
 525         , resDelete = Nothing
 526         }
 527
 528   -- rawData の代はりに gzippedData
 529   gzippedData ∷ Lazy.ByteString
 530   gzippedData = Lazy.fromChunks
 531                 [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
 532                 , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
 533                 ]
 534   ------------------------------------------------------------------------------
 535  -}