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.Time")
 124                                        False Nothing Nothing
 125                         , HsImportDecl undefined (Module "Network.HTTP.Lucu")
 126                                        False Nothing Nothing
 127                         ]
 128                         ++
 129                         (if useGZip then
 130                              [ HsImportDecl undefined (Module "Control.Monad")
 131                                             False Nothing Nothing
 132                              , HsImportDecl undefined (Module "Codec.Compression.GZip")
 133                                             False Nothing Nothing
 134                              ]
 135                          else
 136                              [])
 137              decls    = declResourceDef
 138                         ++
 139                         declEntityTag
 140                         ++
 141                         declLastModified
 142                         ++
 143                         declContentType
 144                         ++
 145                         (if useGZip
 146                          then declGZippedData
 147                          else declRawData)
 148
 149              declResourceDef :: [HsDecl]
 150              declResourceDef
 151                  = [ HsTypeSig undefined [HsIdent symName]
 152                                (HsQualType []
 153                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
 154                    , HsFunBind [HsMatch undefined (HsIdent symName)
 155                                 [] (HsUnGuardedRhs defResourceDef) []]
 156                    ]
 157
 158              defResourceDef :: HsExp
 159              defResourceDef
 160                  = let defResGet = if useGZip
 161                                    then defResGetGZipped
 162                                    else defResGetRaw
 163                    in
 164                      (HsRecConstr (UnQual (HsIdent "ResourceDef"))
 165                       [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
 166                                       (HsCon (UnQual (HsIdent "False")))
 167                       , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
 168                                       (HsCon (UnQual (HsIdent "False")))
 169                       , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
 170                       , HsFieldUpdate (UnQual (HsIdent "resHead"))
 171                                       (HsCon (UnQual (HsIdent "Nothing")))
 172                       , HsFieldUpdate (UnQual (HsIdent "resPost"))
 173                                       (HsCon (UnQual (HsIdent "Nothing")))
 174                       , HsFieldUpdate (UnQual (HsIdent "resPut"))
 175                                       (HsCon (UnQual (HsIdent "Nothing")))
 176                       , HsFieldUpdate (UnQual (HsIdent "resDelete"))
 177                                       (HsCon (UnQual (HsIdent "Nothing")))
 178                       ]
 179                      )
 180
 181              defResGetGZipped :: HsExp
 182              defResGetGZipped
 183                  = let doExp = HsDo [ doFoundEntity
 184                                     , doSetContentType
 185                                     , bindMustGunzip
 186                                     , doConditionalOutput
 187                                     ]
 188                        doFoundEntity
 189                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 190                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 191                                           (HsVar (UnQual (HsIdent "lastModified"))))
 192                        doSetContentType
 193                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 194                                           (HsVar (UnQual (HsIdent "contentType"))))
 195                        bindMustGunzip
 196                            = HsGenerator undefined
 197                              (HsPVar (HsIdent "mustGunzip"))
 198                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
 199                                      (HsVar (UnQual (HsIdent "not"))))
 200                               (HsParen
 201                                (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
 202                                       (HsLit (HsString "gzip")))))
 203                        doConditionalOutput
 204                            = HsQualifier
 205                              (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
 206                                    expOutputGunzipped
 207                                    expOutputGZipped)
 208                        expOutputGunzipped
 209                            = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 210                               (HsParen
 211                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
 212                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
 213                        expOutputGZipped
 214                            = HsDo [ doSetContentEncodingGZip
 215                                   , doOutputGZipped
 216                                   ]
 217                        doSetContentEncodingGZip
 218                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
 219                                           (HsList [HsLit (HsString "gzip")]))
 220                        doOutputGZipped
 221                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 222                                           (HsVar (UnQual (HsIdent "gzippedData"))))
 223                    in
 224                      HsApp (HsCon (UnQual (HsIdent "Just")))
 225                            (HsParen doExp)
 226
 227              defResGetRaw :: HsExp
 228              defResGetRaw
 229                  = let doExp = HsDo [ doFoundEntity
 230                                     , doSetContentType
 231                                     , doOutputRawData
 232                                     ]
 233                        doFoundEntity
 234                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 235                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 236                                           (HsVar (UnQual (HsIdent "lastModified"))))
 237                        doSetContentType
 238                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 239                                           (HsVar (UnQual (HsIdent "contentType"))))
 240                        doOutputRawData
 241                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 242                                           (HsVar (UnQual (HsIdent "rawData"))))
 243                    in
 244                      HsApp (HsCon (UnQual (HsIdent "Just")))
 245                            (HsParen doExp)
 246
 247              declEntityTag :: [HsDecl]
 248              declEntityTag
 249                  = [ HsTypeSig undefined [HsIdent "entityTag"]
 250                                (HsQualType []
 251                                 (HsTyCon (UnQual (HsIdent "ETag"))))
 252                    , HsFunBind [HsMatch undefined (HsIdent "entityTag")
 253                                 [] (HsUnGuardedRhs defEntityTag) []]
 254                    ]
 255
 256              defEntityTag :: HsExp
 257              defEntityTag
 258                  = HsApp (HsVar (UnQual (HsIdent "strongETag")))
 259                    (HsLit (HsString eTag))
 260
 261              declLastModified :: [HsDecl]
 262              declLastModified
 263                  = [ HsTypeSig undefined [HsIdent "lastModified"]
 264                                (HsQualType []
 265                                 (HsTyCon (UnQual (HsIdent "UTCTime"))))
 266                    , HsFunBind [HsMatch undefined (HsIdent "lastModified")
 267                                 [] (HsUnGuardedRhs defLastModified) []]
 268                    ]
 269
 270              defLastModified :: HsExp
 271              defLastModified
 272                  = HsApp (HsVar (UnQual (HsIdent "read")))
 273                    (HsLit (HsString $ show lastMod))
 274
 275
 276              declContentType :: [HsDecl]
 277              declContentType
 278                  = [ HsTypeSig undefined [HsIdent "contentType"]
 279                                (HsQualType []
 280                                 (HsTyCon (UnQual (HsIdent "MIMEType"))))
 281                    , HsFunBind [HsMatch undefined (HsIdent "contentType")
 282                                 [] (HsUnGuardedRhs defContentType) []]
 283                    ]
 284
 285              defContentType :: HsExp
 286              defContentType
 287                  = HsApp (HsVar (UnQual (HsIdent "read")))
 288                    (HsLit (HsString $ show mimeType))
 289
 290              declGZippedData :: [HsDecl]
 291              declGZippedData
 292                  = [ HsTypeSig undefined [HsIdent "gzippedData"]
 293                                (HsQualType []
 294                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
 295                    , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
 296                                 [] (HsUnGuardedRhs defGZippedData) []]
 297                    ]
 298
 299              defGZippedData :: HsExp
 300              defGZippedData
 301                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
 302                    (HsParen
 303                     (HsApp (HsVar (UnQual (HsIdent "decode")))
 304                      (HsLit (HsString gzippedB64))))
 305
 306              declRawData :: [HsDecl]
 307              declRawData
 308                  = [ HsTypeSig undefined [HsIdent "rawData"]
 309                                (HsQualType []
 310                                 (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
 311                    , HsFunBind [HsMatch undefined (HsIdent "rawData")
 312                                 [] (HsUnGuardedRhs defRawData) []]
 313                    ]
 314
 315              defRawData :: HsExp
 316              defRawData
 317                  = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))
 318                    (HsParen
 319                     (HsApp (HsVar (UnQual (HsIdent "decode")))
 320                      (HsLit (HsString rawB64))))
 321
 322          hPutStrLn output header
 323          hPutStrLn output (prettyPrint hsModule)
 324          hClose output
 325
 326
 327 mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
 328 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 329     = do localLastMod <- utcToLocalZonedTime lastMod
 330          return ("{- DO NOT EDIT THIS FILE.\n" ++
 331                  "   This file is automatically generated by the lucu-implant-file program.\n" ++
 332                  "\n" ++
 333                  "              Source: " ++ (if srcFile == "-"
 334                                               then "(stdin)"
 335                                               else srcFile) ++ "\n" ++
 336                  "     Original Length: " ++ show originalLen ++ " bytes\n" ++
 337                  (if useGZip
 338                   then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
 339                        "         Compression: gzip\n"
 340                   else "         Compression: disabled\n") ++
 341                  "           MIME Type: " ++ show mimeType ++ "\n" ++
 342                  "                ETag: " ++ eTag ++ "\n" ++
 343                  "       Last Modified: " ++ show localLastMod ++ "\n" ++
 344                  " -}")
 345
 346
 347 getModuleName :: [CmdOpt] -> IO String
 348 getModuleName opts
 349     = let modNameOpts = filter (\ x -> case x of
 350                                          OptModName _ -> True
 351                                          _            -> False) opts
 352       in
 353         case modNameOpts of
 354           []                      -> error "a module name must be given."
 355           (OptModName modName):[] -> return modName
 356           _                       -> error "too many --module options."
 357
 358
 359 getSymbolName :: [CmdOpt] -> String -> IO String
 360 getSymbolName opts modName
 361     = let symNameOpts    = filter (\ x -> case x of
 362                                             OptSymName _ -> True
 363                                             _            -> False) opts
 364           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
 365           -- 小文字にしたものを使ふ。
 366           defaultSymName = mkDefault modName
 367           mkDefault      = headToLower . getLastComp
 368           headToLower    = \ str -> case str of
 369                                       []     -> error "module name must not be empty"
 370                                       (x:xs) -> toLower x : xs
 371           getLastComp    = reverse . fst . break (== '.') . reverse
 372       in
 373         case symNameOpts of
 374           []                      -> return defaultSymName
 375           (OptSymName symName):[] -> return symName
 376           _                       -> error "too many --symbol options."
 377
 378
 379 getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
 380 getMIMEType opts srcFile
 381     = let mimeTypeOpts = filter (\ x -> case x of
 382                                           OptMIMEType _ -> True
 383                                           _             -> False) opts
 384           defaultType  = fromMaybe (read "application/octet-stream")
 385                          $ guessTypeByFileName defaultExtensionMap srcFile
 386       in
 387         case mimeTypeOpts of
 388           []                        -> return defaultType
 389           (OptMIMEType mimeType):[] -> return $ read mimeType
 390           _                         -> error "too many --mime-type options."
 391
 392
 393 getLastModified :: FilePath -> IO UTCTime
 394 getLastModified "-"   = getCurrentTime
 395 getLastModified fpath = getFileStatus fpath
 396                         >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
 397
 398
 399 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
 400 getETag opts input
 401     = let eTagOpts = filter (\ x -> case x of
 402                                       OptETag _ -> True
 403                                       _         -> False) opts
 404       in
 405         case eTagOpts of
 406           []               -> return mkETagFromInput
 407           (OptETag str):[] -> return str
 408           _                -> error "too many --etag options."
 409     where
 410       mkETagFromInput :: String
 411       mkETagFromInput = "SHA-1:" ++ (toHex $ toOctets $ sha256 $ L.unpack input)
 412
 413       toHex :: [Word8] -> String
 414       toHex []     = ""
 415       toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs
 416
 417       hexByte :: Int -> String
 418       hexByte n
 419           = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
 420
 421       hex4bit :: Int -> Char
 422       hex4bit n
 423           | n < 10    = (chr $ ord '0' + n     )
 424           | n < 16    = (chr $ ord 'a' + n - 10)
 425           | otherwise = undefined
 426
 427
 428 openInput :: FilePath -> IO Lazy.ByteString
 429 openInput "-"   = L.getContents
 430 openInput fpath = L.readFile fpath
 431
 432
 433 openOutput :: [CmdOpt] -> IO Handle
 434 openOutput opts
 435     = let outputOpts = filter (\ x -> case x of
 436                                         OptOutput _ -> True
 437                                         _           -> False) opts
 438       in
 439         case outputOpts of
 440           []                   -> return stdout
 441           (OptOutput fpath):[] -> openFile fpath WriteMode
 442           _                    -> error "two many --output options."
 443
 444
 445 {-
 446   作られるファイルの例 (壓縮されない場合):
 447   ------------------------------------------------------------------------------
 448   {- DO NOT EDIT THIS FILE.
 449      This file is automatically generated by the lucu-implant-file program.
 450
 451                 Source: baz.png
 452        Original Length: 302 bytes
 453      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 454            Compression: disabled
 455              MIME Type: image/png
 456                   ETag: d41d8cd98f00b204e9800998ecf8427e
 457          Last Modified: 2007-11-05 13:53:42.231882 JST
 458    -}
 459   module Foo.Bar.Baz (baz) where
 460   import Codec.Binary.Base64
 461   import qualified Data.ByteString.Lazy as L
 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                        outputLBS rawData)
 473         , resHead   = Nothing
 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 = read "image/png"
 487
 488   rawData :: L.ByteString
 489   rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")
 490   ------------------------------------------------------------------------------
 491
 492   壓縮される場合は次のやうに變はる:
 493   ------------------------------------------------------------------------------
 494   -- import に追加
 495   import Control.Monad
 496   import Codec.Compression.GZip
 497
 498   -- ResourceDef は次のやうに變化
 499   baz :: ResourceDef
 500   baz = ResourceDef {
 501           resUsesNativeThread = False
 502         , resIsGreedy         = False
 503         , resGet
 504             = Just (do foundEntity entityTag lastModified
 505                        setContentType contentType
 506
 507                        mustGunzip <- liftM not (isEncodingAcceptable "gzip")
 508                        if mustGunzip then
 509                            outputLBS (decompress gzippedData)
 510                          else
 511                            do setContentEncoding ["gzip"]
 512                               outputLBS gzippedData
 513         , resHead   = Nothing
 514         , resPost   = Nothing
 515         , resPut    = Nothing
 516         , resDelete = Nothing
 517         }
 518
 519   -- rawData の代はりに gzippedData
 520   gzippedData :: L.ByteString
 521   gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")
 522   ------------------------------------------------------------------------------
 523  -}