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