From 08ab874ae9324e6a1a54efe8998130e1747d27bf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 4 Jan 2015 18:44:40 +0200 Subject: [PATCH] Turn compressing back on, temporarily disable Hoogle generation --- Data/Unpacking.hs | 102 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 87 insertions(+), 15 deletions(-) diff --git a/Data/Unpacking.hs b/Data/Unpacking.hs index c856e27..1904226 100644 --- a/Data/Unpacking.hs +++ b/Data/Unpacking.hs @@ -7,7 +7,9 @@ module Data.Unpacking import Import hiding (runDB) import Data.BlobStore import Handler.Haddock -import Filesystem (createTree, isFile, removeTree, isDirectory, listDirectory) +import Filesystem (createTree, isFile, removeTree, isDirectory, listDirectory, copyFile, removeDirectory, removeFile, rename) +import System.Posix.Files (createLink) +import Crypto.Hash.Conduit (sinkHash) import Control.Concurrent (forkIO) import Control.Monad.Trans.Resource (allocate, resourceForkIO, release) import Data.Char (isAlpha) @@ -19,6 +21,11 @@ import System.IO.Temp (withSystemTempFile, withTempFile, createTempDirectory, wi import System.Directory (getTemporaryDirectory) import System.Exit (ExitCode (ExitSuccess)) import System.Process (createProcess, proc, cwd, waitForProcess) +import qualified Filesystem.Path.CurrentOS as F +import Data.Conduit.Zlib (gzip) +import qualified Data.ByteString.Base16 as B16 +import Data.Byteable (toBytes) +import Crypto.Hash (Digest, SHA1) newDocUnpacker :: FilePath -- ^ haddock root @@ -72,10 +79,10 @@ createDirs dirs = do -- | Check for the presence of file system artifacts indicating that the docs -- have been unpacked. isUnpacked :: Dirs -> Entity Stackage -> IO Bool -isUnpacked dirs (Entity _ stackage) = - isFile databasePath - where - databasePath = dirHoogleFp dirs (stackageIdent stackage) ["default.hoo"] +isUnpacked dirs (Entity _ stackage) = isFile $ defaultHooDest dirs stackage + +defaultHooDest :: Dirs -> Stackage -> FilePath +defaultHooDest dirs stackage = dirHoogleFp dirs (stackageIdent stackage) ["default.hoo"] forkForever :: IO () -> IO () forkForever inner = mask $ \restore -> @@ -103,7 +110,7 @@ unpackWorker dirs runDB store statusMapVar messageVar urlRender workChan = do removeTreeIfExists :: FilePath -> IO () removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp) -unpacker dirs runDB store say urlRender stackageEnt@(Entity _ Stackage {..}) = do +unpacker dirs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage {..}) = do say "Removing old directories, if they exist" removeTreeIfExists $ dirRawIdent dirs stackageIdent removeTreeIfExists $ dirGzIdent dirs stackageIdent @@ -148,14 +155,79 @@ unpacker dirs runDB store say urlRender stackageEnt@(Entity _ Stackage {..}) = d [PackageHasHaddocks =. True] ) - withSystemTempDirectory "hoogle-database-gen" $ \hoogletemp' -> do - let hoogletemp = fpFromString hoogletemp' - logFp = fpToString (dirHoogleFp dirs stackageIdent ["error-log"]) - withBinaryFile logFp WriteMode $ \errorLog -> do - say "Copying Hoogle text files to temp directory" - runResourceT $ copyHoogleTextFiles errorLog destdir hoogletemp - say "Creating Hoogle database" - createHoogleDb say dirs stackageEnt errorLog hoogletemp urlRender + let defaultHoo = destdir "default.hoo" + defaultHooExists <- isFile defaultHoo + if defaultHooExists + then copyFile defaultHoo $ defaultHooDest dirs stackage + else when isHoogleActive $ handleAny print $ withSystemTempDirectory "hoogle-database-gen" $ \hoogletemp' -> do + let hoogletemp = fpFromString hoogletemp' + logFp = fpToString (dirHoogleFp dirs stackageIdent ["error-log"]) + withBinaryFile logFp WriteMode $ \errorLog -> do + say "Copying Hoogle text files to temp directory" + runResourceT $ copyHoogleTextFiles errorLog destdir hoogletemp + say "Creating Hoogle database" + createHoogleDb say dirs stackageEnt errorLog hoogletemp urlRender + + runCompressor say dirs + +isHoogleActive :: Bool +isHoogleActive = False + +runCompressor :: (Text -> IO ()) -> Dirs -> IO () +runCompressor say dirs = + runResourceT $ goDir $ dirRawRoot dirs + where + goDir dir = do + liftIO $ say $ "Compressing directory: " ++ fpToText dir + sourceDirectory dir $$ mapM_C goFP + liftIO $ void $ tryIO $ removeDirectory dir + + goFP fp = do + e <- liftIO $ isFile fp + if e + then liftIO $ do + liftIO $ say $ "Compressing file: " ++ fpToText fp + handle (print . asSomeException) + $ gzipHash dirs suffix + else goDir fp + where + Just suffix = F.stripPrefix (dirRawRoot dirs "") fp + +-- Procedure is to: +-- +-- * Gzip the src file to a temp file, and get a hash of the gzipped contents +-- * If that hash doesn't exist in the cache, move the new file to the cache +-- * Create a hard link from dst to the file in the cache +-- * Delete src +gzipHash :: Dirs + -> FilePath -- ^ suffix + -> IO () +gzipHash dirs suffix = do + withTempFile (fpToString $ dirCacheRoot dirs) "haddock-file.gz" $ \tempfp temph -> do + digest <- withBinaryFile (fpToString src) ReadMode $ \inh -> + sourceHandle inh + $= gzip + $$ (getZipSink $ + ZipSink (sinkHandle temph) *> + ZipSink sinkHash) + hClose temph + let fpcache = dirCacheFp dirs digest + unlessM (isFile fpcache) $ do + createTree $ F.parent fpcache + rename (fpFromString tempfp) fpcache + createTree $ F.parent dst + createLink (fpToString fpcache) (fpToString dst) + removeFile src + where + src = dirRawRoot dirs suffix + dst = dirGzRoot dirs suffix + +dirCacheFp :: Dirs -> Digest SHA1 -> FilePath +dirCacheFp dirs digest = + dirCacheRoot dirs fpFromText x fpFromText y <.> "gz" + where + name = decodeUtf8 $ B16.encode $ toBytes digest + (x, y) = splitAt 2 name copyHoogleTextFiles :: Handle -- ^ error log handle -> FilePath -- ^ raw unpacked Haddock files @@ -232,7 +304,7 @@ createHoogleDb say dirs (Entity _ stackage) errorLog tmpdir urlRender = do dbs <- listDirectory tmpbin Hoogle.mergeDatabase (map fpToString dbs) - (fpToString (dirHoogleFp dirs ident ["default.hoo"])) + (fpToString $ defaultHooDest dirs stackage) case eres of Right () -> return () Left err -> liftIO $ appendHoogleErrors errorLog $ HoogleErrors