diff --git a/package.yaml b/package.yaml index b86da32..3d0c1bf 100644 --- a/package.yaml +++ b/package.yaml @@ -79,6 +79,7 @@ dependencies: - classy-prelude-conduit - path-pieces - persistent-postgresql +- persistent-sqlite - filepath - http-client - http-types diff --git a/src/Application.hs b/src/Application.hs index 4b7b74c..0818f45 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -26,7 +26,6 @@ import Control.AutoUpdate import Control.Concurrent (threadDelay) import Control.Monad.Logger (liftLoc) import Data.WebsiteContent -import Database.Persist.Postgresql (PostgresConf(..)) import Import hiding (catch) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware, rawPathInfo, pathInfo, responseBuilder) @@ -140,18 +139,14 @@ withFoundation appLogFunc appSettings inner = do fp <- runSimpleApp $ getStackageContentDir "." gitRepoDev fp loadWebsiteContent else gitRepo "https://github.com/fpco/stackage-content.git" "master" loadWebsiteContent - let pgConf = - PostgresConf {pgPoolSize = appPostgresPoolsize appSettings, pgConnStr = encodeUtf8 $ appPostgresString appSettings} - -- Temporary workaround to force content updates regularly, until - -- distribution of webhooks is handled via consul - runContentUpdates = + let runContentUpdates = Concurrently $ forever $ void $ do threadDelay $ 1000 * 1000 * 60 * 5 handleAny (runRIO appLogFunc . RIO.logError . fromString . displayException) $ grRefresh appWebsiteContent - withStackageDatabase (appShouldLogAll appSettings) pgConf $ \appStackageDatabase -> do + withStackageDatabase (appShouldLogAll appSettings) (appDatabase appSettings) $ \appStackageDatabase -> do appLatestStackMatcher <- mkAutoUpdateWithModify defaultUpdateSettings diff --git a/src/Settings.hs b/src/Settings.hs index 6fe9a3f..976c5e2 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -12,7 +12,7 @@ module Settings where import ClassyPrelude.Yesod import Data.Aeson (Result(..), fromJSON, withObject, (.!=), (.:?)) import Data.FileEmbed (embedFile) -import Data.Yaml (decodeEither') +import Data.Yaml (decodeEither', Parser) import Data.Yaml.Config import Language.Haskell.TH.Syntax (Exp, Name, Q) import Network.Wai.Handler.Warp (HostPreference) @@ -37,10 +37,7 @@ data AppSettings = AppSettings , appIpFromHeader :: Bool -- ^ Get the IP address from the header when logging. Useful when sitting -- behind a reverse proxy. - , appPostgresString :: !Text - -- ^ PostgreSQL connection string - , appPostgresPoolsize :: !Int - -- ^ PostgreSQL poolsize + , appDatabase :: !DatabaseSettings , appDetailedRequestLogging :: Bool -- ^ Use detailed request logging system @@ -58,6 +55,27 @@ data AppSettings = AppSettings -- ^ Controls how Git and database resources are downloaded (True means less downloading) } +data DatabaseSettings + = DSPostgres !Text !Int + | DSSqlite !Text !Int + +parseDatabase + :: Bool -- ^ is this dev? if so, allow default of SQLite + -> HashMap Text Value + -> Parser DatabaseSettings +parseDatabase isDev o = + if isDev + then postgres + else sqlite <|> postgres + where + postgres = DSPostgres + <$> o .: "postgres-string" + <*> o .: "postgres-poolsize" + + sqlite = do + True <- o .: "sqlite" + pure $ DSSqlite "test.sqlite3" 1 + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -72,11 +90,11 @@ instance FromJSON AppSettings where appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" - appPostgresString <- o .: "postgres-string" - appPostgresPoolsize <- o .: "postgres-poolsize" dev <- o .:? "development" .!= defaultDev + appDatabase <- if dev then pure (DSSqlite "test.sqlite3" 7) else parseDatabase dev o + appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev appShouldLogAll <- o .:? "should-log-all" .!= dev appReloadTemplates <- o .:? "reload-templates" .!= dev diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index d85a3e5..fb0227b 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -60,7 +60,6 @@ import Stackage.Database.PackageInfo import Stackage.Database.Query import Stackage.Database.Schema import Stackage.Database.Types -import System.Environment (lookupEnv) import UnliftIO.Concurrent (getNumCapabilities) import Web.PathPieces (fromPathPiece, toPathPiece) import qualified Control.Retry as Retry @@ -87,17 +86,10 @@ hoogleUrl n = T.concat hackageDeprecatedUrl :: Request hackageDeprecatedUrl = "https://hackage.haskell.org/packages/deprecated.json" -withStorage :: Int -> (Storage -> IO a) -> IO a -withStorage poolSize inner = do - connstr <- - lookupEnv "PGSTRING" >>= \case - Just connstr -> pure (T.pack connstr) - Nothing -> appPostgresString <$> getAppSettings - withStackageDatabase - False - PostgresConf {pgPoolSize = poolSize, pgConnStr = encodeUtf8 connstr} - (\ db -> inner (Storage (runDatabase db) id)) - +withStorage :: (Storage -> IO a) -> IO a +withStorage inner = do + as <- getAppSettings + withStackageDatabase False (appDatabase as) (\db -> inner (Storage (runDatabase db) id)) getStackageSnapshotsDir :: RIO StackageCron FilePath getStackageSnapshotsDir = do @@ -162,7 +154,7 @@ stackageServerCron StackageCronOptions {..} = do catchIO (bindPortTCP 17834 "127.0.0.1") $ const $ throwString "Stackage Cron loader process already running, exiting." connectionCount <- getNumCapabilities - withStorage connectionCount $ \storage -> do + withStorage $ \storage -> do lo <- logOptionsHandle stdout True stackageRootDir <- getAppUserDataDirectory "stackage" pantryRootDir <- parseAbsDir (stackageRootDir "pantry") diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index c7dd4f9..9d89587 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -48,11 +48,12 @@ module Stackage.Database.Schema , module PS ) where -import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT) +import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT, MonadLogger) import qualified Data.Aeson as A -import Data.Pool (destroyAllResources) +import Data.Pool (destroyAllResources, Pool) import Database.Persist import Database.Persist.Postgresql +import Database.Persist.Sqlite (createSqlitePool) import Database.Persist.TH import Pantry (HasPantryConfig(..), Revision, parseVersionThrowing) import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId, @@ -64,6 +65,7 @@ import qualified Pantry.Internal.Stackage as Pantry (migrateAll) import RIO import RIO.Time import Types (CompilerP(..), FlagNameP, Origin, SnapName, VersionRangeP) +import Settings (DatabaseSettings (..)) currentSchema :: Int currentSchema = 1 @@ -190,16 +192,26 @@ run inner = do runRIO logFunc $ runDatabase stackageDatabase inner -withStackageDatabase :: MonadUnliftIO m => Bool -> PostgresConf -> (StackageDatabase -> m a) -> m a -withStackageDatabase shouldLog pg inner = do - let getPoolIO = +withStackageDatabase :: MonadUnliftIO m => Bool -> DatabaseSettings -> (StackageDatabase -> m a) -> m a +withStackageDatabase shouldLog dbs inner = do + let makePool :: (MonadUnliftIO m, MonadLogger m) => m (Pool SqlBackend) + makePool = + case dbs of + DSPostgres connStr size -> createPostgresqlPool (encodeUtf8 connStr) size + DSSqlite connStr size -> do + pool <- createSqlitePool connStr size + runSqlPool (do + runMigration Pantry.migrateAll + runMigration migrateAll + ) pool + pure pool + getPoolIO = if shouldLog - then runStdoutLoggingT $ createPostgresqlPool (pgConnStr pg) (pgPoolSize pg) - else runNoLoggingT $ createPostgresqlPool (pgConnStr pg) (pgPoolSize pg) - bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool -> + then runStdoutLoggingT makePool + else runNoLoggingT makePool + bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool -> do inner (StackageDatabase (`runSqlPool` pool)) - getSchema :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env (Maybe Int) getSchema = run $ do