Allow less downloading during dev

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

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

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 :: Bool -- ^ devel mode? if True, won't delete old databases, and won't refresh them either
-loadFromS3 man = do
+           -> 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
+                isInitial = suffix == 1
-            withResponse req man $ \res ->
+            toSkip <-
-                runResourceT
+                if isInitial
-                     $ bodyReaderSource (responseBody res)
+                    then do
-                    $= ungzip
+                        putStrLn $ "Checking if database exists: " ++ tshow fp
-                    $$ sinkFile 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

config/settings.yml

@@ -5,6 +5,7 @@ Default: &defaults
 
 Development:
   <<: *defaults
+  dev-download: true
 
 Testing:
   <<: *defaults