yesod devel leverages SQLite for simplicity

package.yaml

@@ -79,6 +79,7 @@ dependencies:
 - classy-prelude-conduit
 - path-pieces
 - persistent-postgresql
+- persistent-sqlite
 - filepath
 - http-client
 - http-types

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

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

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")

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