diff --git a/Application.hs b/Application.hs index a4924a4..3c84b81 100644 --- a/Application.hs +++ b/Application.hs @@ -33,6 +33,8 @@ import Yesod.Core.Types (loggerSet, Logger (Logger)) import Yesod.Default.Config import Yesod.Default.Handlers import Yesod.Default.Main +import System.Environment (getEnvironment) +import Data.BlobStore (HasBlobStore) import qualified Echo @@ -166,6 +168,12 @@ makeFoundation useEcho conf = do (Database.Persist.runPool dbconf (runMigration migrateAll) p) (messageLoggerSource foundation logger) + env <- getEnvironment + let loadCabalFiles' = + case lookup "STACKAGE_CABAL_LOADER" env of + Just "0" -> return () + _ -> appLoadCabalFiles foundation dbconf p + -- Start the cabal file loader ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do $logInfoS "CLEANUP" "Cleaning up /tmp" @@ -173,38 +181,8 @@ makeFoundation useEcho conf = do runResourceT $ sourceDirectory "/tmp" $$ mapM_C (cleanupTemp now) $logInfoS "CLEANUP" "Cleaning up complete" - --when development $ liftIO $ threadDelay $ 5 * 60 * 1000000 - eres <- tryAny $ flip runReaderT foundation $ do - let runDB' :: SqlPersistT (ResourceT (ReaderT App (LoggingT IO))) a - -> ReaderT App (LoggingT IO) a - runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p - uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory - let toMDPair (E.Value name, E.Value version, E.Value hash') = - (name, (version, hash')) - metadata0 <- fmap (mapFromList . map toMDPair) - $ runDB' $ E.select $ E.from $ \m -> return - ( m E.^. MetadataName - , m E.^. MetadataVersion - , m E.^. MetadataHash - ) - UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0 - runDB' $ mapM_ insert_ newUploads - runDB' $ forM_ newMD $ \x -> do - deleteBy $ UniqueMetadata $ metadataName x - insert_ x - let views = - [ ("pvp", viewPVP uploadHistory) - , ("no-bounds", viewNoBounds) - , ("unchanged", viewUnchanged) - ] - forM_ views $ \(name, func) -> runResourceT $ createView - name - func - (sourceHistory uploadHistory) - (storeWrite $ HackageViewIndex name) - case eres of - Left e -> $logError $ tshow e - Right () -> return () + loadCabalFiles' + liftIO $ threadDelay $ 30 * 60 * 1000000 return foundation where ifRunCabalLoader m = @@ -212,6 +190,49 @@ makeFoundation useEcho conf = do then void m else return () +appLoadCabalFiles :: ( PersistConfig c + , PersistConfigBackend c ~ SqlPersistT + , HasHackageRoot env + , HasBlobStore env StoreKey + , HasHttpManager env + ) + => env + -> c + -> PersistConfigPool c + -> LoggingT IO () +appLoadCabalFiles env dbconf p = do + eres <- tryAny $ flip runReaderT env $ do + let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a + -> ReaderT env (LoggingT IO) a + runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p + uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory + let toMDPair (E.Value name, E.Value version, E.Value hash') = + (name, (version, hash')) + metadata0 <- fmap (mapFromList . map toMDPair) + $ runDB' $ E.select $ E.from $ \m -> return + ( m E.^. MetadataName + , m E.^. MetadataVersion + , m E.^. MetadataHash + ) + UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0 + runDB' $ mapM_ insert_ newUploads + runDB' $ forM_ newMD $ \x -> do + deleteBy $ UniqueMetadata $ metadataName x + insert_ x + let views = + [ ("pvp", viewPVP uploadHistory) + , ("no-bounds", viewNoBounds) + , ("unchanged", viewUnchanged) + ] + forM_ views $ \(name, func) -> runResourceT $ createView + name + func + (sourceHistory uploadHistory) + (storeWrite $ HackageViewIndex name) + case eres of + Left e -> $logError $ tshow e + Right () -> return () + cleanupTemp :: UTCTime -> FilePath -> ResourceT (LoggingT IO) () cleanupTemp now fp | any (`isPrefixOf` name) prefixes = handleAny ($logError . tshow) $ do diff --git a/config/keter.yaml b/config/keter.yaml index 21c3b8a..723ba55 100644 --- a/config/keter.yaml +++ b/config/keter.yaml @@ -1,6 +1,8 @@ exec: ../dist/build/stackage-server/stackage-server args: - production +env: + STACKAGE_CABAL_LOADER: 0 host: www.stackage.org redirects: