From 789443cb71a9f2b80acc9acc7fe71c8a406069f2 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 6 Oct 2015 07:14:29 +0300
Subject: [PATCH] Allow less downloading during dev

---
 Application.hs            |  5 +++--
 Settings.hs               |  5 ++++-
 Stackage/Database/Cron.hs | 34 +++++++++++++++++++++++-----------
 config/settings.yml       |  1 +
 4 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/Application.hs b/Application.hs
index 0d44a02..a8094a0 100644
--- a/Application.hs
+++ b/Application.hs
@@ -99,6 +99,7 @@ nicerExceptions app req send = catch (app req send) $ \e -> do
 -- performs some initialization.
 makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App
 makeFoundation useEcho conf = do
+    let extra = appExtra conf
     manager <- newManager
     s <- staticSite
 
@@ -109,7 +110,7 @@ makeFoundation useEcho conf = do
 
     gen <- MWC.createSystemRandom
 
-    websiteContent' <- if development
+    websiteContent' <- if extraDevDownload extra
         then do
             void $ rawSystem "git"
                 [ "clone"
@@ -121,7 +122,7 @@ makeFoundation useEcho conf = do
             "master"
             loadWebsiteContent
 
-    (stackageDatabase', refreshDB) <- loadFromS3 manager
+    (stackageDatabase', refreshDB) <- loadFromS3 (extraDevDownload extra) manager
 
     -- Temporary workaround to force content updates regularly, until
     -- distribution of webhooks is handled via consul
diff --git a/Settings.hs b/Settings.hs
index f5e89e3..883dc2d 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -59,7 +59,10 @@ widgetFile = (if development then widgetFileReload
               widgetFileSettings
 
 data Extra = Extra
+    { extraDevDownload :: !Bool
+    -- ^ Controls how Git and database resources are downloaded (True means less downloading)
+    }
     deriving Show
 
 parseExtra :: DefaultEnv -> Object -> Parser Extra
-parseExtra _ _ = pure Extra
+parseExtra _ o = Extra <$> o .:? "dev-download" .!= False
diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs
index 50e148a..d3cd03e 100644
--- a/Stackage/Database/Cron.hs
+++ b/Stackage/Database/Cron.hs
@@ -32,6 +32,7 @@ import qualified Data.Conduit.Binary as CB
 import           Data.Conduit.Zlib             (WindowBits (WindowBits),
                                                 compress, ungzip)
 import qualified Hoogle
+import System.Directory (doesFileExist)
 
 filename' :: Text
 filename' = concat
@@ -50,13 +51,14 @@ url = concat
     ]
 
 -- | Provides an action to be used to refresh the file from S3.
-loadFromS3 :: Manager -> IO (IO StackageDatabase, IO ())
-loadFromS3 man = do
+loadFromS3 :: Bool -- ^ devel mode? if True, won't delete old databases, and won't refresh them either
+           -> Manager -> IO (IO StackageDatabase, IO ())
+loadFromS3 develMode man = do
     killPrevVar <- newTVarIO $ return ()
     currSuffixVar <- newTVarIO (1 :: Int)
 
     let root = "stackage-database"
-    handleIO print $ removeTree root
+    unless develMode $ handleIO print $ removeTree root
     createTree root
 
     req <- parseUrl $ unpack url
@@ -67,12 +69,22 @@ loadFromS3 man = do
                 return x
 
             let fp = root </> fpFromText ("database-download-" ++ tshow suffix)
-            putStrLn $ "Downloading database to " ++ fpToText fp
-            withResponse req man $ \res ->
-                runResourceT
-                     $ bodyReaderSource (responseBody res)
-                    $= ungzip
-                    $$ sinkFile fp
+                isInitial = suffix == 1
+            toSkip <-
+                if isInitial
+                    then do
+                        putStrLn $ "Checking if database exists: " ++ tshow fp
+                        doesFileExist $ fpToString fp
+                    else return False
+            if toSkip
+                then putStrLn "Skipping initial database download"
+                else do
+                    putStrLn $ "Downloading database to " ++ fpToText fp
+                    withResponse req man $ \res ->
+                        runResourceT
+                             $ bodyReaderSource (responseBody res)
+                            $= ungzip
+                            $$ sinkFile fp
             putStrLn "Finished downloading database"
 
             return fp
@@ -81,7 +93,7 @@ loadFromS3 man = do
 
     let update = do
             fp <- download
-            db <- openStackageDatabase fp
+            db <- openStackageDatabase fp `onException` removeFile fp
             void $ tryIO $ join $ atomically $ do
                 writeTVar dbvar db
                 oldKill <- readTVar killPrevVar
@@ -93,7 +105,7 @@ loadFromS3 man = do
 
     update
 
-    return (readTVarIO dbvar, update)
+    return (readTVarIO dbvar, unless develMode update)
 
 hoogleKey :: SnapName -> Text
 hoogleKey name = concat
diff --git a/config/settings.yml b/config/settings.yml
index 323921a..0f9f452 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -5,6 +5,7 @@ Default: &defaults
 
 Development:
   <<: *defaults
+  dev-download: true
 
 Testing:
   <<: *defaults