Persist Hoogle DBs

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.

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

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)