From 3b8e3f596bd418848f423164f893110a00983334 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 4 Jan 2015 21:38:57 +0200
Subject: [PATCH] STACKAGE_HOOGLE_LOADER

---
 Application.hs    |  5 +++--
 Data/Unpacking.hs | 17 ++++++++++-------
 config/keter.yaml |  1 +
 3 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/Application.hs b/Application.hs
index 60584b1..117916e 100644
--- a/Application.hs
+++ b/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 $
diff --git a/Data/Unpacking.hs b/Data/Unpacking.hs
index b0543bb..673fcfa 100644
--- a/Data/Unpacking.hs
+++ b/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 ->
-                      handleAny print
+                    Nothing -> when loadHoogleDBs
+                      $ handleAny print
                       $ withSystemTempDirectory "hoogle-database-gen"
                       $ \hoogletemp' -> do
                         let hoogletemp = fpFromString hoogletemp'
diff --git a/config/keter.yaml b/config/keter.yaml
index be96820..12dcfc2 100644
--- a/config/keter.yaml
+++ b/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