From 68e4ce36ca9c7678492882c8518bca5dc87abb42 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 11 Dec 2022 18:53:54 -0500
Subject: [PATCH] ADD type for database configuration

---
 app/Main.hs                  |  6 ++++--
 lib/Internal/Config.hs       |  1 +
 lib/Internal/Database/Ops.hs | 22 ++++++++++++----------
 lib/Internal/Types.hs        |  5 +++++
 4 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 25ff80b..8a80d47 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -88,7 +88,9 @@ sync = flag' Sync
   )
 
 parse :: Options -> IO ()
-parse (Options _ Reset)           = migrate_ nukeTables
+parse (Options c Reset)           = do
+  config <- readConfig c
+  migrate_ (sqlConfig config) nukeTables
 parse (Options c DumpAccounts)    = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies)  = runDumpCurrencies c
@@ -141,7 +143,7 @@ runDumpAccountKeys c = do
 runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  migrate_ $ do
+  migrate_ (sqlConfig config) $ do
     s <- getDBState config
     flip runReaderT (s $ takeDirectory c) $ do
       insertBudget $ budget config
diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs
index 00f1408..985cc07 100644
--- a/lib/Internal/Config.hs
+++ b/lib/Internal/Config.hs
@@ -66,6 +66,7 @@ typeSubs = firstOrder ++ higherOrder
       , toVar (auto :: Decoder SplitNum)
       , toVar (auto :: Decoder MatchDesc)
       , toVar (auto :: Decoder MatchOther)
+      , toVar (auto :: Decoder SqlConfig)
       ]
 
 readYaml :: FromJSON a => FilePath -> IO a
diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs
index d7f74a6..a9d51fa 100644
--- a/lib/Internal/Database/Ops.hs
+++ b/lib/Internal/Database/Ops.hs
@@ -39,18 +39,20 @@ import           Internal.Database.Model
 import           Internal.Types
 import           Internal.Utils
 
-migrate_ :: SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
-migrate_ more = runNoLoggingT $ runResourceT
-          $ withSqlConn openConnection (\backend ->
-                                          flip runSqlConn backend $ do
-                                           runMigration migrateAll
-                                           more
+migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
+migrate_ c more = runNoLoggingT $ runResourceT
+          $ withSqlConn (openConnection c) (\backend ->
+                                              flip runSqlConn backend $ do
+                                               runMigration migrateAll
+                                               more
                                        )
 
-openConnection :: LogFunc -> IO SqlBackend
-openConnection logfn = do
- conn <- open "/tmp/test.db"
- wrapConnection conn logfn
+openConnection :: SqlConfig -> LogFunc -> IO SqlBackend
+openConnection c logfn = case c of
+  Sqlite p -> do
+    conn <- open p
+    wrapConnection conn logfn
+  Postgres -> error "postgres not implemented"
 
 nukeTables :: MonadIO m => SqlPersistT m ()
 nukeTables = do
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index 0ea0235..bfce0ce 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -34,6 +34,10 @@ import           Text.Read
 -- | YAML CONFIG
 -------------------------------------------------------------------------------
 
+data SqlConfig = Sqlite T.Text |
+  Postgres -- TODO
+  deriving (Generic, FromDhall)
+
 -------------------------------------------------------------------------------
 -- | account tree
 
@@ -86,6 +90,7 @@ data Config_ a = Config_
   , currencies :: ![Currency]
   , statements :: ![Statement]
   , accounts   :: a
+  , sqlConfig  :: !SqlConfig
   }
   deriving (Generic)