From 7c94b008aa411111e2a55169ba526074379f985a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 4 Jan 2015 21:28:30 +0200 Subject: [PATCH] Persist Hoogle DBs --- Data/Unpacking.hs | 74 ++++++++++++++++++++++++++++++++--------------- Handler/Hoogle.hs | 5 ++-- Types.hs | 12 ++++++++ 3 files changed, 65 insertions(+), 26 deletions(-) diff --git a/Data/Unpacking.hs b/Data/Unpacking.hs index 1904226..b0543bb 100644 --- a/Data/Unpacking.hs +++ b/Data/Unpacking.hs @@ -2,6 +2,7 @@ -- and compressing/deduping contents. module Data.Unpacking ( newDocUnpacker + , defaultHooDest ) where import Import hiding (runDB) @@ -11,18 +12,17 @@ import Filesystem (createTree, isFile, removeTree, isDirectory, listDirectory, c import System.Posix.Files (createLink) import Crypto.Hash.Conduit (sinkHash) import Control.Concurrent (forkIO) -import Control.Monad.Trans.Resource (allocate, resourceForkIO, release) +import Control.Monad.Trans.Resource (allocate, release) import Data.Char (isAlpha) import qualified Hoogle import qualified Data.Text as T import qualified Data.Yaml as Y import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile, openBinaryFile) -import System.IO.Temp (withSystemTempFile, withTempFile, createTempDirectory, withSystemTempDirectory) -import System.Directory (getTemporaryDirectory) +import System.IO.Temp (withSystemTempFile, withTempFile, withSystemTempDirectory) 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 Data.Conduit.Zlib (gzip, ungzip) import qualified Data.ByteString.Base16 as B16 import Data.Byteable (toBytes) import Crypto.Hash (Digest, SHA1) @@ -46,7 +46,7 @@ newDocUnpacker root store runDB urlRender = do $ insertMap (stackageSlug $ entityVal ent) var writeTChan workChan (forceUnpack, ent, var) - forkForever $ unpackWorker dirs runDB store statusMapVar messageVar urlRender workChan + forkForever $ unpackWorker dirs runDB store messageVar urlRender workChan return DocUnpacker { duRequestDocs = \ent -> do @@ -82,13 +82,22 @@ isUnpacked :: Dirs -> Entity Stackage -> IO Bool isUnpacked dirs (Entity _ stackage) = isFile $ defaultHooDest dirs stackage defaultHooDest :: Dirs -> Stackage -> FilePath -defaultHooDest dirs stackage = dirHoogleFp dirs (stackageIdent stackage) ["default.hoo"] +defaultHooDest dirs stackage = dirHoogleFp dirs (stackageIdent stackage) + ["default-" ++ VERSION_hoogle ++ ".hoo"] forkForever :: IO () -> IO () forkForever inner = mask $ \restore -> void $ forkIO $ forever $ handleAny print $ restore $ forever inner -unpackWorker dirs runDB store statusMapVar messageVar urlRender workChan = do +unpackWorker + :: Dirs + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> BlobStore StoreKey + -> TVar Text + -> (Route App -> [(Text, Text)] -> Text) + -> TChan (Bool, Entity Stackage, TVar UnpackStatus) + -> IO () +unpackWorker dirs runDB store messageVar urlRender workChan = do atomically $ writeTVar messageVar "Waiting for new work item" (forceUnpack, ent, resVar) <- atomically $ readTChan workChan shouldUnpack <- @@ -110,6 +119,14 @@ unpackWorker dirs runDB store statusMapVar messageVar urlRender workChan = do removeTreeIfExists :: FilePath -> IO () removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp) +unpacker + :: Dirs + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> BlobStore StoreKey + -> (Text -> IO ()) + -> (Route App -> [(Text, Text)] -> Text) + -> Entity Stackage + -> IO () unpacker dirs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage {..}) = do say "Removing old directories, if they exist" removeTreeIfExists $ dirRawIdent dirs stackageIdent @@ -135,7 +152,6 @@ unpacker dirs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage if ec == ExitSuccess then return () else throwM ec createTree $ dirHoogleIdent dirs stackageIdent - tmp <- getTemporaryDirectory -- Determine which packages have documentation and update the -- database appropriately @@ -155,24 +171,35 @@ unpacker dirs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage [PackageHasHaddocks =. True] ) - let defaultHoo = destdir "default.hoo" - defaultHooExists <- isFile defaultHoo + let srcDefaultHoo = destdir "default.hoo" + dstDefaultHoo = defaultHooDest dirs stackage + hoogleKey = HoogleDB stackageIdent $ HoogleVersion VERSION_hoogle + defaultHooExists <- isFile srcDefaultHoo 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 + then copyFile srcDefaultHoo dstDefaultHoo + else withAcquire (storeRead' store hoogleKey) $ \msrc -> + case msrc of + Just src -> do + say "Downloading compiled Hoogle database" + withBinaryFile (fpToString dstDefaultHoo) WriteMode + $ \h -> src $$ ungzip =$ sinkHandle h + Nothing -> + 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 + say "Uploading database to persistent storage" + withAcquire (storeWrite' store hoogleKey) $ \sink -> + runResourceT $ sourceFile dstDefaultHoo $$ gzip =$ sink runCompressor say dirs -isHoogleActive :: Bool -isHoogleActive = False - runCompressor :: (Text -> IO ()) -> Dirs -> IO () runCompressor say dirs = runResourceT $ goDir $ dirRawRoot dirs @@ -258,8 +285,7 @@ createHoogleDb :: (Text -> IO ()) -> (Route App -> [(Text, Text)] -> Text) -> IO () createHoogleDb say dirs (Entity _ stackage) errorLog tmpdir urlRender = do - let ident = stackageIdent stackage - tmpbin = tmpdir "binary" + let tmpbin = tmpdir "binary" createTree tmpbin eres <- tryAny $ runResourceT $ do -- Create hoogle binary databases for each package. diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 9d18a43..58d559d 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -6,8 +6,9 @@ import Control.Spoon (spoon) import Data.Data (Data (..)) import Data.Slug (SnapSlug) import Data.Text.Read (decimal) +import Data.Unpacking (defaultHooDest) import Filesystem (isFile) -import Handler.Haddock (dirHoogleFp, getDirs) +import Handler.Haddock (getDirs) import qualified Hoogle import Import import Text.Blaze.Html (preEscapedToHtml) @@ -31,7 +32,7 @@ getHoogleR slug = do stackageEnt@(Entity _ stackage) <- runDB $ getBy404 $ UniqueSnapshot slug -- Unpack haddocks and generate hoogle DB, if necessary. requireDocs stackageEnt - let databasePath = dirHoogleFp dirs (stackageIdent stackage) ["default.hoo"] + let databasePath = defaultHooDest dirs stackage heDatabase = liftIO $ Hoogle.loadDatabase (fpToString databasePath) -- If the hoogle DB isn't yet generated, yield 404. dbExists <- liftIO $ isFile databasePath diff --git a/Types.hs b/Types.hs index f2647dc..8072fbd 100644 --- a/Types.hs +++ b/Types.hs @@ -58,8 +58,14 @@ data StoreKey = HackageCabal !PackageName !Version | HackageViewIndex !HackageView | SnapshotBundle !PackageSetIdent | HaddockBundle !PackageSetIdent + | HoogleDB !PackageSetIdent !HoogleVersion deriving (Show, Eq, Ord, Typeable) +newtype HoogleVersion = HoogleVersion Text + deriving (Show, Eq, Ord, Typeable, PathPiece) +currentHoogleVersion :: HoogleVersion +currentHoogleVersion = HoogleVersion VERSION_hoogle + instance ToPath StoreKey where toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"] toPath (HackageSdist name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".tar.gz"] @@ -95,6 +101,11 @@ instance ToPath StoreKey where [ "haddock" , toPathPiece ident ++ ".tar.xz" ] + toPath (HoogleDB ident ver) = + [ "hoogle" + , toPathPiece ver + , toPathPiece ident ++ ".hoo.gz" + ] instance BackupToS3 StoreKey where shouldBackup HackageCabal{} = False shouldBackup HackageSdist{} = False @@ -105,6 +116,7 @@ instance BackupToS3 StoreKey where shouldBackup HackageViewIndex{} = False shouldBackup SnapshotBundle{} = True shouldBackup HaddockBundle{} = True + shouldBackup HoogleDB{} = True newtype HackageRoot = HackageRoot { unHackageRoot :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)