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