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