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  -}