pwncash/lib/Internal/Database/Model.hs

112 lines
2.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
2022-12-11 17:51:11 -05:00
module Internal.Database.Model where
import Database.Esqueleto.Experimental
import Database.Persist.TH
import Internal.Types
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
2022-12-11 17:51:11 -05:00
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
2022-12-11 17:51:11 -05:00
CommitR sql=commits
hash Int
type ConfigType
deriving Show Eq
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
deriving Show Eq
AccountR sql=accounts
name T.Text
fullpath T.Text
desc T.Text
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
depth Int
deriving Show Eq
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
date Day
description T.Text
deriving Show Eq
SplitR sql=splits
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational
deriving Show Eq
2023-01-30 22:48:16 -05:00
BudgetLabelR sql=budget_labels
2023-02-05 11:34:22 -05:00
split SplitRId OnDeleteCascade
2023-01-30 22:48:16 -05:00
budgetName T.Text
2023-01-30 21:47:17 -05:00
deriving Show Eq
2023-01-30 22:48:16 -05:00
ExpenseBucketR sql=expense_buckets
2023-02-05 11:34:22 -05:00
budgetLabel BudgetLabelRId OnDeleteCascade
2023-01-30 21:47:17 -05:00
bucket ExpenseBucket
deriving Show Eq
2023-01-30 22:48:16 -05:00
IncomeBucketR sql=income_buckets
2023-02-05 11:34:22 -05:00
budgetLabel BudgetLabelRId OnDeleteCascade
2023-01-30 21:47:17 -05:00
bucket IncomeBucket
deriving Show Eq
2022-12-11 17:51:11 -05:00
|]
type AccountMap = M.Map AcntID (AccountRId, AcntSign)
type CurrencyMap = M.Map CurID CurrencyRId
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
2023-01-30 22:57:42 -05:00
, kmConfigDir :: !FilePath
2022-12-11 17:51:11 -05:00
}
2023-02-12 16:23:32 -05:00
type MappingT m = ReaderT DBState (SqlPersistT m)
2022-12-11 17:51:11 -05:00
type KeySplit = Split AccountRId Rational CurrencyRId
type KeyTx = Tx KeySplit
type TreeR = Tree ([T.Text], AccountRId)
2023-02-12 16:23:32 -05:00
type Balances = M.Map AccountRId Rational
type BalanceM m = ReaderT (MVar Balances) m
class MonadUnliftIO m => MonadFinance m where
askDBState :: (DBState -> a) -> m a
instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
askBalances :: m (MVar Balances)
withBalances :: (Balances -> m a) -> m a
withBalances f = do
bs <- askBalances
withMVar bs f
modifyBalances :: (Balances -> m (Balances, a)) -> m a
modifyBalances f = do
bs <- askBalances
modifyMVar bs f
lookupBalance :: AccountRId -> m Rational
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
addBalance :: AccountRId -> Rational -> m ()
addBalance i v =
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i