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