Allow overriding database with BABEL_DATABASE env var.

Author: srhoulam

app/Main.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Main (main) where
 
-import Application
-import Import
-import Import.Main
-import RIO.Process
-import Options.Applicative.Simple
+import           Application
+import           Import
+import           Import.Main
+import           Options.Applicative.Simple
 import qualified Paths_babel_cards
-import System.Environment.XDG.BaseDir
+import           RIO.Process
 
 main :: IO ()
 main = do
@@ -25,19 +24,18 @@ main = do
 
   lo <- logOptionsHandle stderr (optionsVerbose options)
   pc <- mkDefaultProcessContext
-  settings <- loadSettings
+  dbSettings <- loadSettings
   config <- loadConfig
   rngTV <- newTFGen >>= newTVarIO
-  dataDir <- getUserDataDir "babel-cards"
-  connPool <- createConnPool dataDir settings
+  connPool <- createConnPool dbSettings
   withLogFunc lo $ \lf ->
     let babel = Babel
           { bLogFunc = lf
           , bProcessContext = pc
           , bOptions = options
           , bRNG = rngTV
           , bConfig = config
-          , bEmbeddedSettings = settings
+          , bDatabaseSettings = dbSettings
           , bConnPool = connPool
           }
      in runRIO babel bootstrapBabel

babel-cards.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.0.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9fde3af3248564b38705619462ce38aca0340fe72457770b3ee367564ef4e1c4
+-- hash: 8a344dcc26aef96c7290cf75ca42ad8bcfb97dbaef4eed426e446c9ea3d8be76
 
 name:           babel-cards
 version:        0.1.0
@@ -78,6 +78,7 @@ library
     , tf-random
     , transformers
     , vty
+    , xdg-basedir
     , yaml
   default-language: Haskell2010
 
@@ -93,5 +94,4 @@ executable babel-cards
     , base >=4.11 && <10
     , optparse-simple
     , rio >=0.1.12.0
-    , xdg-basedir
   default-language: Haskell2010

package.yaml

@@ -72,6 +72,7 @@ library:
   - tf-random
   - transformers
   - vty
+  - xdg-basedir
   - yaml
 
 executables:
@@ -81,7 +82,6 @@ executables:
     dependencies:
     - babel-cards
     - optparse-simple
-    - xdg-basedir
     ghc-options:
     - -threaded
     - -rtsopts

src/Application.hs

@@ -2,11 +2,11 @@
 module Application (bootstrapBabel) where
 
 import           Application.Database
-import           Database.Persist.Sql   (runMigration)
+import           Database.Persist.Sql (runMigration)
 -- import           Model
+import           Application.TUI      (lifecycle)
 import           RIO
 import           Types
-import Application.TUI (lifecycle)
 
 bootstrapBabel :: RIO Babel ()
 bootstrapBabel = do

src/Import/Main.hs

@@ -5,29 +5,26 @@ import           Database.Persist.Sql    (ConnectionPool)
 import           Database.Persist.Sqlite (SqliteConf (..), createSqlitePool,
                                           createSqlitePoolFromInfo,
                                           sqlConnectionStr)
-
 import           Import
 import           Settings                as Import.Main (loadSettings)
 import           System.Directory        (createDirectoryIfMissing)
 import           System.Environment
 import           System.FilePath.Posix
 import           System.Random.TF.Init   as Import.Main (newTFGen)
 import           Util.String             (mapText)
+import           System.Environment.XDG.BaseDir (getUserDataDir)
 
-createConnPool :: FilePath -> BabelEmbeddedSettings -> IO ConnectionPool
-createConnPool dataDir' settings = do
-  dataDir <- ensureDataDirExists dataDir'
-  runNoLoggingT $ case besDatabase settings of
-    SqliteConf connStr poolSize ->
-      createSqlitePool (mapText (dataDir </>) connStr) poolSize
-    SqliteConfInfo confInfo poolSize -> createSqlitePoolFromInfo
-      (over sqlConnectionStr (mapText (dataDir </>)) confInfo)
-      poolSize
+createConnPool :: SqliteConf -> IO ConnectionPool
+createConnPool settings = do
+  ensureDataDirExists
+  runNoLoggingT $ case settings of
+    -- SqliteConf connStr poolSize ->
+    --   createSqlitePool (mapText (dataDir </>) connStr) poolSize
+    info@(SqliteConfInfo connInfo poolSize) -> createSqlitePoolFromInfo connInfo poolSize
 
-ensureDataDirExists :: FilePath -> IO FilePath
-ensureDataDirExists dataDir =
-  createDirectoryIfMissing True dataDir
-  >> return dataDir
+ensureDataDirExists :: IO ()
+ensureDataDirExists =
+  getUserDataDir "babel-cards" >>= createDirectoryIfMissing True
 
 loadConfig :: IO BabelConfig
 loadConfig = do

src/Settings.hs

@@ -1,13 +1,24 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Settings where
 
-import Data.ByteString
-import Data.FileEmbed
-import Data.Yaml
-import Types
+import           Data.Maybe                     (fromMaybe)
+import qualified Data.Text                      as Text (pack)
+import           Database.Persist.Sqlite        (SqliteConf (..), fkEnabled,
+                                                 mkSqliteConnectionInfo,
+                                                 walEnabled)
+import           Lens.Micro
+import           System.Environment             (lookupEnv)
+import           System.Environment.XDG.BaseDir (getUserDataDir)
+import           System.FilePath.Posix
 
-loadSettings :: IO BabelEmbeddedSettings
-loadSettings = decodeThrow embeddedSettings
-
-embeddedSettings :: ByteString
-embeddedSettings = $(embedFile "config/settings.yaml")
+loadSettings :: IO SqliteConf
+loadSettings = do
+  dbOverride <- lookupEnv "BABEL_DATABASE"
+  userDataDir <- getUserDataDir "babel-cards"
+  let dbPath = fromMaybe
+        (userDataDir </> "babel-cards.sqlite")
+        dbOverride
+      connString = mkSqliteConnectionInfo (Text.pack dbPath)
+        & walEnabled .~ True
+        & fkEnabled .~ True
+  return $ SqliteConfInfo connString 1

src/Types.hs

@@ -28,19 +28,14 @@ data Babel = Babel
   , bConnPool         :: !ConnectionPool
   , bRNG              :: !(TVar TFGen)
   , bConfig           :: !BabelConfig
-  , bEmbeddedSettings :: !BabelEmbeddedSettings
+  , bDatabaseSettings :: !SqliteConf
   }
 
 data BabelConfig = BabelConfig
   { bcMaxInterval :: !NominalDiffTime
   , bcMinInterval :: !NominalDiffTime
   }
 
-data BabelEmbeddedSettings = BabelEmbeddedSettings
-  { besDatabase    :: !SqliteConf
-  } deriving Generic
-
-$(deriveFromJSON defaultOptions { fieldLabelModifier = decapitalize . drop 3 } 'BabelEmbeddedSettings)
 $(deriveJSON defaultOptions { fieldLabelModifier = decapitalize . drop 2} 'BabelConfig)
 
 instance HasLogFunc Babel where