ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'use_subaccount'

This commit is contained in:
Nathan Dwarshuis 2023-07-16 19:57:00 -04:00
parent 53d77326f5 2e0b591312
commit e6f97651e5
12 changed files with 2451 additions and 1612 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
app/Main.hs
View File

@ -2,13 +2,17 @@
module Main (main) where
import Control.Concurrent
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Bitraversable
-- import Data.Hashable
import qualified Data.Text.IO as TI
import qualified Database.Esqueleto.Experimental as E
import Database.Persist.Monad
import Dhall hiding (double, record)
import qualified Dhall hiding (double, record)
import Internal.Budget
import Internal.Database
import Internal.History
@ -17,6 +21,7 @@ import Internal.Utils
import Options.Applicative
import RIO
import RIO.FilePath
-- import qualified RIO.Map as M
import qualified RIO.Text as T
main :: IO ()
@ -30,14 +35,26 @@ main = parse =<< execParser o
<> header "pwncash - your budget, your life"
)
data Options = Options FilePath Mode
type ConfigPath = FilePath
type BudgetPath = FilePath
type HistoryPath = FilePath
data Options = Options !ConfigPath !Mode
data Mode
= Reset
| DumpCurrencies
| DumpAccounts
| DumpAccountKeys
| Sync
| Sync !SyncOptions
data SyncOptions = SyncOptions
{ syncBudgets :: ![BudgetPath]
, syncHistories :: ![HistoryPath]
, syncThreads :: !Int
}
configFile :: Parser FilePath
configFile =
@ -104,6 +121,35 @@ sync =
<> short 'S'
<> help "Sync config to database"
)
<*> syncOptions
syncOptions :: Parser SyncOptions
syncOptions =
SyncOptions
<$> many
( strOption
( long "budget"
<> short 'b'
<> metavar "BUDGET"
<> help "path to a budget config"
)
)
<*> many
( strOption
( long "history"
<> short 'H'
<> metavar "HISTORY"
<> help "path to a history config"
)
)
<*> option
auto
( long "threads"
<> short 't'
<> metavar "THREADS"
<> value 1
<> help "number of threads for syncing"
)
parse :: Options -> IO ()
parse (Options c Reset) = do
@ -112,7 +158,8 @@ parse (Options c Reset) = do
parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c
parse (Options c Sync) = runSync c
parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
runSync syncThreads c syncBudgets syncHistories
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
runDumpCurrencies c = do
@ -150,50 +197,70 @@ runDumpAccountKeys c = do
ar <- accounts <$> readConfig c
let ks =
paths2IDs $
fmap (double . fst) $
concatMap (t3 . uncurry tree2Records) $
flattenAcntRoot ar
fmap (double . accountRFullpath . E.entityVal) $
fst $
indexAcntRoot ar
mapM_ (uncurry printPair) ks
where
printPair i p = do
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
t3 (_, _, x) = x
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
double x = (x, x)
runSync :: FilePath -> IO ()
runSync c = do
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
runSync threads c bs hs = do
setNumCapabilities threads
-- putStrLn "reading config"
config <- readConfig c
let (hTs, hSs) = splitHistory $ statements config
-- putStrLn "reading statements"
(bs', hs') <-
fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs)
pool <- runNoLoggingT $ mkPool $ sqlConfig config
putStrLn "doing other stuff"
setNumCapabilities 1
handle err $ do
-- _ <- askLoggerIO
-- get the current DB state
(state, updates) <- runSqlQueryT pool $ do
-- Get the current DB state.
state <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ getDBState config
liftIOExceptT $ readConfigState config bs' hs'
-- read desired statements from disk
bSs <-
flip runReaderT state $
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
-- Read raw transactions according to state. If a transaction is already in
-- the database, don't read it but record the commit so we can update it.
toIns <-
flip runReaderT state $ do
(CRUDOps hSs _ _ _) <- asks csHistStmts
hSs' <- mapErrorsIO (readHistStmt root) hSs
(CRUDOps hTs _ _ _) <- asks csHistTrans
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
(CRUDOps bTs _ _ _) <- asks csBudgets
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
return $ concat $ hSs' ++ hTs' ++ bTs'
-- update the DB
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let hTransRes = mapErrors insertHistTransfer hTs
let bgtRes = mapErrors insertBudget $ budget config
updateDBState updates -- TODO this will only work if foreign keys are deferred
-- NOTE this must come first (unless we defer foreign keys)
updateDBState
res <- runExceptT $ do
mapM_ (uncurry insertHistStmt) bSs
combineError hTransRes bgtRes $ \_ _ -> ()
(CRUDOps _ bRs bUs _) <- asks csBudgets
(CRUDOps _ tRs tUs _) <- asks csHistTrans
(CRUDOps _ sRs sUs _) <- asks csHistStmts
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
insertAll ebs
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-- whatever error is encountered above in an IO context, but the first
-- thrown error should be caught despite possibly needing to be rerun
rerunnableIO $ fromEither res
where
root = takeDirectory c
err (InsertException es) = do
err (AppException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure
-- showBalances
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath
readConfig = fmap unfix . readDhall
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath

6
budget.cabal
View File

@ -75,7 +75,8 @@ library
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
build-depends:
base >=4.12 && <10
Decimal >=0.5.2
, base >=4.12 && <10
, cassava
, conduit >=1.3.4.2
, containers >=0.6.4.1
@ -144,7 +145,8 @@ executable pwncash
ViewPatterns
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
build-depends:
base >=4.12 && <10
Decimal >=0.5.2
, base >=4.12 && <10
, budget
, cassava
, conduit >=1.3.4.2

311
dhall/Types.dhall
View File

@ -278,8 +278,9 @@ let DatePat =
-}
< Cron : CronPat.Type | Mod : ModPat.Type >
let TxOpts =
let TxOpts_ =
{- Additional metadata to use when parsing a statement -}
\(re : Type) ->
{ Type =
{ toDate :
{-
@ -312,7 +313,7 @@ let TxOpts =
{- Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
Text
re
}
, default =
{ toDate = "Date"
@ -324,6 +325,8 @@ let TxOpts =
}
}
let TxOpts = TxOpts_ Text
let Field =
{-
General key-value type
@ -402,9 +405,45 @@ let EntryNumGetter =
LookupN: lookup the value from a field
ConstN: a constant value
AmountN: the value of the 'Amount' column
AmountN: the value of the 'Amount' column times a scaling factor
BalanceN: the amount required to make the target account reach a balance
PercentN: the amount required to make an account reach a given percentage
-}
< LookupN : Text | ConstN : Double | AmountN : Double >
< LookupN : Text
| ConstN : Double
| AmountN : Double
| BalanceN : Double
| PercentN : Double
>
let LinkedNumGetter =
{-
Means to get a numeric value from another entry
-}
{ Type =
{ lngIndex :
{-
Index of the entry to link.
-}
Natural
, lngScale :
{-
Factor by which to multiply the value of the linked entry.
-}
Double
}
, default = { lngScale = 1.0, lngIndex = 0 }
}
let LinkedEntryNumGetter =
{-
Means to get a numeric value from a statement row or another entry getter.
Linked: a number referring to the entry on the 'from' side of the
transaction (with 0 being the primary entry)
Getter: a normal getter
-}
< Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
let EntryTextGetter =
{-
@ -443,7 +482,6 @@ let Entry =
-}
\(a : Type) ->
\(v : Type) ->
\(c : Type) ->
\(t : Type) ->
{ eAcnt :
{-
@ -455,11 +493,6 @@ let Entry =
Pertains to value for this entry.
-}
v
, eCurrency :
{-
Pertains to value for this entry.
-}
c
, eComment :
{-
A short description of this entry (if none, use a blank string)
@ -474,35 +507,107 @@ let Entry =
let EntryGetter =
{-
Means for getting an entry from a given row in a statement
Means for getting an entry from a given row in a statement (debit side)
-}
\(n : Type) ->
{ Type = Entry EntryAcntGetter n TagID
, default = { eComment = "", eTags = [] : List TagID }
}
let FromEntryGetter =
{-
Means for getting an entry from a given row in a statement (debit side)
-}
EntryGetter EntryNumGetter
let ToEntryGetter =
{-
Means for getting an entry from a given row in a statement (credit side)
-}
EntryGetter LinkedEntryNumGetter
let TxHalfGetter =
{-
Means of transforming one row in a statement to either the credit or debit
half of a transaction
-}
\(e : Type) ->
{ Type =
{ thgAcnt :
{-
Account from which this transaction will be balanced. The value
of the transaction will be assigned to this account unless
other entries are specified (see below).
This account (and its associated entry) will be denoted
'primary'.
-}
EntryAcntGetter
, thgEntries :
{-
Means of getting additional entries from which this transaction
will be balanced. If this list is empty, the total value of the
transaction will be assigned to the value defined by 'tsgAcnt'.
Otherwise, the entries specified here will be added to this side
of this transaction, and their sum value will be subtracted from
the total value of the transaction and assigned to 'tsgAcnt'.
This is useful for situations where a particular transaction
denotes values that come from multiple subaccounts.
-}
List e
, thgComment :
{-
Comment for the primary entry
-}
Text
, thgTags :
{-
Tags for the primary entry
-}
List TagID
}
, default =
{ thgTags = [] : List TagID
, thgComment = ""
, thgEntries = [] : List e
}
}
let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
let ToTxHalfGetter = TxHalfGetter ToEntryGetter.Type
let TxSubGetter =
{-
A means for transforming one row in a statement to a transaction
-}
{ Type =
Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
, default = { eValue = None EntryNumGetter, eComment = "" }
{ tsgValue : EntryNumGetter
, tsgCurrency : EntryCurGetter
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
}
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
}
let TxGetter =
{-
A means for transforming one row in a statement to a transaction
Note that N-1 entries need to be specified to make a transaction, as the
Nth entry will be balanced with the others.
-}
{ tgEntries :
{-
A means of getting entries for this transaction (minimum 1)
-}
List EntryGetter.Type
, tgCurrency :
{-
Currency against which entries in this transaction will be balanced
-}
EntryCurGetter
, tgAcnt :
{-
Account in which entries in this transaction will be balanced
-}
EntryAcntGetter
{ Type =
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
, tgScale : Double
, tgCurrency : EntryCurGetter
, tgOtherEntries : List TxSubGetter.Type
}
, default =
{ tgOtherEntries = [] : List TxSubGetter.Type
, tgFrom = TxHalfGetter
, tgTo = TxHalfGetter
, tgScale = 1.0
}
}
let StatementParser_ =
@ -542,7 +647,7 @@ let StatementParser_ =
a transaction. If none, don't make a transaction (eg 'skip'
this row in the statement).
-}
Optional TxGetter
Optional TxGetter.Type
, spTimes :
{-
Match at most this many rows; if none there is no limit
@ -559,7 +664,7 @@ let StatementParser_ =
, spVal = ValMatcher::{=}
, spDesc = None Text
, spOther = [] : List (FieldMatcher_ re)
, spTx = None TxGetter
, spTx = None TxGetter.Type
, spTimes = None Natural
, spPriority = +0
}
@ -577,7 +682,29 @@ let Amount =
-}
\(w : Type) ->
\(v : Type) ->
{ amtWhen : w, amtValue : v, amtDesc : Text }
{ Type =
{ amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
, default.amtPriority = +0
}
let TransferType =
{-
The type of a budget transfer.
BTFixed: Tranfer a fixed amount
BTPercent: Transfer a percent of the source account to destination
BTTarget: Transfer an amount such that the destination has a given target
value
-}
< TPercent | TBalance | TFixed >
let TransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ Type = { tvVal : Double, tvType : TransferType }
, default.tvType = TransferType.TFixed
}
let Transfer =
{-
@ -590,14 +717,24 @@ let Transfer =
{ transFrom : a
, transTo : a
, transCurrency : c
, transAmounts : List (Amount w v)
, transAmounts : List (Amount w v).Type
}
let TaggedAcnt =
{-
An account with a tag
-}
{ Type = { taAcnt : AcntID, taTags : List TagID }
, default.taTags = [] : List TagID
}
let HistTransfer =
{-
A manually specified historical transfer
-}
Transfer AcntID CurID DatePat Double
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
let TransferAmount = Amount DatePat TransferValue.Type
let Statement =
{-
@ -634,44 +771,6 @@ let History =
-}
< HistTransfer : HistTransfer | HistStatement : Statement >
let Exchange =
{-
A currency exchange.
-}
{ xFromCur :
{-
Starting currency of the exchange.
-}
CurID
, xToCur :
{-
Ending currency of the exchange.
-}
CurID
, xAcnt :
{-
account in which the exchange will be documented.
-}
AcntID
, xRate :
{-
The exchange rate between the currencies.
-}
Double
}
let BudgetCurrency =
{-
A 'currency' in the budget; either a fixed currency or an exchange
-}
< NoX : CurID | X : Exchange >
let TaggedAcnt =
{-
An account with a tag
-}
{ taAcnt : AcntID, taTags : List TagID }
let Allocation =
{-
How to allocate a given budget stream. This can be thought of as a Transfer
@ -679,12 +778,7 @@ let Allocation =
-}
\(w : Type) ->
\(v : Type) ->
{ alloTo : TaggedAcnt
, alloAmts : List (Amount w v)
, alloCur :
{-TODO allow exchanges here-}
CurID
}
{ alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }
let PretaxValue =
{-
@ -779,6 +873,8 @@ let SingleAllocation =
-}
Allocation {}
let SingleAlloAmount = \(v : Type) -> Amount {} v
let MultiAllocation =
{-
An allocation specialized to capturing multiple income streams within a given
@ -787,6 +883,8 @@ let MultiAllocation =
-}
Allocation Interval
let MultiAlloAmount = \(v : Type) -> Amount Interval v
let HourlyPeriod =
{-
Definition for a pay period denominated in hours
@ -869,18 +967,20 @@ let Income =
This must be an income AcntID, and is the only place income
accounts may be specified in the entire budget.
-}
TaggedAcnt
TaggedAcnt.Type
, incToBal :
{-
The account to which to send the remainder of the income stream
(if any) after all allocations have been applied.
-}
TaggedAcnt
TaggedAcnt.Type
, incPriority : Integer
}
, default =
{ incPretax = [] : List (SingleAllocation PretaxValue)
, incTaxes = [] : List (SingleAllocation TaxValue)
, incPosttaxx = [] : List (SingleAllocation PosttaxValue)
, incPriority = +0
}
}
@ -937,17 +1037,6 @@ let TransferMatcher =
}
}
let BudgetTransferType =
{-
The type of a budget transfer.
BTFixed: Tranfer a fixed amount
BTPercent: Transfer a percent of the source account to destination
BTTarget: Transfer an amount such that the destination has a given target
value
-}
< BTPercent | BTTarget | BTFixed >
let ShadowTransfer =
{-
A transaction analogous to another transfer with given properties.
@ -956,17 +1045,17 @@ let ShadowTransfer =
{-
Source of this transfer
-}
TaggedAcnt
TaggedAcnt.Type
, stTo :
{-
Destination of this transfer.
-}
TaggedAcnt
TaggedAcnt.Type
, stCurrency :
{-
Currency of this transfer.
-}
BudgetCurrency
CurID
, stDesc :
{-
Description of this transfer.
@ -980,7 +1069,7 @@ let ShadowTransfer =
specified in other fields of this type.
-}
TransferMatcher.Type
, stType : BudgetTransferType
, stType : TransferType
, stRatio :
{-
Fixed multipler to translate value of matched transfer to this one.
@ -988,17 +1077,11 @@ let ShadowTransfer =
Double
}
let BudgetTransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ btVal : Double, btType : BudgetTransferType }
let BudgetTransfer =
{-
A manually specified transaction for a budget
-}
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
HistTransfer
let Budget =
{-
@ -1040,6 +1123,7 @@ in { CurID
, CronPat
, DatePat
, TxOpts
, TxOpts_
, StatementParser
, StatementParser_
, ValMatcher
@ -1048,10 +1132,13 @@ in { CurID
, FieldMatcher
, FieldMatcher_
, EntryNumGetter
, LinkedEntryNumGetter
, LinkedNumGetter
, Field
, FieldMap
, Entry
, EntryGetter
, FromEntryGetter
, ToEntryGetter
, EntryTextGetter
, EntryCurGetter
, EntryAcntGetter
@ -1065,9 +1152,8 @@ in { CurID
, TransferMatcher
, ShadowTransfer
, AcntSet
, BudgetCurrency
, Exchange
, TaggedAcnt
, AccountTree
, Account
, Placeholder
, PretaxValue
@ -1076,13 +1162,20 @@ in { CurID
, TaxProgression
, TaxMethod
, TaxValue
, BudgetTransferValue
, BudgetTransferType
, TransferValue
, TransferType
, TxGetter
, TxSubGetter
, TxHalfGetter
, FromTxHalfGetter
, ToTxHalfGetter
, HistTransfer
, SingleAllocation
, MultiAllocation
, HourlyPeriod
, Period
, PeriodType
, TransferAmount
, MultiAlloAmount
, SingleAlloAmount
}

95
dhall/common.dhall
View File

@ -4,18 +4,10 @@ let List/map =
let T = ./Types.dhall
let nullSplit =
let nullEntry =
\(a : T.EntryAcntGetter) ->
\(c : T.EntryCurGetter) ->
T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
let nullOpts = T.TxOpts::{=}
let nullVal = T.ValMatcher::{=}
let nullMatch = T.StatementParser::{=}
let nullCron = T.CronPat::{=}
\(v : T.EntryNumGetter) ->
T.FromEntryGetter::{ eAcnt = a, eValue = v }
let nullMod =
\(by : Natural) ->
@ -27,21 +19,22 @@ let cron1 =
\(m : Natural) ->
\(d : Natural) ->
T.DatePat.Cron
( nullCron
// { cpYear = Some (T.MDYPat.Single y)
T.CronPat::{
, cpYear = Some (T.MDYPat.Single y)
, cpMonth = Some (T.MDYPat.Single m)
, cpDay = Some (T.MDYPat.Single d)
}
)
let matchInf_ = nullMatch
let matchInf_ = T.StatementParser::{=}
let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
let matchInf = \(x : T.TxGetter.Type) -> T.StatementParser::{ spTx = Some x }
let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
let matchN_ = \(n : Natural) -> T.StatementParser::{ spTimes = Some n }
let matchN =
\(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
\(n : Natural) ->
\(x : T.TxGetter.Type) ->
matchInf x // { spTimes = Some n }
let match1_ = matchN_ 1
@ -86,46 +79,45 @@ let mRngYMD =
\(r : Natural) ->
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
let partN =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
\(ss : List PartSplit) ->
let toSplit =
\(x : PartSplit) ->
nullSplit (T.EntryAcntGetter.ConstT x._1) c
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
let partNFrom =
\(ss : List PartEntry) ->
let toEntry =
\(x : PartEntry) ->
T.FromEntryGetter::{
, eAcnt = T.EntryAcntGetter.ConstT x._1
, eValue = T.EntryNumGetter.ConstN x._2
, eComment = x._3
}
in [ nullSplit a c // { eComment = comment } ]
# List/map PartSplit T.EntryGetter.Type toSplit ss
in List/map PartEntry T.FromEntryGetter.Type toEntry ss
let part1 =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
\(comment : Text) ->
partN c a comment ([] : List PartSplit)
let partNTo =
\(ss : List PartEntry) ->
let toEntry =
\(x : PartEntry) ->
T.ToEntryGetter::{
, eAcnt = T.EntryAcntGetter.ConstT x._1
, eValue =
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
, eComment = x._3
}
let part1_ =
\(c : T.EntryCurGetter) ->
\(a : T.EntryAcntGetter) ->
partN c a "" ([] : List PartSplit)
in List/map PartEntry T.ToEntryGetter.Type toEntry ss
let addDay =
\(x : T.GregorianM) ->
\(d : Natural) ->
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
let mvP = nullVal // { vmSign = Some True }
let mvP = T.ValMatcher::{ vmSign = Some True }
let mvN = nullVal // { vmSign = Some False }
let mvN = T.ValMatcher::{ vmSign = Some False }
let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
let mvNum = \(x : Natural) -> T.ValMatcher::{ vmNum = Some x }
let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
let mvDen = \(x : Natural) -> T.ValMatcher::{ vmDen = Some x }
let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
@ -135,13 +127,7 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
in { nullSplit
, nullMatch
, nullVal
, nullOpts
, nullCron
, nullMod
, cron1
in { cron1
, mY
, mYM
, mYMD
@ -156,9 +142,8 @@ in { nullSplit
, match1
, greg
, gregM
, partN
, part1
, part1_
, partNFrom
, partNTo
, addDay
, comma = 44
, tab = 9
@ -170,6 +155,8 @@ in { nullSplit
, mvDen
, mvDenP
, mvDenN
, PartSplit
, PartEntry
, nullEntry
, nullMod
}
/\ T

489
lib/Internal/Budget.hs
View File

@ -1,9 +1,9 @@
module Internal.Budget (insertBudget) where
module Internal.Budget (readBudget) where
import Control.Monad.Except
import Data.Decimal hiding (allocate)
import Data.Foldable
import Database.Persist.Monad
import Internal.Database
import Data.Hashable
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -13,22 +13,8 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions
-- 5. insert all transactions
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m ()
insertBudget
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
readBudget
b@Budget
{ bgtLabel
, bgtIncomes
@ -39,15 +25,19 @@ insertBudget
, bgtPosttax
, bgtInterval
} =
whenHash CTBudget b () $ \key -> do
do
spanRes <- getSpan
case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
where
c = CommitR (CommitHash $ hash b) CTBudget
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
pre_ = sortAllos bgtPretax
@ -58,73 +48,15 @@ insertBudget
(alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- asks (unBSpan . csBudgetScope)
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
localSpan <- liftExcept $ resolveDaySpan bi
return $ intersectDaySpan globalSpan localSpan
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
let balTo = M.findWithDefault 0 ftTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
in (bals', f {ftValue = x})
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer
-> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k entry = do
sk <- insertEntry k entry
insert_ $ BudgetLabelR sk $ bmName ftMeta
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (EntryPair, Maybe EntryPair)
entryPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = entry curid from_ (-v)
let s2 = entry curid to_ v
combineError s1 s2 (,)
entry c TaggedAcnt {taAcnt, taTags} v =
resolveEntry $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
@ -143,100 +75,107 @@ sortAllo a@Allocation {alloAmts = as} = do
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
insertIncome
:: (MonadInsertError m, MonadFinance m)
=> CommitRId
-> T.Text
readIncome
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> BudgetName
-> IntAllocations
-> Maybe Interval
-> DaySpan
-> Income
-> m [UnbalancedTransfer]
insertIncome
-> m [Tx CommitR]
readIncome
key
name
(intPre, intTax, intPost)
localInterval
ds
Income
{ incWhen
, incCurrency
, incFrom
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
, incPretax
, incPosttax
, incTaxes
, incToBal
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
, incGross
, incPayPeriod
, incPriority
} =
combineErrorM
(combineError incRes nonIncRes (,))
(combineError precRes dayRes (,))
$ \_ (precision, days) -> do
let gross = roundPrecision precision incGross
concat <$> foldDays (allocate precision gross) start days
(combineError cpRes dayRes (,))
$ \_ (cp, days) -> do
let gross = realFracToDecimalP (cpPrec cp) incGross
foldDays (allocate cp gross) start days
where
incRes = isIncomeAcnt $ taAcnt incFrom
srcAcnt' = AcntID srcAcnt
destAcnt' = AcntID destAcnt
incRes = isIncomeAcnt srcAcnt'
nonIncRes =
mapErrors isNotIncomeAcnt $
taAcnt incToBal
destAcnt'
: (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax)
precRes = lookupCurrencyPrec incCurrency
dayRes = askDays incWhen localInterval
cpRes = lookupCurrency incCurrency
dayRes = liftExcept $ expandDatePat ds incWhen
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue
-- TODO ensure these are all the "correct" accounts
allocate precision gross prevDay day = do
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
allocate cp gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day
let precision = cpPrec cp
let (preDeductions, pre) =
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
tax =
let tax =
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre)
post =
let post =
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post
bal =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = incFrom
, ftCur = NoX incCurrency
, ftTo = incToBal
, ftValue = UnbalancedValue BTFixed balance
, ftDesc = "balance after deductions"
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary =
EntrySet
{ esTotalValue = gross
, esCurrency = cpID cp
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
}
return $
Tx
{ txCommit = key
, txDate = day
, txPrimary = Left primary
, txOther = []
, txDescr = TxDesc ""
, txBudget = name
, txPriority = incPriority
}
in if balance < 0
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
-> AppExcept PeriodScaler
periodScaler pt prev cur = return scale
where
n = fromIntegral $ workingDays wds prev cur
n = workingDays wds prev cur
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
scale precision x = case pt of
scale prec x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
fromRational (rnd $ x / fromIntegral hpAnnualHours)
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
* fromIntegral n
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
-- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural
@ -252,7 +191,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
-- ASSUME days is a sorted list
foldDays
:: MonadInsertError m
:: MonadAppError m
=> (Day -> Day -> m a)
-> Day
-> [Day]
@ -262,27 +201,27 @@ foldDays f start days = case NE.nonEmpty days of
Just ds
| any (start >) ds ->
throwError $
InsertException [PeriodError start $ minimum ds]
AppException [PeriodError start $ minimum ds]
| otherwise ->
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
checkAcntType
:: (MonadInsertError m, MonadFinance m)
:: (MonadAppError m, MonadFinance m)
=> AcntType
-> AcntID
-> m ()
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
:: (MonadAppError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m ()
@ -290,83 +229,70 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
where
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
| otherwise = throwError $ AppException [AccountTypeError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
{ faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
selectAllos day Allocation {alloAmts, alloTo} =
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
{ faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
allo2Trans
:: BudgetMeta
-> Day
-> TaggedAcnt
-> FlatAllocation Rational
-> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = from
, ftCur = faCur
, ftTo = faTo
, ftValue = UnbalancedValue BTFixed faValue
, ftDesc = faDesc
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
Entry
{ eValue = LinkValue (EntryFixed faValue)
, eComment = faDesc
, eAcnt = AcntID taAcnt
, eTags = TagID <$> taTags
}
type PreDeductions = M.Map T.Text Decimal
allocatePre
:: Natural
-> Rational
:: Precision
-> Decimal
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
-> (PreDeductions, [FlatAllocation Decimal])
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
p = preValue faValue
v =
if prePercent faValue
then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
let v =
if prePercent
then gross *. (preValue / 100)
else realFracToDecimalP precision preValue
in (mapAdd_ preCategory v m, f {faValue = v})
allocateTax
:: Natural
-> Rational
-> M.Map T.Text Rational
:: Precision
-> Decimal
-> PreDeductions
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
-> [FlatAllocation Decimal]
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
TMPercent p -> agi *. p / 100
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
let taxDed = roundPrecision precision $ f precision tpDeductible
let taxDed = f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
-- | Compute effective tax percentage of a bracket
@ -380,174 +306,80 @@ allocateTax precision gross preDeds f = fmap (fmap go)
--
-- In reality, this can all be done with one loop, but it isn't clear these
-- three steps are implemented from this alone.
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
let l = roundPrecision precision $ f precision tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain >= l then (acc + p * (remain - l), l) else a
let l = f prec tbLowerLimit
in if remain >= l
then (acc + (remain - l) *. (tbPercent / 100), l)
else a
allocatePost
:: Natural
-> Rational
:: Precision
-> Decimal
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
-> [FlatAllocation Decimal]
allocatePost prec aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
--------------------------------------------------------------------------------
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [UnbalancedTransfer]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn ftWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
-> m [UnbalancedTransfer]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftCur = transCurrency
, ftFrom = transFrom
, ftTo = transTo
, ftValue = UnbalancedValue y $ roundPrecision precision v
, ftDesc = desc
}
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
go PosttaxValue {postValue, postPercent}
| postPercent = aftertax *. (postValue / 100)
| otherwise = realFracToDecimalP prec postValue
--------------------------------------------------------------------------------
-- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
:: (MonadAppError m, MonadFinance m)
=> [ShadowTransfer]
-> [Tx CommitR]
-> m [Tx CommitR]
addShadowTransfers ms = mapErrors go
where
go tx = do
es <- catMaybes <$> mapErrors (fromShadow tx) ms
return $ tx {txOther = Right <$> es}
fromShadow
:: CurrencyMap
-> UnbalancedTransfer
:: (MonadAppError m, MonadFinance m)
=> Tx CommitR
-> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $
if not res
then Nothing
else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
-> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
combineErrorM curRes shaRes $ \cur sha -> do
let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not sha then Nothing else Just es
where
curRes = lookupCurrencyKey (CurID stCurrency)
shaRes = liftExcept $ shadowMatches stMatch tx
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
&& maybe True (`dateMatches` txDate) tmDate
&& valRes
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
--------------------------------------------------------------------------------
-- random
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
alloAcnt = AcntID . taAcnt . alloTo
type IntAllocations =
( [DaySpanAllocation PretaxValue]
@ -557,14 +389,11 @@ type IntAllocations =
type DaySpanAllocation = Allocation DaySpan
type EntryPair = (KeyEntry, KeyEntry)
type PeriodScaler = Natural -> Double -> Double
type PeriodScaler = Precision -> Double -> Decimal
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)

844
lib/Internal/Database.hs
View File

@ -1,35 +1,38 @@
module Internal.Database
( runDB
, readConfigState
, nukeTables
, updateHashes
, updateDBState
, getDBState
, tree2Records
, flattenAcntRoot
, indexAcntRoot
, paths2IDs
, mkPool
, whenHash
, whenHash_
, insertEntry
, resolveEntry
, readUpdates
, insertAll
, updateTx
)
where
import Conduit
import Control.Monad.Except
import Control.Monad.Logger
import Data.Decimal
import Data.Hashable
import Database.Esqueleto.Experimental ((==.), (^.))
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
import Database.Persist.Monad
import Database.Persist.Sqlite hiding
( delete
( Statement
, delete
, deleteWhere
, insert
, insertKey
, insert_
, runMigration
, update
, (==.)
, (||.)
)
@ -37,10 +40,10 @@ import GHC.Err
import Internal.Types.Main
import Internal.Utils
import RIO hiding (LogFunc, isNothing, on, (^.))
import RIO.List ((\\))
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as N
import qualified RIO.NonEmpty as NE
import qualified RIO.Set as S
import qualified RIO.Text as T
runDB
@ -103,85 +106,192 @@ nukeTables = do
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
-- toBal = maybe "???" (fmtRational 2) . unValue
hashConfig :: Config -> [Int]
hashConfig
Config_
{ budget = bs
, statements = ss
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
readConfigState
:: (MonadAppError m, MonadSqlQuery m)
=> Config
-> [Budget]
-> [History]
-> m ConfigState
readConfigState c bs hs = do
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
(pathsIns, _, pathsDel) <- diff newPaths
(curs2Ins, cursRem, curs2Del) <- diff newCurs
(tags2Ins, tagsRem, tags2Del) <- diff newTags
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
let fromMap f = S.fromList . fmap f . M.elems
let existing =
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-- TODO refine this test to include the whole db (with data already mixed
-- in this algorithm)
let bsRes = BudgetSpan <$> resolveScope budgetInterval
let hsRes = HistorySpan <$> resolveScope statementInterval
combineErrorM bsRes hsRes $ \bscope hscope -> do
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
bgt <- makeTxCRUD existing bs curBgts bChanged
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
hStmt <- makeTxCRUD existing ss curHistSts hChanged
return $
ConfigState
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
, csTags = CRUDOps tags2Ins () () tags2Del
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
, csPaths = CRUDOps pathsIns () () pathsDel
, csBudgets = bgt
, csHistTrans = hTrans
, csHistStmts = hStmt
, csAccountMap = amap
, csCurrencyMap = cmap
, csTagMap = tmap
, csBudgetScope = bscope
, csHistoryScope = hscope
}
where
(ts, ss) = splitHistory hs
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
(newAcnts, newPaths) = indexAcntRoot $ accounts c
newTags = tag2Record <$> tags c
newCurs = currency2Record <$> currencies c
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
readScopeChanged
:: (MonadAppError m, MonadSqlQuery m)
=> Bool
-> BudgetSpan
-> HistorySpan
-> m (Bool, Bool)
readScopeChanged dbempty bscope hscope = do
rs <- dumpTbl
-- TODO these errors should only fire when someone messed with the DB
case rs of
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
[r] -> do
let (ConfigStateR h b) = E.entityVal r
return (bscope /= b, hscope /= h)
_ -> throwAppError $ DBError DBMultiScope
makeTxCRUD
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
=> ExistingConfig
-> [a]
-> [CommitHash]
-> Bool
-> m
( CRUDOps
[a]
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
)
makeTxCRUD existing newThings curThings scopeChanged = do
let (toDelHashes, overlap, toIns) =
setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
-- Check the overlap for rows with accounts/tags/currencies that
-- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later
(noRetry, toInsRetry) <- readInvalidIds existing overlap
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-- If we are inserting or deleting something or the scope changed, pull out
-- the remainder of the entries to update/read as we are (re)inserting other
-- stuff (this is necessary because a given transaction may depend on the
-- value of previous transactions, even if they are already in the DB).
(toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
([], [], False) -> return ([], [])
_ -> readUpdates noRetry
toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps toInsAll toRead toUpdate toDelAll
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
readTxIds cs = do
xs <- selectE $ do
(commits :& txs :& ess :& es :& ts) <-
E.from
$ E.table
`E.innerJoin` E.table
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
`E.innerJoin` E.table
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
return
( txs ^. TransactionRId
, ess ^. EntrySetRId
, es ^. EntryRId
, ts ^. TagRelationRId
)
let (txs, ss, es, ts) = L.unzip4 xs
return $
DeleteTxs
{ dtTxs = go txs
, dtEntrySets = go ss
, dtEntries = go es
, dtTagRelations = E.unValue <$> ts
}
where
go :: Eq a => [E.Value a] -> [a]
go = fmap (E.unValue . NE.head) . NE.group
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
(ms, ps) = partitionEithers $ fmap go ss
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
-- setDiff = setDiff' (==)
setDiff as bs = (as \\ bs, bs \\ as)
makeTagMap :: [Entity TagR] -> TagMap
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
-- setDiff' f = go []
-- where
-- go inA [] bs = (inA, bs)
-- go inA as [] = (as ++ inA, [])
-- go inA (a:as) bs = case inB a bs of
-- Just bs' -> go inA as bs'
-- Nothing -> go (a:inA) as bs
-- inB _ [] = Nothing
-- inB a (b:bs)
-- | f a b = Just bs
-- | otherwise = inB a bs
getDBHashes :: MonadSqlQuery m => m [Int]
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
nukeDBHash :: MonadSqlQuery m => Int -> m ()
nukeDBHash h = deleteE $ do
c <- E.from E.table
E.where_ (c ^. CommitRHash ==. E.val h)
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
nukeDBHashes = mapM_ nukeDBHash
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
getConfigHashes c = do
let ch = hashConfig c
dh <- getDBHashes
return $ setDiff dh ch
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
deleteAccount e = deleteE $ do
c <- E.from $ E.table @AccountR
E.where_ (c ^. AccountRId ==. E.val k)
where
k = entityKey e
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
deleteCurrency e = deleteE $ do
c <- E.from $ E.table @CurrencyR
E.where_ (c ^. CurrencyRId ==. E.val k)
where
k = entityKey e
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
deleteTag e = deleteE $ do
c <- E.from $ E.table @TagR
E.where_ (c ^. TagRId ==. E.val k)
where
k = entityKey e
-- TODO slip-n-slide code...
insertFull
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
=> Entity r
-> m ()
insertFull (Entity k v) = insertKey k v
tag2Record :: Tag -> Entity TagR
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
rs <- E.from E.table
return (rs ^. E.persistIdField)
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
readCurrentCommits = do
xs <- selectE $ do
rs <- E.from E.table
return (rs ^. CommitRHash, rs ^. CommitRType)
return $ foldr go ([], [], []) xs
where
go (x, t) (bs, ts, hs) =
let y = E.unValue x
in case E.unValue t of
CTBudget -> (y : bs, ts, hs)
CTHistoryTransfer -> (bs, y : ts, hs)
CTHistoryStatement -> (bs, ts, y : hs)
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
setDiffWith f = go [] []
where
go inA inBoth [] bs = (inA, inBoth, bs)
go inA inBoth as [] = (as ++ inA, inBoth, [])
go inA inBoth (a : as) bs =
let (res, bs') = findDelete (f a) bs
in case res of
Nothing -> go (a : inA) inBoth as bs
Just b -> go inA ((a, b) : inBoth) as bs'
findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
findDelete f xs = case break f xs of
(ys, []) -> (Nothing, ys)
(ys, z : zs) -> (Just z, ys ++ zs)
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table
currencyMap :: [Entity CurrencyR] -> CurrencyMap
currencyMap =
@ -189,46 +299,43 @@ currencyMap =
. fmap
( \e ->
( currencyRSymbol $ entityVal e
, (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
, CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
)
)
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
tree2Entity t parents name des =
Entity (toSqlKey $ fromIntegral h) $
AccountR name (toPath parents) des
where
p = AcntPath t (reverse (name : parents))
h = hash p
toPath = T.intercalate "/" . (atName t :) . reverse
makeAccountEntity :: AccountR -> Entity AccountR
makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
tree2Records
:: AcntType
-> AccountTree
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
makeAccountR atype name parents des = AccountR name path des (accountSign atype)
where
path = AcntPath atype (reverse $ name : parents)
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
tree2Records t = go []
where
go ps (Placeholder d n cs) =
let e = tree2Entity t (fmap snd ps) n d
k = entityKey e
(as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
a0 = acnt k n (fmap snd ps) d
paths = expand k $ fmap fst ps
in (a0 : concat as, paths ++ concat aps, concat ms)
let (parentKeys, parentNames) = L.unzip ps
a = acnt n parentNames d False
k = entityKey a
thesePaths = expand k parentKeys
in bimap ((a :) . concat) ((thesePaths ++) . concat) $
L.unzip $
go ((k, n) : ps) <$> cs
go ps (Account d n) =
let e = tree2Entity t (fmap snd ps) n d
k = entityKey e
in ( [acnt k n (fmap snd ps) d]
, expand k $ fmap fst ps
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
)
toPath = T.intercalate "/" . (atName t :) . reverse
acnt k n ps = Entity k . AccountR n (toPath ps)
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
sign = accountSign t
let (parentKeys, parentNames) = L.unzip ps
a = acnt n parentNames d True
k = entityKey a
in ([a], expand k parentKeys)
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
accountPathRecord p c d =
Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
paths2IDs =
@ -236,49 +343,25 @@ paths2IDs =
. first trimNames
. L.unzip
. L.sortOn fst
. fmap (first pathList)
where
pathList (AcntPath t []) = atName t :| []
pathList (AcntPath t ns) = N.reverse $ atName t :| ns
. fmap (first (NE.reverse . acntPath2NonEmpty))
-- none of these errors should fire assuming that input is sorted and unique
trimNames :: [N.NonEmpty T.Text] -> [AcntID]
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
trimNames :: [NonEmpty T.Text] -> [AcntID]
trimNames = fmap (AcntID . T.intercalate "_") . go []
where
trimAll _ [] = []
trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
(a, [], bs) -> reverse $ trim i a : bs
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
matchPre i (y, ys, old) new = case (y !? i, new !? i) of
(Nothing, Just _) ->
case ys of
[] -> (new, [], trim i y : old)
_ -> err "unsorted input"
(Just _, Nothing) -> err "unsorted input"
(Nothing, Nothing) -> err "duplicated inputs"
(Just a, Just b)
| a == b -> (new, y : ys, old)
| otherwise ->
let next = case ys of
[] -> [trim i y]
_ -> trimAll (i + 1) (reverse $ y : ys)
in (new, [], reverse next ++ old)
trim i = N.take (i + 1)
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
go prev = concatMap (go' prev) . groupNonEmpty
go' prev (key, rest) = case rest of
(_ :| []) -> [key : prev]
([] :| xs) ->
let next = key : prev
other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
in next : other
(x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
err = error "account path list either not sorted or contains duplicates"
(!?) :: N.NonEmpty a -> Int -> Maybe a
xs !? n
| n < 0 = Nothing
-- Definition adapted from GHC.List
| otherwise =
foldr
( \x r k -> case k of
0 -> Just x
_ -> r (k - 1)
)
(const Nothing)
xs
n
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
@ -288,129 +371,372 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
++ ((AssetT,) <$> arAssets)
++ ((EquityT,) <$> arEquity)
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
indexAcntRoot r =
( concat ars
, concat aprs
, M.fromList $ paths2IDs $ concat ms
)
makeAcntMap :: [Entity AccountR] -> AccountMap
makeAcntMap =
M.fromList
. paths2IDs
. fmap go
. filter (accountRLeaf . snd)
. fmap (\e -> (E.entityKey e, E.entityVal e))
where
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
getDBState
:: (MonadInsertError m, MonadSqlQuery m)
=> Config
-> m (DBState, DBUpdates)
getDBState c = do
(del, new) <- getConfigHashes c
combineError bi si $ \b s ->
( DBState
{ kmCurrency = currencyMap cs
, kmAccount = am
, kmBudgetInterval = b
, kmStatementInterval = s
, kmTag = tagMap ts
, kmNewCommits = new
}
, DBUpdates
{ duOldCommits = del
, duNewTagIds = ts
, duNewAcntPaths = paths
, duNewAcntIds = acnts
, duNewCurrencyIds = cs
}
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
updateCD
:: ( MonadSqlQuery m
, PersistRecordBackend a SqlBackend
, PersistRecordBackend b SqlBackend
)
=> CDOps (Entity a) (Key b)
-> m ()
updateCD (CRUDOps cs () () ds) = do
mapM_ deleteKeyE ds
insertEntityManyE cs
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
mapM_ deleteKeyE dtTxs
mapM_ deleteKeyE dtEntrySets
mapM_ deleteKeyE dtEntries
mapM_ deleteKeyE dtTagRelations
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
updateDBState = do
updateCD =<< asks csCurrencies
updateCD =<< asks csAccounts
updateCD =<< asks csPaths
updateCD =<< asks csTags
deleteTxs =<< asks (coDelete . csBudgets)
deleteTxs =<< asks (coDelete . csHistTrans)
deleteTxs =<< asks (coDelete . csHistStmts)
b <- asks csBudgetScope
h <- asks csHistoryScope
repsertE (E.toSqlKey 1) $ ConfigStateR h b
readInvalidIds
:: MonadSqlQuery m
=> ExistingConfig
-> [(CommitHash, a)]
-> m ([CommitHash], [(CommitHash, a)])
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
rs <- selectE $ do
(commits :& _ :& entrysets :& entries :& tags) <-
E.from
$ E.table
`E.innerJoin` E.table
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
`E.innerJoin` E.table
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
return
( commits ^. CommitRHash
, entrysets ^. EntrySetRCurrency
, entries ^. EntryRAccount
, tags ?. TagRelationRTag
)
-- TODO there are faster ways to do this; may/may not matter
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
let valid = (cs `S.intersection` as) `S.intersection` ts
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
return (a0, [])
where
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
(acnts, paths, am) = indexAcntRoot $ accounts c
cs = currency2Record <$> currencies c
ts = toRecord <$> tags c
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
go existing =
S.fromList
. fmap (E.unValue . fst)
. L.filter (all (`S.member` existing) . snd)
. groupKey id
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
readUpdates
:: (MonadAppError m, MonadSqlQuery m)
=> [CommitHash]
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
readUpdates hashes = do
xs <- selectE $ do
(commits :& txs :& entrysets :& entries :& currencies) <-
E.from
$ E.table @CommitR
`E.innerJoin` E.table @TransactionR
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
`E.innerJoin` E.table @EntrySetR
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table @EntryR
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.innerJoin` E.table @CurrencyR
`E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
return
( entrysets ^. EntrySetRRebalance
,
(
( entrysets ^. EntrySetRId
, txs ^. TransactionRDate
, txs ^. TransactionRBudgetName
, txs ^. TransactionRPriority
,
( entrysets ^. EntrySetRCurrency
, currencies ^. CurrencyRPrecision
)
)
, entries
)
)
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
let toRead' = fmap (makeRE . snd) toRead
return (toRead', toUpdate')
where
makeUES ((_, day, name, pri, (curID, prec)), es) = do
let prec' = fromIntegral $ E.unValue prec
let cur = E.unValue curID
let res =
bimap NE.nonEmpty NE.nonEmpty $
NE.partition ((< 0) . entryRIndex . snd) $
NE.sortWith (entryRIndex . snd) $
fmap (\e -> (entityKey e, entityVal e)) es
case res of
(Just froms, Just tos) -> do
let tot = sum $ fmap (entryRValue . snd) froms
(from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
(from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
-- TODO WAP (wet ass programming)
return $ case from0' of
Left x ->
Left $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = realFracToDecimalP prec' tot
, utBudget = E.unValue name
, utPriority = E.unValue pri
}
Right x ->
Right $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = ()
, utBudget = E.unValue name
, utPriority = E.unValue pri
}
-- TODO this error is lame
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
let e = entityVal entry
in ReadEntry
{ reDate = E.unValue day
, reCurrency = E.unValue curID
, reAcnt = entryRAccount e
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
, reBudget = E.unValue name
, rePriority = E.unValue pri
}
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateTags DBUpdates {duNewTagIds} = do
tags' <- selectE $ E.from $ E.table @TagR
let (toIns, toDel) = setDiff duNewTagIds tags'
mapM_ deleteTag toDel
mapM_ insertFull toIns
splitFrom
:: Precision
-> NonEmpty (EntryRId, EntryR)
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
splitFrom prec (f0 :| fs) = do
-- ASSUME entries are sorted by index
-- TODO combine errors here
let f0Res = readDeferredValue prec f0
let fsRes = mapErrors (splitDeferredValue prec) fs
combineErrorM f0Res fsRes $ \f0' fs' -> do
let (ro, unk) = partitionEithers fs'
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
return (f0', ro, unk)
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
acnts' <- dumpTbl
let (toIns, toDel) = setDiff duNewAcntIds acnts'
deleteWhere ([] :: [Filter AccountPathR])
mapM_ deleteAccount toDel
mapM_ insertFull toIns
mapM_ insert duNewAcntPaths
splitTo
:: Precision
-> Either UEBlank (Either UE_RO UEUnk)
-> [UEUnk]
-> NonEmpty (EntryRId, EntryR)
-> AppExcept
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
, [(UEUnk, [UELink])]
, UEBlank
, [UE_RO]
, [UEUnk]
)
splitTo prec from0 fromUnk (t0 :| ts) = do
-- How to split the credit side of the database transaction in 1024 easy
-- steps:
--
-- 1. Split incoming entries (except primary) into those with links and not
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateCurrencies DBUpdates {duNewCurrencyIds} = do
curs' <- selectE $ E.from $ E.table @CurrencyR
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
mapM_ deleteCurrency toDel
mapM_ insertFull toIns
-- 2. For unlinked entries, split into read-only and unknown entries
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateDBState u = do
updateHashes u
updateTags u
updateAccounts u
updateCurrencies u
-- 3. For linked entries, split into those that link to the primary debit
-- entry and not
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
-- 4. For linked entries that don't link to the primary debit entry, split
-- into those that link to an unknown debit entry or not. Those that
-- are not will be read-only and those that are will be collected with
-- their linked debit entry
let linkedRes = zipPaired prec fromUnk linkedN
-- 5. For entries linked to the primary debit entry, turn them into linked
-- entries (lazily only used when needed later)
let from0Res = mapErrors (makeLinkUnk . snd) linked0
combineErrorM3 from0Res linkedRes unlinkedRes $
-- 6. Depending on the type of primary debit entry we have, add linked
-- entries if it is either an unknown or a blank (to be solved) entry,
-- or turn the remaining linked entries to read-only and add to the other
-- read-only entries
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
let (from0', toROLinked0) = case from0 of
Left blnk -> (Left (blnk, from0Links), [])
Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
where
primary = uncurry makeUnkUE t0
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
-- | Match linked credit entries with unknown entries, returning a list of
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
-- sorted.
zipPaired
:: Precision
-> [UEUnk]
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired prec = go ([], [])
where
nolinks = ((,[]) <$>)
go acc fs [] = return $ first (nolinks fs ++) acc
go (facc, tacc) fs ((ti, tls) : ts) = do
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
links <- NE.toList <$> mapErrors makeLinkUnk tls
let (nextLink, fs') = case rest of
(r0 : rs)
| ueIndex r0 == ti -> (Just (r0, links), rs)
| otherwise -> (Nothing, rest)
_ -> (Nothing, rest)
let acc' = (nolinks lesser ++ facc, tacc)
let ros = NE.toList $ makeRoUE prec . snd <$> tls
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
go (f acc') fs' ts
makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
makeLinkUnk (k, e) =
-- TODO error should state that scale must be present for a link in the db
maybe
(throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
(return . makeUE k e . LinkScale)
$ fromRational <$> entryRCachedValue e
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
splitDeferredValue prec p@(k, _) = do
res <- readDeferredValue prec p
case res of
Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
Right x -> return x
readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
where
go = return . Right . Right
err = throwAppError . DBError . DBLinkError k
makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e ()
insertAll
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
=> [EntryCRU]
-> m ()
insertAll ebs = do
(toUpdate, toInsert) <- balanceTxs ebs
mapM_ updateTx toUpdate
forM_ (groupWith itxCommit toInsert) $
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
where
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
let fs = NE.toList iesFromEntries
let ts = NE.toList iesToEntries
let rebalance = any (isJust . ieCached) (fs ++ ts)
esk <- insert $ EntrySetR tk iesCurrency i rebalance
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
go k i e = void $ insertEntry k i e
insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
insertEntry
k
i
InsertEntry
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
, ieCached
} =
do
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
mapM_ (insert_ . TagRelationR ek) eTags
return ek
where
(cval, ctype, deflink) = case ieCached of
(Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
(Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
(Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
Nothing -> (Nothing, Just TFixed, Nothing)
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
where
v = toRational $ unStaticValue ueValue
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)

429
lib/Internal/History.hs
View File

@ -1,15 +1,16 @@
module Internal.History
( splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
( readHistStmt
, readHistTransfer
, splitHistory
)
where
import Control.Monad.Except
import Data.Csv
import Database.Persist.Monad
import Internal.Database
import Data.Decimal
import Data.Foldable
import Data.Hashable
import GHC.Real
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
@ -20,107 +21,55 @@ import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
splitHistory :: [History] -> ([HistTransfer], [Statement])
-- NOTE keep statement and transfer readers separate because the former needs
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
-- thingy
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
insertHistTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
--------------------------------------------------------------------------------
-- Transfers
readHistTransfer
:: (MonadAppError m, MonadFinance m)
=> PairedTransfer
-> m [Tx CommitR]
readHistTransfer ht = do
bounds <- asks (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht
where
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
--------------------------------------------------------------------------------
-- Statements
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Maybe (CommitR, [KeyTx]))
readHistStmt root i = whenHash_ CTImport i $ do
-> m [Tx CommitR]
readHistStmt root i = do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
bounds <- asks (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
where
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txEntries = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txEntries = ss} =
fmap (\kss -> t {txEntries = kss}) $
combineErrors $
fmap resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
--------------------------------------------------------------------------------
-- Statements
c = CommitR (CommitHash $ hash i) CTHistoryStatement
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt paths
m <- askDBState kmCurrency
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
fromEither =<< runExceptT (matchRecords compiledMatches records)
where
paths = (root </>) <$> stmtPaths
@ -133,9 +82,9 @@ readImport_
-> m [TxRecord]
readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Left m -> throwIO $ AppException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@ -149,18 +98,18 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
if d == ""
then return Nothing
else do
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
e <- r .: T.encodeUtf8 toDesc
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
(ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ AppException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
@ -214,9 +163,10 @@ zipperSlice f x = go
LT -> z
zipperMatch
:: Unzipped MatchRe
:: MonadFinance m
=> Unzipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -230,9 +180,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch'
:: Zipped MatchRe
:: MonadFinance m
=> Zipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
@ -249,7 +200,11 @@ matchDec m = case spTimes m of
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchAll
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
@ -259,13 +214,21 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchGroup
:: MonadFinance m
=> MatchGroup
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchDates
:: MonadFinance m
=> [MatchRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -286,7 +249,11 @@ matchDates ms = go ([], [], initZipper ms)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchNonDates
:: MonadFinance m
=> [MatchRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -303,26 +270,246 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> InsertExcept BalTx
balanceTx t@Tx {txEntries = ss} = do
bs <- balanceEntries ss
return $ t {txEntries = bs}
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
balanceEntries ss =
fmap concat
<$> mapM (uncurry bal)
$ groupByKey
$ fmap (\s -> (eCurrency s, s)) ss
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
res <- liftInner $
combineError3 val other desc $
\x y z -> x && y && z && date
if res
then maybe (return MatchSkip) convert spTx
else return MatchFail
where
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
bal cur rss
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
| otherwise = case partitionEithers $ fmap haeValue rss of
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
val = valMatches spVal $ toRational trAmount
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
toTx
priority
TxGetter
{ tgFrom
, tgTo
, tgCurrency
, tgOtherEntries
, tgScale
}
r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ txDate = trDate
, txDescr = trDesc
, txCommit = ()
, txPrimary =
Left $
EntrySet
{ esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
, txOther = Left <$> ss
, txBudget = historyName
, txPriority = priority
}
where
curRes = do
m <- asks csCurrencyMap
cur <- liftInner $ resolveCurrency m r tgCurrency
let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
resolveSubGetter
:: MonadFinance m
=> TxRecord
-> TxSubGetter
-> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- asks csCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency
let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
let valRes = liftInner $ resolveValue prec r tsgValue
liftInner $ combineErrorM toRes valRes $ \t v -> do
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
return $
EntrySet
{ esTotalValue = ()
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
resolveHalfEntry
:: (Precision -> TxRecord -> n -> AppExcept v')
-> Precision
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
-> AppExcept (HalfEntrySet v v')
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = v
, eComment = thgComment
, eTags = thgTags
}
, hesOther = es
}
where
acntRes = resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f prec r) thgEntries
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveEntry
:: (Precision -> TxRecord -> n -> AppExcept v)
-> Precision
-> TxRecord
-> EntryGetter n
-> AppExcept (Entry AcntID v TagID)
resolveEntry f prec r s@Entry {eAcnt, eValue} =
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
where
acntRes = resolveAcnt r eAcnt
valRes = f prec r eValue
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveFromValue = resolveValue
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
resolveValue prec TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return $ EntryFixed $ go c
AmountN m -> return $ EntryFixed $ trAmount *. m
BalanceN x -> return $ EntryBalance $ go x
PercentN x -> return $ EntryPercent x
where
go = realFracToDecimalP prec
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
resolveCurrency m r c = do
i <- resolveEntryField CurField r (unCurID <$> c)
case M.lookup (CurID i) m of
Just k -> return k
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
ConstT p -> return p
LookupT f -> lookup_ f o
MapT (Field f m) -> do
k <- lookup_ f o
lookup_ k m
Map2T (Field (f1, f2) m) -> do
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
lookup_ = lookupErr (EntryIDField t)
readDouble :: T.Text -> AppExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> return x
Nothing -> throwError $ AppException [ConversionError s True]
readRational :: T.Text -> AppExcept Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
(Just x', Just y') ->
let p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
where
readT = readMaybe . T.unpack
err = throwError $ AppException [ConversionError s False]
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept MatchRe
compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
go = compileRegex False
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> return (pat, re)
Left _ -> throwError $ AppException [RegexError pat]
where
res =
compile
(blankCompOpt {newSyntax = True})
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> AppExcept Bool
matchMaybe q re = case execute re q of
Right res -> return $ isJust res
Left _ -> throwError $ AppException [RegexError "this should not happen"]
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of
Right Nothing -> []
Right (Just (_, _, _, xs)) -> xs
-- this should never fail as regexec always returns Right
Left _ -> []
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
[sign, x, y] -> do
d <- readT "decimal" y
let p = T.length y
(k, w) <- readWhole sign x
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
_ -> msg "malformed decimal"
where
readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
T.unpack $
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
readSign x
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
readWhole sign x = do
w <- readT "whole number" x
k <- readSign sign
return (k, w)
historyName :: BudgetName
historyName = BudgetName "history"

152
lib/Internal/Types/Database.hs
View File

@ -7,9 +7,12 @@
-- | Types corresponding to the database model
module Internal.Types.Database where
import Data.Csv (FromField)
import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH
import Internal.Types.Dhall
import RIO
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
@ -17,51 +20,94 @@ share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits
hash Int
hash CommitHash
type ConfigType
deriving Show Eq
UniqueCommitHash hash
deriving Show Eq Ord
ConfigStateR sql=config_state
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
CurrencyR sql=currencies
symbol T.Text
symbol CurID
fullname T.Text
precision Int
deriving Show Eq
precision Precision
UniqueCurrencySymbol symbol
UniqueCurrencyFullname fullname
deriving Show Eq Ord
TagR sql=tags
symbol T.Text
symbol TagID
fullname T.Text
deriving Show Eq
UniqueTagSymbol symbol
UniqueTagFullname fullname
deriving Show Eq Ord
AccountR sql=accounts
name T.Text
fullpath T.Text
fullpath AcntPath
desc T.Text
deriving Show Eq
sign AcntSign
leaf Bool
UniqueAccountFullpath fullpath
deriving Show Eq Ord
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
parent AccountRId
child AccountRId
depth Int
deriving Show Eq
deriving Show Eq Ord
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
commit CommitRId
date Day
description T.Text
description TxDesc
budgetName BudgetName
priority Int
deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId
currency CurrencyRId
index EntrySetIndex
rebalance Bool
deriving Show Eq
EntryR sql=entries
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
entryset EntrySetRId
account AccountRId
memo T.Text
value Rational
index EntryIndex
cachedValue (Maybe Rational)
cachedType (Maybe TransferType)
cachedLink (Maybe EntryIndex)
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade
tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
entry EntryRId OnDeleteCascade
budgetName T.Text
entry EntryRId
tag TagRId
deriving Show Eq
|]
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype TxDesc = TxDesc {unTxDesc :: T.Text}
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
newtype Precision = Precision {unPrecision :: Word8}
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
type DaySpan = (Day, Int)
newtype CommitHash = CommitHash {unCommitHash :: Int}
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
deriving (Eq, Show, Read, Enum, Ord)
instance PersistFieldSql ConfigType where
sqlType _ = SqlString
@ -69,7 +115,61 @@ instance PersistFieldSql ConfigType where
instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
fromPersistValue _ = Left "not a string"
data AcntSign = Credit | Debit
deriving (Show, Eq, Ord)
instance PersistFieldSql AcntSign where
sqlType _ = SqlInt64
instance PersistField AcntSign where
toPersistValue Debit = PersistInt64 1
toPersistValue Credit = PersistInt64 (-1)
fromPersistValue (PersistInt64 1) = Right Debit
fromPersistValue (PersistInt64 (-1)) = Right Credit
fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
fromPersistValue _ = Left "not an Int64"
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Hashable, Generic, Read)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Hashable, Generic, Read)
acntPath2Text :: AcntPath -> T.Text
acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
instance PersistFieldSql AcntPath where
sqlType _ = SqlString
instance PersistField AcntPath where
toPersistValue = PersistText . acntPath2Text
fromPersistValue (PersistText v) = case T.split (== '/') v of
[] -> Left "path is empty"
(x : xs) -> case readMaybe $ T.unpack x of
Just t -> Right $ AcntPath t xs
_ -> Left "could not get account type"
fromPersistValue _ = Left "not a string"

177
lib/Internal/Types/Dhall.hs
View File

@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -33,13 +33,14 @@ makeHaskellTypesWith
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@ -48,12 +49,17 @@ makeHaskellTypesWith
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor
"Amount"
"Amount"
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
, SingleConstructor
"TxOpts"
"TxOpts"
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -61,14 +67,9 @@ makeHaskellTypesWith
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
, SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
, SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
]
deriveProduct
@ -95,9 +96,9 @@ deriveProduct
, "DateMatcher"
, "ValMatcher"
, "YMDMatcher"
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter"
, "LinkedNumGetter"
, "LinkedEntryNumGetter"
, "TemporalScope"
, "SqlConfig"
, "PretaxValue"
@ -106,8 +107,8 @@ deriveProduct
, "TaxProgression"
, "TaxMethod"
, "PosttaxValue"
, "BudgetTransferValue"
, "BudgetTransferType"
, "TransferValue"
, "TransferType"
, "Period"
, "PeriodType"
, "HourlyPeriod"
@ -178,22 +179,24 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat
type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
deriving instance Hashable BudgetTransfer
deriving instance Hashable PairedTransfer
deriving instance Generic BudgetTransfer
deriving instance Generic PairedTransfer
deriving instance FromDhall BudgetTransfer
deriving instance FromDhall PairedTransfer
newtype BudgetName = BudgetName {unBudgetName :: T.Text}
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Budget = Budget
{ bgtLabel :: Text
{ bgtLabel :: BudgetName
, bgtIncomes :: [Income]
, bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [BudgetTransfer]
, bgtTransfers :: [PairedTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval)
}
@ -212,15 +215,28 @@ deriving instance Hashable PosttaxValue
deriving instance Hashable Budget
deriving instance Hashable BudgetTransferValue
deriving instance Hashable TransferValue
deriving instance Hashable BudgetTransferType
deriving instance Hashable TransferType
deriving instance Read TransferType
instance PersistFieldSql TransferType where
sqlType _ = SqlString
instance PersistField TransferType where
toPersistValue = PersistText . T.pack . show
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
type CurID = T.Text
newtype CurID = CurID {unCurID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Income = Income
{ incGross :: Double
@ -232,6 +248,7 @@ data Income = Income
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
, incPayPeriod :: !Period
, incPriority :: !Int
}
deriving instance Hashable HourlyPeriod
@ -250,20 +267,13 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
deriving instance (Show w, Show v) => Show (Amount w v)
deriving instance (Eq w, Eq v) => Eq (Amount w v)
deriving instance Hashable Exchange
deriving instance Hashable BudgetCurrency
data Allocation w v = Allocation
{ alloTo :: TaggedAcnt
, alloAmts :: [Amount w v]
, alloCur :: CurID
}
deriving (Eq, Show, Generic, Hashable)
@ -340,6 +350,10 @@ instance Ord DateMatcher where
deriving instance Hashable EntryNumGetter
deriving instance Hashable LinkedNumGetter
deriving instance Hashable LinkedEntryNumGetter
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type
@ -362,7 +376,7 @@ data AccountRoot_ a = AccountRoot_
, arIncome :: ![a]
, arLiabilities :: ![a]
}
deriving (Generic)
deriving (Generic, Hashable)
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
@ -371,10 +385,8 @@ deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree
data Config_ a = Config_
{ global :: !TemporalScope
, budget :: ![Budget]
{ scope :: !TemporalScope
, currencies :: ![Currency]
, statements :: ![History]
, accounts :: !a
, tags :: ![Tag]
, sqlConfig :: !SqlConfig
@ -404,55 +416,44 @@ instance FromDhall a => FromDhall (Config_ a)
-- dhall type overrides (since dhall can't import types with parameters...yet)
-- TODO newtypes for these?
type AcntID = T.Text
newtype AcntID = AcntID {unAcntID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type TagID = T.Text
type HistTransfer = Transfer AcntID CurID DatePat Double
deriving instance Generic HistTransfer
deriving instance Hashable HistTransfer
deriving instance FromDhall HistTransfer
newtype TagID = TagID {unTagID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data History
= HistTransfer !HistTransfer
= HistTransfer !PairedTransfer
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
type EntryGetter n = Entry EntryAcnt n TagID
instance FromDhall EntryGetter
type FromEntryGetter = EntryGetter EntryNumGetter
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
type ToEntryGetter = EntryGetter LinkedEntryNumGetter
deriving instance Generic (Entry a v c t)
instance FromDhall FromEntryGetter
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
instance FromDhall ToEntryGetter
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txEntries :: ![s]
}
deriving (Generic)
deriving instance Generic (Entry a v t)
type ExpTx = Tx EntryGetter
deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
instance FromDhall ExpTx
deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !T.Text
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toAmountFmt :: !re
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
deriving instance Eq a => Eq (TxOpts a)
deriving instance Generic (TxOpts a)
deriving instance Hashable a => Hashable (TxOpts a)
deriving instance FromDhall a => FromDhall (TxOpts a)
deriving instance Show a => Show (TxOpts a)
data Statement = Statement
{ stmtPaths :: ![FilePath]
@ -461,7 +462,7 @@ data Statement = Statement
, stmtTxOpts :: !(TxOpts T.Text)
, stmtSkipLines :: !Natural
}
deriving (Eq, Hashable, Generic, FromDhall)
deriving (Eq, Hashable, Generic, FromDhall, Show)
-- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
@ -471,7 +472,7 @@ data EntryTextGetter t
| LookupT !T.Text
| MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall)
deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
type EntryCur = EntryTextGetter CurID
@ -503,10 +504,32 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text)
data TxHalfGetter e = TxHalfGetter
{ thgAcnt :: !EntryAcnt
, thgComment :: !T.Text
, thgTags :: ![TagID]
, thgEntries :: ![e]
}
deriving (Eq, Generic, Hashable, Show)
deriving instance FromDhall (TxHalfGetter FromEntryGetter)
deriving instance FromDhall (TxHalfGetter ToEntryGetter)
data TxSubGetter = TxSubGetter
{ tsgFrom :: !(TxHalfGetter FromEntryGetter)
, tsgTo :: !(TxHalfGetter ToEntryGetter)
, tsgValue :: !EntryNumGetter
, tsgCurrency :: !EntryCur
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data TxGetter = TxGetter
{ tgCurrency :: !EntryCur
, tgAcnt :: !EntryAcnt
, tgEntries :: ![EntryGetter]
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
, tgTo :: !(TxHalfGetter ToEntryGetter)
, tgCurrency :: !EntryCur
, tgOtherEntries :: ![TxSubGetter]
, tgScale :: !Double
}
deriving (Eq, Generic, Hashable, Show, FromDhall)

300
lib/Internal/Types/Main.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
@ -12,11 +11,11 @@ module Internal.Types.Main
where
import Control.Monad.Except
import Data.Decimal
import Database.Persist.Sql hiding (Desc, In, Statement)
import Dhall hiding (embed, maybe)
import Internal.Types.Database
import Internal.Types.Dhall
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
@ -27,99 +26,139 @@ import Text.Regex.TDFA
--------------------------------------------------------------------------------
-- database cache types
data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
, chExpense :: ![Int]
, chManual :: ![Int]
, chImport :: ![Int]
type MonadFinance = MonadReader ConfigState
data DeleteTxs = DeleteTxs
{ dtTxs :: ![TransactionRId]
, dtEntrySets :: ![EntrySetRId]
, dtEntries :: ![EntryRId]
, dtTagRelations :: ![TagRelationRId]
}
deriving (Show)
type CDOps c d = CRUDOps [c] () () [d]
-- TODO split the entry stuff from the account metadata stuff
data ConfigState = ConfigState
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
, csAccounts :: !(CDOps (Entity AccountR) AccountRId)
, csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
, csTags :: !(CDOps (Entity TagR) TagRId)
, csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csAccountMap :: !AccountMap
, csCurrencyMap :: !CurrencyMap
, csTagMap :: !TagMap
, csBudgetScope :: !BudgetSpan
, csHistoryScope :: !HistorySpan
}
deriving (Show)
data ExistingConfig = ExistingConfig
{ ecAccounts :: !(Set AccountRId)
, ecTags :: !(Set TagRId)
, ecCurrencies :: !(Set CurrencyRId)
}
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type AccountMap = M.Map AcntID (AccountRId, AcntType)
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
deriving (Show)
type CurrencyMap = M.Map CurID CurrencyPrec
type TagMap = M.Map TagID TagRId
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
data CRUDOps c r u d = CRUDOps
{ coCreate :: !c
, coRead :: !r
, coUpdate :: !u
, coDelete :: !d
}
deriving (Show)
data DBUpdates = DBUpdates
{ duOldCommits :: ![Int]
, duNewTagIds :: ![Entity TagR]
, duNewAcntPaths :: ![AccountPathR]
, duNewAcntIds :: ![Entity AccountR]
, duNewCurrencyIds :: ![Entity CurrencyR]
data CachedEntry
= CachedLink EntryIndex LinkScale
| CachedBalance Decimal
| CachedPercent Double
data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId
, reAcnt :: !AccountRId
, reValue :: !Decimal
, reDate :: !Day
, rePriority :: !Int
, reBudget :: !BudgetName
}
deriving (Show)
type CurrencyM = Reader CurrencyMap
data UpdateEntry i v = UpdateEntry
{ ueID :: !i
, ueAcnt :: !AccountRId
, ueValue :: !v
, ueIndex :: !EntryIndex
}
deriving (Show)
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
deriving instance Functor (UpdateEntry i)
type KeyTx = Tx KeyEntry
newtype LinkScale = LinkScale {unLinkScale :: Double}
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
type TreeR = Tree ([T.Text], AccountRId)
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
deriving newtype (Num, Show)
type MonadFinance = MonadReader DBState
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
type UEUnk = UpdateEntry EntryRId EntryValueUnk
type UELink = UpdateEntry EntryRId LinkScale
type UEBlank = UpdateEntry EntryRId ()
type UE_RO = UpdateEntry () StaticValue
type UEBalanced = UpdateEntry EntryRId StaticValue
data UpdateEntrySet f t = UpdateEntrySet
{ utFrom0 :: !f
, utTo0 :: !UEBlank
, utFromUnk :: ![(UEUnk, [UELink])]
, utToUnk :: ![UEUnk]
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utDate :: !Day
, utTotalValue :: !t
, utBudget :: !BudgetName
, utPriority :: !Int
}
deriving (Show)
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryCRU
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry
| ToInsert (Tx CommitR)
-------------------------------------------------------------------------------
-- misc
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord
{ trDate :: !Day
, trAmount :: !Rational
, trDesc :: !T.Text
, trAmount :: !Decimal
, trDesc :: !TxDesc
, trOther :: !(M.Map T.Text T.Text)
, trFile :: !FilePath
}
deriving (Show, Eq, Ord)
type DaySpan = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit
accountSign ExpenseT = Debit
@ -127,21 +166,81 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
data HalfEntrySet v0 vN = HalfEntrySet
{ hesPrimary :: !(Entry AcntID v0 TagID)
, hesOther :: ![Entry AcntID vN TagID]
}
deriving (Show)
type BalEntry = Entry AcntID Rational CurID TagID
data EntrySet v0 vp0 vpN vtN = EntrySet
{ esTotalValue :: !v0
, esCurrency :: !CurrencyRId
, esFrom :: !(HalfEntrySet vp0 vpN)
, esTo :: !(HalfEntrySet () vtN)
}
deriving (Show)
type RawTx = Tx RawEntry
type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
type BalTx = Tx BalEntry
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
type TransferEntrySet = SecondayEntrySet
type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data Tx k = Tx
{ txDescr :: !TxDesc
, txDate :: !Day
, txPriority :: !Int
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
, txCommit :: !k
, txBudget :: !BudgetName
}
deriving (Generic, Show)
data InsertEntry = InsertEntry
{ ieCached :: !(Maybe CachedEntry)
, ieEntry :: !(Entry AccountRId Decimal TagRId)
}
data InsertEntrySet = InsertEntrySet
{ iesCurrency :: !CurrencyRId
, iesFromEntries :: !(NonEmpty InsertEntry)
, iesToEntries :: !(NonEmpty InsertEntry)
}
data InsertTx = InsertTx
{ itxDescr :: !TxDesc
, itxDate :: !Day
, itxPriority :: !Int
, itxEntrySets :: !(NonEmpty InsertEntrySet)
, itxCommit :: !CommitR
, itxBudget :: !BudgetName
}
deriving (Generic)
data EntryValue_ a = EntryValue_ TransferType a
deriving (Show, Functor, Foldable, Traversable)
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
deriving (Show, Eq, Ord)
data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
deriving (Show)
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
--------------------------------------------------------------------------------
-- exception types
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show)
data EntryIDType = AcntField | CurField | TagField deriving (Show)
@ -153,48 +252,49 @@ data LookupSuberr
| DBKey !EntryIDType
deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data InsertError
data DBLinkSubError
= DBLinkNoScale
| DBLinkNoValue
| DBLinkInvalidValue !Rational !Bool
| DBLinkInvalidBalance
| DBLinkInvalidPercent
deriving (Show)
data DBSubError
= DBShouldBeEmpty
| DBMultiScope
| DBUpdateUnbalanced
| DBLinkError !EntryRId !DBLinkSubError
deriving (Show)
data AppError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !(NE.NonEmpty AcntType)
| InsertIOError !T.Text
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
| StatementIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text
| ConversionError !T.Text !Bool
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![RawEntry]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex
| DBError !DBSubError
deriving (Show)
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
newtype AppException = AppException [AppError]
deriving (Show, Semigroup) via [AppError]
instance Exception InsertException
instance Exception AppException
type MonadInsertError = MonadError InsertException
type MonadAppError = MonadError AppException
type InsertExceptT = ExceptT InsertException
type AppExceptT = ExceptT AppException
type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type AppExcept = AppExceptT Identity
type MatchRe = StatementParser (T.Text, Regex)

1046
lib/Internal/Utils.hs
View File

File diff suppressed because it is too large Load Diff

1
package.yaml
View File

@ -87,6 +87,7 @@ dependencies:
- filepath
- mtl
- persistent-mtl >= 0.3.0.0
- Decimal >= 0.5.2
library:
source-dirs: lib/