STACKAGE_HOOGLE_LOADER

Application.hs

@@ -198,6 +198,8 @@ makeFoundation useEcho conf = do
             loadWebsiteContent
 #endif
 
+    env <- getEnvironment
+
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         mkFoundation du = App
             { settings = conf
@@ -219,13 +221,12 @@ makeFoundation useEcho conf = do
     let urlRender' = yesodRender (mkFoundation (error "docUnpacker forced")) (appRoot conf)
     docUnpacker <- newDocUnpacker
         haddockRootDir'
+        (lookup "STACKAGE_HOOGLE_LOADER" env /= Just "0")
         blobStore'
         (flip (Database.Persist.runPool dbconf) p)
         urlRender'
     let foundation = mkFoundation docUnpacker
 
-    env <- getEnvironment
-
     -- Perform database migration using our application's logging settings.
     when (lookup "STACKAGE_SKIP_MIGRATION" env /= Just "1") $
         runResourceT $

Data/Unpacking.hs

@@ -29,11 +29,12 @@ import Crypto.Hash (Digest, SHA1)
 
 newDocUnpacker
     :: FilePath -- ^ haddock root
+    -> Bool -- ^ loadHoogleDBs
     -> BlobStore StoreKey
     -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a)
     -> (Route App -> [(Text, Text)] -> Text)
     -> IO DocUnpacker
-newDocUnpacker root store runDB urlRender = do
+newDocUnpacker root loadHoogleDBs store runDB urlRender = do
     createDirs dirs
 
     statusMapVar <- newTVarIO $ asMap mempty
@@ -46,7 +47,7 @@ newDocUnpacker root store runDB urlRender = do
                        $ insertMap (stackageSlug $ entityVal ent) var
             writeTChan workChan (forceUnpack, ent, var)
 
-    forkForever $ unpackWorker dirs runDB store messageVar urlRender workChan
+    forkForever $ unpackWorker dirs loadHoogleDBs runDB store messageVar urlRender workChan
 
     return DocUnpacker
         { duRequestDocs = \ent -> do
@@ -91,13 +92,14 @@ forkForever inner = mask $ \restore ->
 
 unpackWorker
     :: Dirs
+    -> Bool -- ^ load Hoogle DBs?
     -> (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
+unpackWorker dirs loadHoogleDBs runDB store messageVar urlRender workChan = do
     atomically $ writeTVar messageVar "Waiting for new work item"
     (forceUnpack, ent, resVar) <- atomically $ readTChan workChan
     shouldUnpack <-
@@ -111,7 +113,7 @@ unpackWorker dirs runDB store messageVar urlRender workChan = do
                 , msg
                 ]
         say "Beginning of processing"
-        eres <- tryAny $ unpacker dirs runDB store say urlRender ent
+        eres <- tryAny $ unpacker dirs loadHoogleDBs runDB store say urlRender ent
         atomically $ writeTVar resVar $ case eres of
             Left e -> USFailed $ tshow e
             Right () -> USReady
@@ -121,13 +123,14 @@ removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp)
 
 unpacker
     :: Dirs
+    -> Bool -- ^ load Hoogle DBs?
     -> (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
+unpacker dirs loadHoogleDBs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage {..}) = do
     say "Removing old directories, if they exist"
     removeTreeIfExists $ dirRawIdent dirs stackageIdent
     removeTreeIfExists $ dirGzIdent dirs stackageIdent
@@ -183,8 +186,8 @@ unpacker dirs runDB store say urlRender stackageEnt@(Entity _ stackage@Stackage
                         say "Downloading compiled Hoogle database"
                         withBinaryFile (fpToString dstDefaultHoo) WriteMode
                               $ \h -> src $$ ungzip =$ sinkHandle h
-                    Nothing ->
+                    Nothing -> when loadHoogleDBs
-                      handleAny print
+                      $ handleAny print
                       $ withSystemTempDirectory "hoogle-database-gen"
                       $ \hoogletemp' -> do
                         let hoogletemp = fpFromString hoogletemp'

config/keter.yaml

@@ -5,5 +5,6 @@ stanzas:
     - production
   env:
     STACKAGE_CABAL_LOADER: "0"
+    STACKAGE_HOOGLE_LOADER: "0"
   host: www.stackage.org
 copy-to: fpuser@www.stackage.org:/var/opt/keter/incoming