112 lines
2.7 KiB
Haskell
112 lines
2.7 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
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
|
|
|
|
share
|
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
|
[persistLowerCase|
|
|
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
|
|
BudgetLabelR sql=budget_labels
|
|
split SplitRId OnDeleteCascade
|
|
budgetName T.Text
|
|
deriving Show Eq
|
|
ExpenseBucketR sql=expense_buckets
|
|
budgetLabel BudgetLabelRId OnDeleteCascade
|
|
bucket ExpenseBucket
|
|
deriving Show Eq
|
|
IncomeBucketR sql=income_buckets
|
|
budgetLabel BudgetLabelRId OnDeleteCascade
|
|
bucket IncomeBucket
|
|
deriving Show Eq
|
|
|]
|
|
|
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
|
|
|
type CurrencyMap = M.Map CurID CurrencyRId
|
|
|
|
data DBState = DBState
|
|
{ kmCurrency :: !CurrencyMap
|
|
, kmAccount :: !AccountMap
|
|
, kmBudgetInterval :: !Bounds
|
|
, kmStatementInterval :: !Bounds
|
|
, kmNewCommits :: ![Int]
|
|
, kmConfigDir :: !FilePath
|
|
}
|
|
|
|
type MappingT m = ReaderT DBState (SqlPersistT m)
|
|
|
|
type KeySplit = Split AccountRId Rational CurrencyRId
|
|
|
|
type KeyTx = Tx KeySplit
|
|
|
|
type TreeR = Tree ([T.Text], AccountRId)
|
|
|
|
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
|