{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Upload Haddock documentation to S3. module Stackage.Curator.UploadDocs ( uploadDocs , upload ) where import ClassyPrelude.Conduit import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import Control.Monad.Trans.Resource (liftResourceT) import Control.Monad.Trans.RWS.Ref (MonadRWS, get, modify, put, runRWSIORefT, tell) import Crypto.Hash (Digest, SHA256) import Crypto.Hash.Conduit (sinkHash) import Data.Byteable (toBytes) import qualified Data.ByteString.Base16 as B16 import Data.Conduit.Zlib (WindowBits (WindowBits), compress) import Data.XML.Types (Content (ContentText), Event (EventBeginDoctype, EventEndDoctype, EventBeginElement), Name) import Distribution.Package (PackageIdentifier (..)) import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import Network.AWS (Credentials (Discover), Env, Region (NorthVirginia), getEnv, send) import Network.AWS.Data (toBody) import Network.AWS.S3 (ObjectCannedACL (PublicRead), poACL, poCacheControl, poContentEncoding, poContentType, putObject) import Network.Mime (defaultMimeLookup) import Stackage.Types (simpleParse) import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.HTML.DOM (eventConduit) import Text.XML (fromEvents) upload :: (MonadResource m) => Bool -- ^ compression? -> Env -> Text -> Text -> Consumer ByteString m () upload toCompress env bucket name = do let mime = defaultMimeLookup name body <- if toCompress then compress 9 (WindowBits 31) =$= sinkLazy else sinkLazy let po = set poContentType (Just $ decodeUtf8 mime) $ (if toCompress then set poContentEncoding (Just "gzip") else id) $ set poCacheControl (Just "maxage=31536000") $ set poACL (Just PublicRead) $ putObject (toBody body) bucket name putStrLn $ "Sending " ++ name eres <- liftResourceT $ send env po case eres of Left e -> error $ show e Right _ -> return () -- | Uses 'getEnv' for S3 credentials. uploadDocs :: FilePath -- ^ directory containing docs -> FilePath -- ^ the bundle file -> Text -- ^ name of current docs, used as prefix in object names -> Text -- ^ bucket name -> IO () uploadDocs input' bundleFile name bucket = do env <- getEnv NorthVirginia Discover unlessM (F.isDirectory input') $ error $ "Could not find directory: " ++ show input' input <- fmap ( "") $ F.canonicalizePath input' let inner = sourceDirectoryDeep False input $$ mapM_C (go input name) runResourceT $ do ((), _, hoogles) <- runRWSIORefT inner (env, bucket) mempty lbs <- liftIO $ fmap Tar.write $ mapM toEntry $ toList hoogles flip runReaderT (env, bucket) $ do upload' True (name ++ "/hoogle/orig.tar") $ sourceLazy lbs upload' False (name ++ "/bundle.tar.xz") $ sourceFile bundleFile -- | Create a TAR entry for each Hoogle txt file. Unfortunately doesn't stream. toEntry :: FilePath -> IO Tar.Entry toEntry fp = do tp <- either error return $ Tar.toTarPath False $ fpToString $ F.filename fp Tar.packFileEntry (fpToString fp) tp upload' :: (MonadResource m, MonadReader (Env, Text) m) => Bool -- ^ compress? -> Text -- ^ S3 key -> Source (ResourceT IO) ByteString -> m () upload' toCompress name src = do (env, bucket) <- ask liftResourceT $ src $$ upload toCompress env bucket name isHoogleFile :: FilePath -> FilePath -> Bool isHoogleFile input fp' = fromMaybe False $ do fp <- F.stripPrefix input fp' [dir, name] <- Just $ F.splitDirectories fp pkgver <- stripSuffix "/" $ fpToText dir (fpToText -> pkg, ["txt"]) <- Just $ F.splitExtensions name PackageIdentifier pkg1 _ver <- simpleParse pkgver pkg2 <- simpleParse pkg return $ pkg1 == pkg2 go :: M m => FilePath -- ^ prefix for all input -> Text -- ^ upload name -> FilePath -- ^ current file -> m () go input name fp | isHoogleFile input fp = tell $! singletonSet fp | hasExtension fp "html" = do doc <- sourceFile fp $= eventConduit $= (do yield (Nothing, EventBeginDoctype "html" Nothing) yield (Nothing, EventEndDoctype) mapMC $ \e -> do e' <- goEvent fp toRoot e return (Nothing, e') ) $$ fromEvents -- Sink to a Document and then use blaze-html to render to avoid using -- XML rendering rules (e.g., empty elements) upload' True key $ sourceLazy (renderHtml $ toHtml doc) | any (hasExtension fp) $ words "css js png svg gif" = void $ getName fp | otherwise = upload' True key $ sourceFile fp where Just suffix = F.stripPrefix input fp toRoot = concat $ asList $ replicate (length $ F.splitDirectories suffix) $ asText "../" key = name ++ "/" ++ fpToText suffix goEvent :: M m => FilePath -- HTML file path -> Text -- ^ relative prefix to root -> Event -> m Event goEvent htmlfp toRoot (EventBeginElement name attrs) = EventBeginElement name <$> mapM (goAttr htmlfp toRoot) attrs goEvent _ _ e = return e goAttr :: M m => FilePath -- ^ HTML file path -> Text -- ^ relative prefix to root -> (Name, [Content]) -> m (Name, [Content]) goAttr htmlfp toRoot pair@(name, [ContentText value]) | isRef name && not (".html" `isSuffixOf` value) = do let fp = F.parent htmlfp fpFromText value exists <- liftIO $ F.isFile fp if exists then do x <- getName fp return (name, [ContentText $ toRoot ++ x]) else return pair goAttr _ _ pair = return pair isRef :: Name -> Bool isRef "href" = True isRef "src" = True isRef _ = False type M m = ( MonadRWS (Env, Text) (Set FilePath) (Map FilePath Text, Set Text) m , MonadResource m ) getName :: M m => FilePath -> m Text getName src = do (m, _) <- get case lookup src m of Just x -> return x Nothing -> do x <- toHash src modify $ \(m, s) -> (insertMap src x m, s) return x toHash :: M m => FilePath -> m Text toHash src = do (digest, lbs) <- sourceFile src $$ sink let hash' = decodeUtf8 $ B16.encode $ toBytes (digest :: Digest SHA256) name = fpToText $ F.addExtensions ("byhash" fpFromText hash') (F.extensions src) (m, s) <- get unless (name `member` s) $ do put (m, insertSet name s) upload' True name $ sourceLazy lbs return name where sink = getZipSink $ (,) <$> ZipSink sinkHash <*> ZipSink sinkLazy type Setter s a = (a -> Identity a) -> s -> Identity s set :: Setter s a -> a -> s -> s set l a s = runIdentity $ l (const $ Identity a) s