Browse Source

Allow less downloading during dev

zudov-ghc-7.10
Michael Snoyman 6 years ago
parent
commit
789443cb71
  1. 5
      Application.hs
  2. 5
      Settings.hs
  3. 34
      Stackage/Database/Cron.hs
  4. 1
      config/settings.yml

5
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

5
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

34
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

1
config/settings.yml

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

Loading…
Cancel
Save