ImplantFile.hs

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