pwncash/lib/Internal/History.hs

544 lines
17 KiB
Haskell
Raw Normal View History

2023-05-29 15:56:15 -04:00
module Internal.History
( readHistStmt
, readHistTransfer
, splitHistory
2023-05-29 15:56:15 -04:00
)
where
import Control.Monad.Except
2023-05-29 17:19:49 -04:00
import Data.Csv
2023-07-08 00:52:40 -04:00
import Data.Decimal
import Data.Foldable
2023-07-13 23:31:27 -04:00
import Data.Hashable
2023-07-04 00:11:25 -04:00
import GHC.Real
2023-05-29 15:56:15 -04:00
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
2023-05-29 17:19:49 -04:00
import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import qualified RIO.List as L
import qualified RIO.Map as M
2023-05-29 15:56:15 -04:00
import qualified RIO.Text as T
import RIO.Time
2023-05-29 17:19:49 -04:00
import qualified RIO.Vector as V
2023-07-04 00:11:25 -04:00
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
2023-05-29 15:56:15 -04:00
-- 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
--------------------------------------------------------------------------------
-- Transfers
readHistTransfer
:: (MonadInsertError m, MonadFinance m)
=> PairedTransfer
2023-07-13 23:31:27 -04:00
-> m [Tx CommitR]
readHistTransfer ht = do
2023-07-15 23:25:28 -04:00
bounds <- askDBState (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht
2023-07-13 23:31:27 -04:00
where
2023-07-15 23:25:28 -04:00
c = CommitR (hash ht) CTHistoryTransfer
--------------------------------------------------------------------------------
-- Statements
2023-05-29 15:56:15 -04:00
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
2023-07-13 23:31:27 -04:00
-> m [Tx CommitR]
readHistStmt root i = do
bs <- readImport root i
2023-07-15 23:25:28 -04:00
bounds <- askDBState (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
2023-07-13 23:31:27 -04:00
where
2023-07-15 23:25:28 -04:00
c = CommitR (hash i) CTHistoryStatement
2023-05-29 15:56:15 -04:00
2023-05-29 17:19:49 -04:00
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
2023-05-29 17:19:49 -04:00
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
fromEither =<< runExceptT (matchRecords compiledMatches records)
where
paths = (root </>) <$> stmtPaths
2023-05-29 17:19:49 -04:00
readImport_
:: MonadUnliftIO m
2023-05-29 17:19:49 -04:00
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m [TxRecord]
readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p
2023-07-13 23:31:27 -04:00
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res
2023-05-29 17:19:49 -04:00
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
where
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
d <- r .: T.encodeUtf8 toDate
if d == ""
then return Nothing
else do
2023-07-08 00:52:40 -04:00
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
2023-05-29 17:19:49 -04:00
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 :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
2023-05-29 17:19:49 -04:00
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_
2023-05-29 17:19:49 -04:00
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
fmap matchToGroup
. L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority)
matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms =
uncurry MatchGroup $
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
data MatchGroup = MatchGroup
{ mgDate :: ![MatchRe]
, mgNoDate :: ![MatchRe]
}
deriving (Show)
data Zipped a = Zipped ![a] ![a]
data Unzipped a = Unzipped ![a] ![a] ![a]
initZipper :: [a] -> Zipped a
initZipper = Zipped []
resetZipper :: Zipped a -> Zipped a
resetZipper = initZipper . recoverZipper
recoverZipper :: Zipped a -> [a]
recoverZipper (Zipped as bs) = reverse as ++ bs
zipperSlice
:: (a -> b -> Ordering)
-> b
-> Zipped a
-> Either (Zipped a) (Unzipped a)
zipperSlice f x = go
where
go z@(Zipped _ []) = Left z
go z@(Zipped bs (a : as)) =
case f a x of
GT -> go $ Zipped (a : bs) as
EQ -> Right $ goEq (Unzipped bs [a] as)
LT -> Left z
goEq z@(Unzipped _ _ []) = z
goEq z@(Unzipped bs cs (a : as)) =
case f a x of
GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z
zipperMatch
:: MonadFinance m
=> Unzipped MatchRe
2023-05-29 17:19:49 -04:00
-> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
2023-05-29 17:19:49 -04:00
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = do
res <- matches m x
case res of
MatchFail -> go (m : prev) ms
skipOrPass ->
let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch'
:: MonadFinance m
=> Zipped MatchRe
2023-05-29 17:19:49 -04:00
-> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
2023-05-29 17:19:49 -04:00
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
res <- matches a x
case res of
MatchFail -> go (Zipped (a : bs) as)
skipOrPass ->
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of
Just 1 -> Nothing
Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m
matchAll
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
2023-05-29 17:19:49 -04:00
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
(_, []) -> return (matched, [], unused)
([], _) -> return (matched, rs, unused)
(g : gs', _) -> do
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
matchGroup
:: MonadFinance m
=> MatchGroup
-> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
2023-05-29 17:19:49 -04:00
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
:: MonadFinance m
=> [MatchRe]
-> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
2023-05-29 17:19:49 -04:00
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
)
go (matched, unmatched, z) (r : rs) =
case zipperSlice findDate r z of
Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do
(z', res) <- zipperMatch unzipped r
let (m, u) = case res of
(MatchPass p) -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
matchNonDates
:: MonadFinance m
=> [MatchRe]
-> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
2023-05-29 17:19:49 -04:00
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
)
go (matched, unmatched, z) (r : rs) = do
(z', res) <- zipperMatch' z r
let (m, u) = case res of
MatchPass p -> (Just p : matched, unmatched)
MatchSkip -> (Nothing : matched, unmatched)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
2023-07-04 00:11:25 -04:00
matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
2023-07-04 00:11:25 -04:00
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
2023-07-08 00:52:40 -04:00
val = valMatches spVal $ toRational trAmount
2023-07-04 00:11:25 -04:00
date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
2023-07-04 00:11:25 -04:00
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT m (Tx ())
2023-07-04 00:11:25 -04:00
toTx
priority
2023-07-04 00:11:25 -04:00
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
2023-07-08 00:52:40 -04:00
{ esTotalValue = roundTo (cpPrec cur) trAmount *. tgScale
, esCurrency = cpID cur
2023-07-04 00:11:25 -04:00
, esFrom = f
, esTo = t
}
, txOther = Left <$> ss
, txBudget = historyName
, txPriority = priority
2023-07-04 00:11:25 -04:00
}
where
curRes = do
2023-07-13 23:31:27 -04:00
m <- askDBState csCurrencyMap
2023-07-04 00:11:25 -04:00
cur <- liftInner $ resolveCurrency m r tgCurrency
2023-07-08 00:52:40 -04:00
let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
2023-07-04 00:11:25 -04:00
combineError fromRes toRes (cur,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
resolveSubGetter
:: MonadFinance m
=> TxRecord
-> TxSubGetter
-> InsertExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
2023-07-13 23:31:27 -04:00
m <- askDBState csCurrencyMap
2023-07-04 00:11:25 -04:00
cur <- liftInner $ resolveCurrency m r tsgCurrency
2023-07-08 00:52:40 -04:00
let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
let valRes = liftInner $ resolveValue prec r tsgValue
2023-07-04 00:11:25 -04:00
liftInner $ combineErrorM toRes valRes $ \t v -> do
2023-07-08 00:52:40 -04:00
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
2023-07-04 00:11:25 -04:00
return $
EntrySet
{ esTotalValue = ()
2023-07-08 00:52:40 -04:00
, esCurrency = cpID cur
2023-07-04 00:11:25 -04:00
, esFrom = f
, esTo = t
}
resolveHalfEntry
2023-07-08 00:52:40 -04:00
:: (Precision -> TxRecord -> n -> InsertExcept v')
-> Precision
2023-07-04 00:11:25 -04:00
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
2023-07-08 00:52:40 -04:00
-> InsertExcept (HalfEntrySet v v')
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
2023-07-04 00:11:25 -04:00
combineError acntRes esRes $ \a es ->
HalfEntrySet
{ hesPrimary =
Entry
{ eAcnt = a
, eValue = v
, eComment = thgComment
, eTags = thgTags
}
, hesOther = es
}
where
acntRes = resolveAcnt r thgAcnt
2023-07-08 00:52:40 -04:00
esRes = mapErrors (resolveEntry f prec r) thgEntries
2023-07-04 00:11:25 -04:00
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept 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
2023-07-08 00:52:40 -04:00
:: (Precision -> TxRecord -> n -> InsertExcept v)
-> Precision
2023-07-04 00:11:25 -04:00
-> TxRecord
-> EntryGetter n
2023-07-08 00:52:40 -04:00
-> InsertExcept (Entry AcntID v TagID)
resolveEntry f prec r s@Entry {eAcnt, eValue} =
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
2023-07-04 00:11:25 -04:00
where
acntRes = resolveAcnt r eAcnt
2023-07-08 00:52:40 -04:00
valRes = f prec r eValue
2023-07-04 00:11:25 -04:00
2023-07-08 00:52:40 -04:00
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
2023-07-04 00:11:25 -04:00
resolveFromValue = resolveValue
2023-07-08 00:52:40 -04:00
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept 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 = realFracToDecimal prec
2023-07-04 00:11:25 -04:00
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
resolveCurrency m r c = do
i <- resolveEntryField CurField r c
case M.lookup i m of
Just k -> return k
-- TODO this should be its own error (I think)
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept 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 -> InsertExcept v
lookup_ = lookupErr (EntryIDField t)
readDouble :: T.Text -> InsertExcept Double
readDouble s = case readMaybe $ T.unpack s of
Just x -> return x
Nothing -> throwError $ InsertException [ConversionError s]
readRational :: T.Text -> InsertExcept 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 $ InsertException [ConversionError s]
compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> InsertExcept 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 -> InsertExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> return (pat, re)
Left _ -> throwError $ InsertException [RegexError pat]
where
res =
compile
(blankCompOpt {newSyntax = True})
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> InsertExcept Bool
matchMaybe q re = case execute re q of
Right res -> return $ isJust res
Left _ -> throwError $ InsertException [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 _ -> []
2023-07-08 00:52:40 -04:00
-- parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
-- parseRational (pat, re) s = case matchGroupsMaybe s re of
-- [sign, x, ""] -> uncurry (*) <$> readWhole sign x
-- [sign, x, y] -> do
-- d <- readT "decimal" y
-- let p = 10 ^ T.length y
-- (k, w) <- readWhole sign x
-- return $ k * (w + d % p)
-- _ -> 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)
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
2023-07-04 00:11:25 -04:00
[sign, x, y] -> do
d <- readT "decimal" y
2023-07-08 00:52:40 -04:00
let p = T.length y
2023-07-04 00:11:25 -04:00
(k, w) <- readWhole sign x
2023-07-08 00:52:40 -04:00
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
2023-07-04 00:11:25 -04:00
_ -> 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 :: T.Text
historyName = "history"