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           unless (null errors)
  82                    $ do mapM_ putStr errors
  83                         exitWith $ ExitFailure 1
  84
  85           when (any (== 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 = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)
 404                         $ getFileStatus fpath
 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           []               -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1")
 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 :: String -> String
 422       toHex = foldr ((++) . hexByte . fromEnum) ""
 423
 424       hexByte :: Int -> String
 425       hexByte n
 426           = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
 427             , hex4bit ( n             .&. 0x0F)
 428             ]
 429
 430       hex4bit :: Int -> Char
 431       hex4bit n
 432           | n < 10    = chr $ ord '0' + n
 433           | n < 16    = chr $ ord 'a' + n - 10
 434           | otherwise = undefined
 435
 436
 437 openInput :: FilePath -> IO Lazy.ByteString
 438 openInput "-"   = L.getContents
 439 openInput fpath = L.readFile fpath
 440
 441
 442 openOutput :: [CmdOpt] -> IO Handle
 443 openOutput opts
 444     = let outputOpts = filter (\ x -> case x of
 445                                         OptOutput _ -> True
 446                                         _           -> False) opts
 447       in
 448         case outputOpts of
 449           []                   -> return stdout
 450           (OptOutput fpath):[] -> openFile fpath WriteMode
 451           _                    -> error "two many --output options."
 452
 453
 454 {-
 455   作られるファイルの例 (壓縮されない場合):
 456   ------------------------------------------------------------------------------
 457   {- DO NOT EDIT THIS FILE.
 458      This file is automatically generated by the lucu-implant-file program.
 459
 460                 Source: baz.png
 461        Original Length: 302 bytes
 462      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
 463            Compression: disabled
 464              MIME Type: image/png
 465                   ETag: d41d8cd98f00b204e9800998ecf8427e
 466          Last Modified: 2007-11-05 13:53:42.231882 JST
 467    -}
 468   module Foo.Bar.Baz (baz) where
 469   import Codec.Binary.Base64
 470   import qualified Data.ByteString.Lazy as L
 471   import Data.Maybe
 472   import Data.Time
 473   import Network.HTTP.Lucu
 474
 475   baz :: ResourceDef
 476   baz = ResourceDef {
 477           resUsesNativeThread = False
 478         , resIsGreedy         = False
 479         , resGet
 480             = Just (do foundEntity entityTag lastModified
 481                        setContentType contentType
 482                        outputLBS rawData)
 483         , resHead   = Nothing
 484         , resPost   = Nothing
 485         , resPut    = Nothing
 486         , resDelete = Nothing
 487         }
 488
 489   entityTag :: ETag
 490   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 491
 492   lastModified :: UTCTime
 493   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 494
 495   contentType :: MIMEType
 496   contentType = read "image/png"
 497
 498   rawData :: L.ByteString
 499   rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))
 500   ------------------------------------------------------------------------------
 501
 502   壓縮される場合は次のやうに變はる:
 503   ------------------------------------------------------------------------------
 504   -- import に追加
 505   import Control.Monad
 506   import Codec.Compression.GZip
 507
 508   -- ResourceDef は次のやうに變化
 509   baz :: ResourceDef
 510   baz = ResourceDef {
 511           resUsesNativeThread = False
 512         , resIsGreedy         = False
 513         , resGet
 514             = Just (do foundEntity entityTag lastModified
 515                        setContentType contentType
 516
 517                        mustGunzip <- liftM not (isEncodingAcceptable "gzip")
 518                        if mustGunzip then
 519                            outputLBS (decompress gzippedData)
 520                          else
 521                            do setContentEncoding ["gzip"]
 522                               outputLBS gzippedData
 523         , resHead   = Nothing
 524         , resPost   = Nothing
 525         , resPut    = Nothing
 526         , resDelete = Nothing
 527         }
 528
 529   -- rawData の代はりに gzippedData
 530   gzippedData :: L.ByteString
 531   gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))
 532   ------------------------------------------------------------------------------
 533  -}