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

ENH store account sign in db itself

This commit is contained in:
Nathan Dwarshuis 2023-07-09 11:13:35 -04:00
parent 9c93ad25af
commit c8f7689c7a
4 changed files with 60 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lib/Internal/Database.hs
View File

@ -201,7 +201,7 @@ 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
AccountR name (toPath parents) des (accountSign t)
where
p = AcntPath t (reverse (name : parents))
h = hash p
@ -210,7 +210,7 @@ tree2Entity t parents name des =
tree2Records
:: AcntType
-> AccountTree
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))])
tree2Records t = go []
where
go ps (Placeholder d n cs) =
@ -225,10 +225,10 @@ tree2Records t = go []
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))]
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))]
)
toPath = T.intercalate "/" . (atName t :) . reverse
acnt k n ps = Entity k . AccountR n (toPath ps)
acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
sign = accountSign t

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

@ -34,6 +34,7 @@ AccountR sql=accounts
name T.Text
fullpath T.Text
desc T.Text
sign AcntSign
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
@ -78,7 +79,21 @@ 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"

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

@ -35,7 +35,7 @@ data ConfigHashes = ConfigHashes
, chImport :: ![Int]
}
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type AccountMap = M.Map AcntID (AccountRId, AcntType)
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
deriving (Show)
@ -186,9 +186,6 @@ data Keyed a = Keyed
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
-- TODO debit should be negative
sign2Int :: AcntSign -> Int
sign2Int Debit = 1

98
lib/Internal/Utils.hs
View File

@ -30,19 +30,15 @@ module Internal.Utils
, mapErrorsPooledIO
, showError
, acntPath2Text
, showT
, tshow
, lookupErr
, gregorians
, uncurry3
, fstOf3
, sndOf3
, thdOf3
, xGregToDay
, dateMatches
, valMatches
, lookupAccount
, lookupAccountKey
, lookupAccountSign
, lookupAccountType
, lookupCurrency
, lookupCurrencyKey
@ -410,7 +406,7 @@ collectErrorsIO = mapErrorsIO id
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
lookupErr what k m = case M.lookup k m of
Just x -> return x
_ -> throwError $ InsertException [LookupError what $ showT k]
_ -> throwError $ InsertException [LookupError what $ tshow k]
fmtRational :: Natural -> Rational -> T.Text
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
@ -439,7 +435,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
showError :: InsertError -> [T.Text]
showError other = case other of
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
(StatementError ts ms) -> (tshowx <$> ts) ++ (showMatch <$> ms)
(DaySpanError a b) ->
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where
@ -461,9 +457,9 @@ showError other = case other of
keyVals $
[ (k, v)
| (k, Just v) <-
[ ("start", Just $ showT s)
, ("by", Just $ showT b)
, ("repeats", showT <$> r)
[ ("start", Just $ tshow s)
, ("by", Just $ tshow b)
, ("repeats", tshow <$> r)
]
]
msg = case p of
@ -474,7 +470,7 @@ showError other = case other of
(InsertIOError msg) -> [T.append "IO Error: " msg]
(ParseError msg) -> [T.append "Parse Error: " msg]
(MatchValPrecisionError d p) ->
[T.unwords ["Match denominator", showT d, "must be less than", showT p]]
[T.unwords ["Match denominator", tshow d, "must be less than", tshow p]]
(LookupError t f) ->
[T.unwords ["Could not find field", f, "when resolving", what]]
where
@ -494,27 +490,27 @@ showError other = case other of
[ "Income allocations for budget"
, singleQuote name
, "exceed total on day"
, showT day
, tshow day
, "where balance is"
, showT (fromRational balance :: Double)
, tshow (fromRational balance :: Double)
]
]
(PeriodError start next) ->
[ T.unwords
[ "First pay period on "
, singleQuote $ showT start
, singleQuote $ tshow start
, "must start before first income payment on "
, singleQuote $ showT next
, singleQuote $ tshow next
]
]
(IndexError Entry {eValue = LinkedNumGetter {lngIndex}, eAcnt} day) ->
[ T.unwords
[ "No credit entry for index"
, singleQuote $ showT lngIndex
, singleQuote $ tshow lngIndex
, "for entry with account"
, singleQuote eAcnt
, "on"
, showT day
, tshow day
]
]
(RoundError cur) ->
@ -525,15 +521,15 @@ showError other = case other of
]
showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
tshowx :: TxRecord -> T.Text
tshowx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
T.append "Unmatched transaction: " $
keyVals
[ ("path", T.pack f)
, ("date", T.pack $ iso8601Show d)
, ("value", showT v)
, ("value", tshow v)
, ("description", doubleQuote e)
]
@ -546,8 +542,8 @@ showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority}
, ("val", showValMatcher spVal)
, ("desc", fst <$> spDesc)
, ("other", others)
, ("counter", Just $ maybe "Inf" showT spTimes)
, ("priority", Just $ showT spPriority)
, ("counter", Just $ maybe "Inf" tshow spTimes)
, ("priority", Just $ tshow spPriority)
]
others = case spOther of
[] -> Nothing
@ -580,7 +576,7 @@ showYMDMatcher = showYMD_ . fromYMDMatcher
showYMD_ :: YMD_ -> T.Text
showYMD_ md =
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
T.intercalate "-" $ L.take 3 (fmap tshow digits ++ L.repeat "*")
where
digits = case md of
Y_ y -> [fromIntegral y]
@ -594,9 +590,9 @@ showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
where
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
, ("numerator", showT <$> vmNum)
, ("denominator", showT <$> vmDen)
, ("precision", Just $ showT vmPrec)
, ("numerator", tshow <$> vmNum)
, ("denominator", tshow <$> vmDen)
, ("precision", Just $ tshow vmPrec)
]
showMatchOther :: FieldMatcherRe -> T.Text
@ -622,9 +618,6 @@ keyVal a b = T.concat [a, "=", b]
keyVals :: [(T.Text, T.Text)] -> T.Text
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
showT :: Show a => a -> T.Text
showT = T.pack . show
--------------------------------------------------------------------------------
-- random functions
@ -644,26 +637,14 @@ mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
fstOf3 :: (a, b, c) -> a
fstOf3 (a, _, _) = a
sndOf3 :: (a, b, c) -> b
sndOf3 (_, b, _) = b
thdOf3 :: (a, b, c) -> c
thdOf3 (_, _, c) = c
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountKey = fmap fst . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupAccountType = fmap snd . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField kmCurrency
@ -917,8 +898,8 @@ balanceFinal
=> BCKey
-> Decimal
-> NonEmpty InsertEntry
-> Entry (AccountRId, AcntSign) () TagRId
-> [Entry (AccountRId, AcntSign) LinkDeferred TagRId]
-> Entry AccountRId () TagRId
-> [Entry AccountRId LinkDeferred TagRId]
-> StateT EntryBals m InsertEntrySet
balanceFinal k@(curID, _) tot fs t0 ts = do
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
@ -936,18 +917,17 @@ doEntries
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
-> BCKey
-> Decimal
-> Entry (AccountRId, AcntSign) () TagRId
-> [Entry (AccountRId, AcntSign) v TagRId]
-> Entry AccountRId () TagRId
-> [Entry AccountRId v TagRId]
-> StateT EntryBals m (NonEmpty InsertEntry)
doEntries f k tot e@Entry {eAcnt = (acntID, sign)} es = do
doEntries f k tot e@Entry {eAcnt = acntID} es = do
es' <- mapErrors (balanceEntry f k) es
let e0val = tot - entrySum es'
-- TODO not dry
let s = fromIntegral $ sign2Int sign -- NOTE hack
modify (mapAdd_ (acntID, k) e0val)
let e' =
InsertEntry
{ ieEntry = e {eValue = s * e0val, eAcnt = acntID}
{ ieEntry = e {eValue = e0val, eAcnt = acntID}
, ieDeferred = Nothing
}
return $ e' :| es'
@ -988,27 +968,25 @@ balanceEntry
:: (MonadInsertError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
-> BCKey
-> Entry (AccountRId, AcntSign) v TagRId
-> Entry AccountRId v TagRId
-> StateT EntryBals m InsertEntry
balanceEntry f k e@Entry {eValue, eAcnt = (acntID, sign)} = do
let s = fromIntegral $ sign2Int sign
balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
(newVal, deferred) <- f (acntID, k) eValue
modify (mapAdd_ (acntID, k) newVal)
return $
InsertEntry
{ ieEntry = e {eValue = s * newVal, eAcnt = acntID}
{ ieEntry = e {eValue = newVal, eAcnt = acntID}
, ieDeferred = deferred
}
resolveAcntAndTags
:: (MonadInsertError m, MonadFinance m)
=> Entry AcntID v TagID
-> m (Entry (AccountRId, AcntSign) v TagRId)
-> m (Entry AccountRId v TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
let acntRes = lookupAccount eAcnt
let acntRes = lookupAccountKey eAcnt
let tagRes = mapErrors lookupTag eTags
combineError acntRes tagRes $
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
combineError acntRes tagRes $ \a ts -> e {eAcnt = a, eTags = ts}
findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
findBalance k e = do