ImplantFile.hs

   1 import           Codec.Binary.Base64
   2 import           Codec.Compression.GZip
   3 import           Control.Monad
   4 import           Data.Bits
   5 import qualified Data.ByteString.Lazy as Lazy (ByteString)
   6 import qualified Data.ByteString.Lazy as L hiding (ByteString)
   7 import           Data.Char
   8 import           Data.Digest.SHA2
   9 import           Data.Int
  10 import           Data.Maybe
  11 import           Data.Time
  12 import           Data.Time.Clock.POSIX
  13 import           Data.Word
  14 import           Language.Haskell.Pretty
  15 import           Language.Haskell.Syntax
  16 import           Network.HTTP.Lucu.MIMEType
  17 import           Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
  18 import           Network.HTTP.Lucu.MIMEType.Guess
  19 import           System.Console.GetOpt
  20 import           System.Environment
  21 import           System.Exit
  22 import           System.Posix.Files
  23 import           System.IO
  24
  25 data CmdOpt
  26     = OptOutput FilePath
  27     | OptModName String
  28     | OptSymName String
  29     | OptMIMEType String
  30     | OptETag String
  31     | OptHelp
  32     deriving (Eq, Show)
  33
  34
  35 options :: [OptDescr CmdOpt]
  36 options = [ Option ['o'] ["output"]
  37                        (ReqArg OptOutput "FILE")
  38                        "Output to the FILE."
  39
  40           , Option ['m'] ["module"]
  41                        (ReqArg OptModName "MODULE")
  42                        "Specify the resulting module name. (required)"
  43
  44           , Option ['s'] ["symbol"]
  45                        (ReqArg OptSymName "SYMBOL")
  46                        "Specify the resulting symbol name."
  47
  48           , Option ['t'] ["mime-type"]
  49                        (ReqArg OptMIMEType "TYPE")
  50                        "Specify the MIME Type of the file."
  51
  52           , Option ['e'] ["etag"]
  53                        (ReqArg OptETag "TAG")
  54                        "Specify the ETag of the file."
  55
  56           , Option ['h'] ["help"]
  57                        (NoArg OptHelp)
  58                        "Print this message."
  59           ]
  60
  61
  62 printUsage :: IO ()
  63 printUsage = do putStrLn ""
  64                 putStrLn "Description:"
  65                 putStrLn ("  lucu-implant-file is an utility that generates " ++
  66                           "Haskell code containing an arbitrary file to " ++
  67                           "compile it directly into programs and serve it " ++
  68                           "statically with the Lucu HTTP server.")
  69                 putStrLn ""
  70                 putStrLn "Usage:"
  71                 putStrLn "  lucu-implant-file [OPTIONS...] FILE"
  72                 putStrLn ""
  73                 putStr $ usageInfo "Options:" options
  74                 putStrLn ""
  75
  76
  77 main :: IO ()
  78 main = do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
  79
  80           when (not $ null errors)
  81                    $ do mapM_ putStr errors
  82                         exitWith $ ExitFailure 1
  83
  84           when (any (\ x -> x == OptHelp) opts)
  85                    $ do printUsage
  86                         exitWith ExitSuccess
  87
  88           when (null sources)
  89                    $ do printUsage
  90                         exitWith $ ExitFailure 1
  91
  92           when (length sources >= 2)
  93                    $ error "too many input files."
  94
  95           generateHaskellSource opts (head sources)
  96
  97
  98 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
  99 generateHaskellSource opts srcFile
 100     = do modName  <- getModuleName opts
 101          symName  <- getSymbolName opts modName
 102          mimeType <- getMIMEType opts srcFile
 103          lastMod  <- getLastModified srcFile
 104          input    <- openInput srcFile
 105          output   <- openOutput opts
 106          eTag     <- getETag opts input
 107
 108          let gzippedData = compressWith BestCompression input
 109              originalLen = L.length input
 110              gzippedLen  = L.length gzippedData
 111              useGZip     = originalLen > gzippedLen
 112              rawB64      = encode $ L.unpack input
 113              gzippedB64  = encode $ L.unpack gzippedData
 114
 115          header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 116
 117          let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
 118              exports  = [HsEVar (UnQual (HsIdent symName))]
 119              imports  = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
 120                                        False Nothing Nothing
 121                         , HsImportDecl undefined (Module "Data.ByteString.Lazy")
 122                                        True (Just (Module "L")) Nothing
 123                         , HsImportDecl undefined (Module "Data.Maybe")
 124                                        False Nothing Nothing
 125                         , HsImportDecl undefined (Module "Data.Time")
 126                                        False Nothing Nothing
 127                         , HsImportDecl undefined (Module "Network.HTTP.Lucu")
 128                                        False Nothing Nothing
 129                         ]
 130                         ++
 131                         (if useGZip then
 132                              [ HsImportDecl undefined (Module "Control.Monad")
 133                                             False Nothing Nothing
 134                              , HsImportDecl undefined (Module "Codec.Compression.GZip")
 135                                             False Nothing Nothing
 136                              ]
 137                          else
 138                              [])
 139              decls    = declResourceDef
 140                         ++
 141                         declEntityTag
 142                         ++
 143                         declLastModified
 144                         ++
 145                         declContentType
 146                         ++
 147                         (if useGZip
 148                          then declGZippedData
 149                          else declRawData)
 150
 151              declResourceDef :: [HsDecl]
 152              declResourceDef
 153                  = [ HsTypeSig undefined [HsIdent symName]
 154                                (HsQualType []
 155                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
 156                    , HsFunBind [HsMatch undefined (HsIdent symName)
 157                                 [] (HsUnGuardedRhs defResourceDef) []]
 158                    ]
 159
 160              defResourceDef :: HsExp
 161              defResourceDef
 162                  = let defResGet = if useGZip
 163                                    then defResGetGZipped
 164                                    else defResGetRaw
 165                    in
 166                      (HsRecConstr (UnQual (HsIdent "ResourceDef"))
 167                       [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
 168                                       (HsCon (UnQual (HsIdent "False")))
 169                       , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
 170                                       (HsCon (UnQual (HsIdent "False")))
 171                       , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
 172                       , HsFieldUpdate (UnQual (HsIdent "resHead"))
 173                                       (HsCon (UnQual (HsIdent "Nothing")))
 174                       , HsFieldUpdate (UnQual (HsIdent "resPost"))
 175                                       (HsCon (UnQual (HsIdent "Nothing")))
 176                       , HsFieldUpdate (UnQual (HsIdent "resPut"))
 177                                       (HsCon (UnQual (HsIdent "Nothing")))
 178                       , HsFieldUpdate (UnQual (HsIdent "resDelete"))
 179                                       (HsCon (UnQual (HsIdent "Nothing")))
 180                       ]
 181                      )
 182
 183              defResGetGZipped :: HsExp
 184              defResGetGZipped
 185                  = let doExp = HsDo [ doFoundEntity
 186                                     , doSetContentType
 187                                     , bindMustGunzip
 188                                     , doConditionalOutput
 189                                     ]
 190                        doFoundEntity
 191                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 192                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 193                                           (HsVar (UnQual (HsIdent "lastModified"))))
 194                        doSetContentType
 195                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 196                                           (HsVar (UnQual (HsIdent "contentType"))))
 197                        bindMustGunzip
 198                            = HsGenerator undefined
 199                              (HsPVar (HsIdent "mustGunzip"))
 200                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
 201                                      (HsVar (UnQual (HsIdent "not"))))
 202                               (HsParen
 203                                (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
 204                                       (HsLit (HsString "gzip")))))
 205                        doConditionalOutput
 206                            = HsQualifier
 207                              (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
 208                                    expOutputGunzipped
 209                                    expOutputGZipped)
 210                        expOutputGunzipped
 211                            = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 212                               (HsParen
 213                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
 214                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
 215                        expOutputGZipped
 216                            = HsDo [ doSetContentEncodingGZip
 217                                   , doOutputGZipped
 218                                   ]
 219                        doSetContentEncodingGZip
 220                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
 221                                           (HsList [HsLit (HsString "gzip")]))
 222                        doOutputGZipped
 223                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 224                                           (HsVar (UnQual (HsIdent "gzippedData"))))
 225                    in
 226                      HsApp (HsCon (UnQual (HsIdent "Just")))
 227                            (HsParen doExp)
 228
 229              defResGetRaw :: HsExp
 230              defResGetRaw
 231                  = let doExp = HsDo [ doFoundEntity
 232                                     , doSetContentType
 233                                     , doOutputRawData
 234                                     ]
 235                        doFoundEntity
 236                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 237                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 238                                           (HsVar (UnQual (HsIdent "lastModified"))))
 239                        doSetContentType
 240                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 241                                           (HsVar (UnQual (HsIdent "contentType"))))
 242                        doOutputRawData
 243                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 244                                           (HsVar (UnQual (HsIdent "rawData"))))
 245                    in
 246                      HsApp (HsCon (UnQual (HsIdent "Just")))
 247                            (HsParen doExp)
 248
 249              declEntityTag :: [HsDecl]
 250              declEntityTag
 251                  = [ HsTypeSig undefined [HsIdent "entityTag"]
 252                                (HsQualType []
 253                                 (HsTyCon (UnQual (HsIdent "ETag"))))
 254                    , HsFunBind [HsMatch undefined (HsIdent "entityTag")
 255                                 [] (HsUnGuardedRhs defEntityTag) []]
 256                    ]
 257
 258              defEntityTag :: HsExp
 259              defEntityTag
 260                  = HsApp (HsVar (UnQual (HsIdent "strongETag")))
 261                    (HsLit (HsString eTag))
 262
 263              declLastModified :: [HsDecl]
 264              declLastModified
 265                  = [ HsTypeSig undefined [HsIdent "lastModified"]
 266                                (HsQualType []
 267                                 (HsTyCon (UnQual (HsIdent "UTCTime"))))
 268                    , HsFunBind [HsMatch undefined (HsIdent "lastModified")
 269                                 [] (HsUnGuardedRhs defLastModified) []]
 270                    ]
 271
 272              defLastModified :: HsExp
 273              defLastModified
 274                  = HsApp (HsVar (UnQual (HsIdent "read")))
 275                    (HsLit (HsString $ show lastMod))
 276
 277
 278              declContentType :: [HsDecl]
 279              declContentType
 280                  = [ HsTypeSig undefined [HsIdent "contentType"]
 281                                (HsQualType []
 282                                 (HsTyCon (UnQual (HsIdent "MIMEType"))))
 283                    , HsFunBind [HsMatch undefined (HsIdent "contentType")
 284                                 [] (HsUnGuardedRhs defContentType) []]
 285                    ]
 286
 287              defContentType :: HsExp
 288              defContentType
 289                  = HsApp (HsVar (UnQual (HsIdent "read")))
 290                    (HsLit (HsString $ show mimeType))
 291
 292              declGZippedData :: [HsDecl]
 293              declGZippedData
 294                  = [ HsTypeSig undefined [HsIdent "gzippedData"]
 295                                (HsQualType []
 296                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
 297                    , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
 298                                 [] (HsUnGuardedRhs defGZippedData) []]
 299                    ]
 300
 301              defGZippedData :: HsExp
 302              defGZippedData
 303                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
 304                    (HsParen
 305                     (HsApp (HsVar (UnQual (HsIdent "fromJust")))
 306                      (HsParen
 307                       (HsApp (HsVar (UnQual (HsIdent "decode")))
 308                        (HsLit (HsString gzippedB64))))))
 309
 310              declRawData :: [HsDecl]
 311              declRawData
 312                  = [ HsTypeSig undefined [HsIdent "rawData"]
 313                                (HsQualType []
 314                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
 315                    , HsFunBind [HsMatch undefined (HsIdent "rawData")
 316                                 [] (HsUnGuardedRhs defRawData) []]
 317                    ]
 318
 319              defRawData :: HsExp
 320              defRawData
 321                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
 322                    (HsParen
 323                     (HsApp (HsVar (UnQual (HsIdent "fromJust")))
 324                      (HsParen
 325                       (HsApp (HsVar (UnQual (HsIdent "decode")))
 326                        (HsLit (HsString rawB64))))))
 327
 328          hPutStrLn output header
 329          hPutStrLn output (prettyPrint hsModule)
 330          hClose output
 331
 332
 333 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
 334 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 335     = do localLastMod <- utcToLocalZonedTime lastMod
 336          return ("{- DO NOT EDIT THIS FILE.\n" ++
 337                  "   This file is automatically generated by the lucu-implant-file program.\n" ++
 338                  "\n" ++
 339                  "              Source: " ++ (if srcFile == "-"
 340                                               then "(stdin)"
 341                                               else srcFile) ++ "\n" ++
 342                  "     Original Length: " ++ show originalLen ++ " bytes\n" ++
 343                  (if useGZip
 344                   then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
 345                        "         Compression: gzip\n"
 346                   else "         Compression: disabled\n") ++
 347                  "           MIME Type: " ++ show mimeType ++ "\n" ++
 348                  "                ETag: " ++ eTag ++ "\n" ++
 349                  "       Last Modified: " ++ show localLastMod ++ "\n" ++
 350                  " -}")
 351
 352
 353 getModuleName :: [CmdOpt] -> IO String
 354 getModuleName opts
 355     = let modNameOpts = filter (\ x -> case x of
 356                                          OptModName _ -> True
 357                                          _            -> False) opts
 358       in
 359         case modNameOpts of
 360           []                      -> error "a module name must be given."
 361           (OptModName modName):[] -> return modName
 362           _                       -> error "too many --module options."
 363
 364
 365 getSymbolName :: [CmdOpt] -> String -> IO String
 366 getSymbolName opts modName
 367     = let symNameOpts    = filter (\ x -> case x of
 368                                             OptSymName _ -> True
 369                                             _            -> False) opts
 370           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
 371           -- 小文字にしたものを使ふ。
 372           defaultSymName = mkDefault modName
 373           mkDefault      = headToLower . getLastComp
 374           headToLower    = \ str -> case str of
 375                                       []     -> error "module name must not be empty"
 376                                       (x:xs) -> toLower x : xs
 377           getLastComp    = reverse . fst . break (== '.') . reverse
 378       in
 379         case symNameOpts of
 380           []                      -> return defaultSymName
 381           (OptSymName symName):[] -> return symName
 382           _                       -> error "too many --symbol options."
 383
 384
 385 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
 386 getMIMEType opts srcFile
 387     = let mimeTypeOpts = filter (\ x -> case x of
 388                                           OptMIMEType _ -> True
 389                                           _             -> False) opts
 390           defaultType  = fromMaybe (read "application/octet-stream")
 391                          $ guessTypeByFileName defaultExtensionMap srcFile
 392       in
 393         case mimeTypeOpts of
 394           []                        -> return defaultType
 395           (OptMIMEType mimeType):[] -> return $ read mimeType
 396           _                         -> error "too many --mime-type options."
 397
 398
 399 getLastModified :: FilePath -> IO UTCTime
 400 getLastModified "-"   = getCurrentTime
 401 getLastModified fpath = getFileStatus fpath
 402                         >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
 403
 404
 405 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
 406 getETag opts input
 407     = let eTagOpts = filter (\ x -> case x of
 408                                       OptETag _ -> True
 409                                       _         -> False) opts
 410       in
 411         case eTagOpts of
 412           []               -> return mkETagFromInput
 413           (OptETag str):[] -> return str
 414           _                -> error "too many --etag options."
 415     where
 416       mkETagFromInput :: String
 417       mkETagFromInput = "SHA-1:" ++ (toHex $ toOctets $ sha256 $ L.unpack input)
 418
 419       toHex :: [Word8] -> String
 420       toHex []     = ""
 421       toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs
 422
 423       hexByte :: Int -> String
 424       hexByte n
 425           = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
 426
 427       hex4bit :: Int -> Char
 428       hex4bit n
 429           | n < 10    = (chr $ ord '0' + n     )
 430           | n < 16    = (chr $ ord 'a' + n - 10)
 431           | otherwise = undefined
 432
 433
 434 openInput :: FilePath -> IO Lazy.ByteString
 435 openInput "-"   = L.getContents
 436 openInput fpath = L.readFile fpath
 437
 438
 439 openOutput :: [CmdOpt] -> IO Handle
 440 openOutput opts
 441     = let outputOpts = filter (\ x -> case x of
 442                                         OptOutput _ -> True
 443                                         _           -> False) opts
 444       in
 445         case outputOpts of
 446           []                   -> return stdout
 447           (OptOutput fpath):[] -> openFile fpath WriteMode
 448           _                    -> error "two many --output options."
 449
 450
 451 {-
 452   作られるファイルの例 (壓縮されない場合):
 453   ------------------------------------------------------------------------------
 454   {- DO NOT EDIT THIS FILE.
 455      This file is automatically generated by the lucu-implant-file program.
 456
 457                 Source: baz.png
 458        Original Length: 302 bytes
 459      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 460            Compression: disabled
 461              MIME Type: image/png
 462                   ETag: d41d8cd98f00b204e9800998ecf8427e
 463          Last Modified: 2007-11-05 13:53:42.231882 JST
 464    -}
 465   module Foo.Bar.Baz (baz) where
 466   import Codec.Binary.Base64
 467   import qualified Data.ByteString.Lazy as L
 468   import Data.Maybe
 469   import Data.Time
 470   import Network.HTTP.Lucu
 471
 472   baz :: ResourceDef
 473   baz = ResourceDef {
 474           resUsesNativeThread = False
 475         , resIsGreedy         = False
 476         , resGet
 477             = Just (do foundEntity entityTag lastModified
 478                        setContentType contentType
 479                        outputLBS rawData)
 480         , resHead   = Nothing
 481         , resPost   = Nothing
 482         , resPut    = Nothing
 483         , resDelete = Nothing
 484         }
 485
 486   entityTag :: ETag
 487   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 488
 489   lastModified :: UTCTime
 490   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 491
 492   contentType :: MIMEType
 493   contentType = read "image/png"
 494
 495   rawData :: L.ByteString
 496   rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
 497   ------------------------------------------------------------------------------
 498
 499   壓縮される場合は次のやうに變はる:
 500   ------------------------------------------------------------------------------
 501   -- import に追加
 502   import Control.Monad
 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                        mustGunzip <- liftM not (isEncodingAcceptable "gzip")
 515                        if mustGunzip then
 516                            outputLBS (decompress gzippedData)
 517                          else
 518                            do setContentEncoding ["gzip"]
 519                               outputLBS gzippedData
 520         , resHead   = Nothing
 521         , resPost   = Nothing
 522         , resPut    = Nothing
 523         , resDelete = Nothing
 524         }
 525
 526   -- rawData の代はりに gzippedData
 527   gzippedData :: L.ByteString
 528   gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
 529   ------------------------------------------------------------------------------
 530  -}