ImplantFile.hs

   1 import           Codec.Compression.GZip
   2 import           Control.Monad
   3 import           Data.Bits
   4 import qualified Data.ByteString as BS
   5 import qualified Data.ByteString.Base64 as B64
   6 import qualified Data.ByteString.Char8 as C8
   7 import qualified Data.ByteString.Lazy as Lazy (ByteString)
   8 import qualified Data.ByteString.Lazy as LS hiding (ByteString)
   9 import           Data.Char
  10 import           Data.Int
  11 import           Data.Maybe
  12 import           Data.Time
  13 import           Data.Time.Clock.POSIX
  14 import           Language.Haskell.Pretty
  15 import           Language.Haskell.Syntax
  16 import           Network.HTTP.Lucu.MIMEType
  17 import           Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
  18 import           Network.HTTP.Lucu.MIMEType.Guess
  19 import           OpenSSL
  20 import           OpenSSL.EVP.Digest
  21 import           System.Console.GetOpt
  22 import           System.Environment
  23 import           System.Exit
  24 import           System.Posix.Files
  25 import           System.IO
  26
  27 data CmdOpt
  28     = OptOutput FilePath
  29     | OptModName String
  30     | OptSymName String
  31     | OptMIMEType String
  32     | OptETag String
  33     | OptHelp
  34     deriving (Eq, Show)
  35
  36
  37 options :: [OptDescr CmdOpt]
  38 options = [ Option ['o'] ["output"]
  39                        (ReqArg OptOutput "FILE")
  40                        "Output to the FILE."
  41
  42           , Option ['m'] ["module"]
  43                        (ReqArg OptModName "MODULE")
  44                        "Specify the resulting module name. (required)"
  45
  46           , Option ['s'] ["symbol"]
  47                        (ReqArg OptSymName "SYMBOL")
  48                        "Specify the resulting symbol name."
  49
  50           , Option ['t'] ["mime-type"]
  51                        (ReqArg OptMIMEType "TYPE")
  52                        "Specify the MIME Type of the file."
  53
  54           , Option ['e'] ["etag"]
  55                        (ReqArg OptETag "TAG")
  56                        "Specify the ETag of the file."
  57
  58           , Option ['h'] ["help"]
  59                        (NoArg OptHelp)
  60                        "Print this message."
  61           ]
  62
  63
  64 printUsage :: IO ()
  65 printUsage = do putStrLn ""
  66                 putStrLn "Description:"
  67                 putStrLn ("  lucu-implant-file is an utility that generates " ++
  68                           "Haskell code containing an arbitrary file to " ++
  69                           "compile it directly into programs and serve it " ++
  70                           "statically with the Lucu HTTP server.")
  71                 putStrLn ""
  72                 putStrLn "Usage:"
  73                 putStrLn "  lucu-implant-file [OPTIONS...] FILE"
  74                 putStrLn ""
  75                 putStr $ usageInfo "Options:" options
  76                 putStrLn ""
  77
  78
  79 main :: IO ()
  80 main = withOpenSSL $
  81        do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
  82
  83           unless (null errors)
  84                    $ do mapM_ putStr errors
  85                         exitWith $ ExitFailure 1
  86
  87           when (any (== OptHelp) opts)
  88                    $ do printUsage
  89                         exitWith ExitSuccess
  90
  91           when (null sources)
  92                    $ do printUsage
  93                         exitWith $ ExitFailure 1
  94
  95           when (length sources >= 2)
  96                    $ error "too many input files."
  97
  98           generateHaskellSource opts (head sources)
  99
 100
 101 generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
 102 generateHaskellSource opts srcFile
 103     = do modName  <- getModuleName opts
 104          symName  <- getSymbolName opts modName
 105          mimeType <- getMIMEType opts srcFile
 106          lastMod  <- getLastModified srcFile
 107          input    <- openInput srcFile
 108          output   <- openOutput opts
 109          eTag     <- getETag opts input
 110
 111          let compParams  = defaultCompressParams { compressLevel = bestCompression }
 112              gzippedData = compressWith compParams input
 113              originalLen = LS.length input
 114              gzippedLen  = LS.length gzippedData
 115              useGZip     = originalLen > gzippedLen
 116              rawB64      = B64.encode $ BS.concat $ LS.toChunks input
 117              gzippedB64  = B64.encode $ BS.concat $ LS.toChunks gzippedData
 118
 119          header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 120
 121          let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
 122              exports  = [HsEVar (UnQual (HsIdent symName))]
 123              imports  = [ HsImportDecl undefined (Module "Data.ByteString.Base64")
 124                                        True (Just (Module "B64")) Nothing
 125                         , HsImportDecl undefined (Module "Data.ByteString.Char8")
 126                                        True (Just (Module "C8")) Nothing
 127                         , HsImportDecl undefined (Module "Data.ByteString.Lazy")
 128                                        True (Just (Module "LS")) Nothing
 129                         , HsImportDecl undefined (Module "Data.Time")
 130                                        False Nothing Nothing
 131                         , HsImportDecl undefined (Module "Network.HTTP.Lucu")
 132                                        False Nothing Nothing
 133                         ]
 134                         ++
 135                         (if useGZip then
 136                              [ HsImportDecl undefined (Module "Control.Monad")
 137                                             False Nothing Nothing
 138                              , HsImportDecl undefined (Module "Codec.Compression.GZip")
 139                                             False Nothing Nothing
 140                              ]
 141                          else
 142                              [])
 143              decls    = declResourceDef
 144                         ++
 145                         declEntityTag
 146                         ++
 147                         declLastModified
 148                         ++
 149                         declContentType
 150                         ++
 151                         (if useGZip
 152                          then declGZippedData
 153                          else declRawData)
 154
 155              declResourceDef :: [HsDecl]
 156              declResourceDef
 157                  = [ HsTypeSig undefined [HsIdent symName]
 158                                (HsQualType []
 159                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
 160                    , HsFunBind [HsMatch undefined (HsIdent symName)
 161                                 [] (HsUnGuardedRhs defResourceDef) []]
 162                    ]
 163
 164              defResourceDef :: HsExp
 165              defResourceDef
 166                  = let defResGet = if useGZip
 167                                    then defResGetGZipped
 168                                    else defResGetRaw
 169                    in
 170                      (HsRecConstr (UnQual (HsIdent "ResourceDef"))
 171                       [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
 172                                       (HsCon (UnQual (HsIdent "False")))
 173                       , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
 174                                       (HsCon (UnQual (HsIdent "False")))
 175                       , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
 176                       , HsFieldUpdate (UnQual (HsIdent "resHead"))
 177                                       (HsCon (UnQual (HsIdent "Nothing")))
 178                       , HsFieldUpdate (UnQual (HsIdent "resPost"))
 179                                       (HsCon (UnQual (HsIdent "Nothing")))
 180                       , HsFieldUpdate (UnQual (HsIdent "resPut"))
 181                                       (HsCon (UnQual (HsIdent "Nothing")))
 182                       , HsFieldUpdate (UnQual (HsIdent "resDelete"))
 183                                       (HsCon (UnQual (HsIdent "Nothing")))
 184                       ]
 185                      )
 186
 187              defResGetGZipped :: HsExp
 188              defResGetGZipped
 189                  = let doExp = HsDo [ doFoundEntity
 190                                     , doSetContentType
 191                                     , bindMustGunzip
 192                                     , doConditionalOutput
 193                                     ]
 194                        doFoundEntity
 195                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 196                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 197                                           (HsVar (UnQual (HsIdent "lastModified"))))
 198                        doSetContentType
 199                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 200                                           (HsVar (UnQual (HsIdent "contentType"))))
 201                        bindMustGunzip
 202                            = HsGenerator undefined
 203                              (HsPVar (HsIdent "mustGunzip"))
 204                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
 205                                      (HsVar (UnQual (HsIdent "not"))))
 206                               (HsParen
 207                                (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
 208                                       (HsLit (HsString "gzip")))))
 209                        doConditionalOutput
 210                            = HsQualifier
 211                              (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
 212                                    expOutputGunzipped
 213                                    expOutputGZipped)
 214                        expOutputGunzipped
 215                            = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 216                               (HsParen
 217                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
 218                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
 219                        expOutputGZipped
 220                            = HsDo [ doSetContentEncodingGZip
 221                                   , doOutputGZipped
 222                                   ]
 223                        doSetContentEncodingGZip
 224                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
 225                                           (HsList [HsLit (HsString "gzip")]))
 226                        doOutputGZipped
 227                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 228                                           (HsVar (UnQual (HsIdent "gzippedData"))))
 229                    in
 230                      HsApp (HsCon (UnQual (HsIdent "Just")))
 231                            (HsParen doExp)
 232
 233              defResGetRaw :: HsExp
 234              defResGetRaw
 235                  = let doExp = HsDo [ doFoundEntity
 236                                     , doSetContentType
 237                                     , doOutputRawData
 238                                     ]
 239                        doFoundEntity
 240                            = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
 241                                                  (HsVar (UnQual (HsIdent "entityTag"))))
 242                                           (HsVar (UnQual (HsIdent "lastModified"))))
 243                        doSetContentType
 244                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
 245                                           (HsVar (UnQual (HsIdent "contentType"))))
 246                        doOutputRawData
 247                            = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
 248                                           (HsVar (UnQual (HsIdent "rawData"))))
 249                    in
 250                      HsApp (HsCon (UnQual (HsIdent "Just")))
 251                            (HsParen doExp)
 252
 253              declEntityTag :: [HsDecl]
 254              declEntityTag
 255                  = [ HsTypeSig undefined [HsIdent "entityTag"]
 256                                (HsQualType []
 257                                 (HsTyCon (UnQual (HsIdent "ETag"))))
 258                    , HsFunBind [HsMatch undefined (HsIdent "entityTag")
 259                                 [] (HsUnGuardedRhs defEntityTag) []]
 260                    ]
 261
 262              defEntityTag :: HsExp
 263              defEntityTag
 264                  = HsApp (HsVar (UnQual (HsIdent "strongETag")))
 265                    (HsLit (HsString eTag))
 266
 267              declLastModified :: [HsDecl]
 268              declLastModified
 269                  = [ HsTypeSig undefined [HsIdent "lastModified"]
 270                                (HsQualType []
 271                                 (HsTyCon (UnQual (HsIdent "UTCTime"))))
 272                    , HsFunBind [HsMatch undefined (HsIdent "lastModified")
 273                                 [] (HsUnGuardedRhs defLastModified) []]
 274                    ]
 275
 276              defLastModified :: HsExp
 277              defLastModified
 278                  = HsApp (HsVar (UnQual (HsIdent "read")))
 279                    (HsLit (HsString $ show lastMod))
 280
 281
 282              declContentType :: [HsDecl]
 283              declContentType
 284                  = [ HsTypeSig undefined [HsIdent "contentType"]
 285                                (HsQualType []
 286                                 (HsTyCon (UnQual (HsIdent "MIMEType"))))
 287                    , HsFunBind [HsMatch undefined (HsIdent "contentType")
 288                                 [] (HsUnGuardedRhs defContentType) []]
 289                    ]
 290
 291              defContentType :: HsExp
 292              defContentType
 293                  = HsApp (HsVar (UnQual (HsIdent "read")))
 294                    (HsLit (HsString $ show mimeType))
 295
 296              declGZippedData :: [HsDecl]
 297              declGZippedData
 298                  = [ HsTypeSig undefined [HsIdent "gzippedData"]
 299                                (HsQualType []
 300                                 (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
 301                    , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
 302                                 [] (HsUnGuardedRhs defGZippedData) []]
 303                    ]
 304
 305              defGZippedData :: HsExp
 306              defGZippedData
 307                  = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
 308                    (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
 309                             (HsParen
 310                              (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
 311                               (HsLit (HsString $ C8.unpack gzippedB64))))])
 312
 313              declRawData :: [HsDecl]
 314              declRawData
 315                  = [ HsTypeSig undefined [HsIdent "rawData"]
 316                                (HsQualType []
 317                                 (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
 318                    , HsFunBind [HsMatch undefined (HsIdent "rawData")
 319                                 [] (HsUnGuardedRhs defRawData) []]
 320                    ]
 321
 322              defRawData :: HsExp
 323              defRawData
 324                  = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
 325                    (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
 326                             (HsParen
 327                              (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
 328                               (HsLit (HsString $ C8.unpack 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 "-"   = LS.getContents
 439 openInput fpath = LS.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 qualified Data.ByteString.Base64 as B64
 470   import qualified Data.ByteString.Char8 as C8
 471   import qualified Data.ByteString.Lazy as LS
 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 :: LS.ByteString
 499   rawData = LS.fromChunks [B64.decodeLenient (C8.pack "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 :: LS.ByteString
 531   gzippedData = LS.fromChunks [B64.decodeLenient (C8.pack "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")]
 532   ------------------------------------------------------------------------------
 533  -}