pwncash/lib/Internal/History.hs

406 lines
13 KiB
Haskell

module Internal.History
( readHistStmt
, readHistTransfer
, insertHistory
, splitHistory
)
where
import Control.Monad.Except
import Data.Csv
import Data.Foldable
import Database.Persist.Monad hiding (get)
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
-- readHistory
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
-- => FilePath
-- -> [History]
-- -> m [(CommitR, [DeferredTx])]
-- readHistory root hs = do
-- let (ts, ss) = splitHistory hs
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
-- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
-- return $ ts' ++ ss'
readHistTransfer
:: (MonadInsertError m, MonadFinance m)
=> HistTransfer
-> m (Maybe (CommitR, [DeferredTx]))
readHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash_ CTManual m $ 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
return $ fmap tx days
concat <$> mapErrors go amts
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Maybe (CommitR, [DeferredTx]))
readHistStmt root i = whenHash_ CTImport i $ do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
return $ filter (inDaySpan bounds . dtxDate) bs
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
insertHistory
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [(CommitR, [DeferredTx])]
-> m ()
insertHistory hs = do
bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> DeferredTx
txPair day from to cur val desc =
Tx
{ dtxDescr = desc
, dtxDate = day
, dtxEntries =
[ EntrySet
{ desTotalValue = val
, desCurrency = cur
, desFromEntry0 = entry from
, desToEntryBal = entry to
, desFromEntries = []
, desToEntries = []
}
]
}
where
entry a =
Entry
{ eAcnt = a
, eValue = ()
, eComment = ""
, eTags = []
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {dtxEntries = ss} =
(\kss -> t {dtxEntries = kss}) <$> mapErrors resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {dtxDate = d, dtxDescr = e, dtxEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
--------------------------------------------------------------------------------
-- Statements
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx]
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
where
paths = (root </>) <$> stmtPaths
readImport_
:: MonadUnliftIO m
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m [TxRecord]
readImport_ n delim tns p = do
res <- tryIO $ BL.readFile p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
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
a <- parseRational 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
-- TODO need to somehow balance temporally here (like I do in the budget for
-- directives that "pay off" a balance)
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
(_, 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
:: Unzipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
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'
:: Zipped MatchRe
-> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes DeferredTx)
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 :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
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 :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [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 ([DeferredTx], [TxRecord], [MatchRe])
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 :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx], [TxRecord], [MatchRe])
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
-- TDOO should use a better type here to squish down all the entry sets
-- which at this point in the chain should not be necessary
balanceTxs
:: (MonadInsertError m, MonadFinance m)
=> [(CommitR, DeferredTx)]
-> m [(CommitR, KeyTx)]
balanceTxs ts = do
keyts <- mapErrors resolveTx balTs
return $ zip cs keyts
where
(cs, ts') = L.unzip $ L.sortOn (dtxDate . snd) ts
go bals t@Tx {dtxEntries} =
second (\es -> t {dtxEntries = concat es}) $
L.mapAccumL balanceEntrySet bals dtxEntries
balTs = snd $ L.mapAccumL go M.empty ts'
type EntryBals = M.Map (AcntID, CurID) Rational
-- TODO might be faster to also do all the key stuff here since currency
-- will be looked up for every entry rather then the entire entry set
balanceEntrySet :: EntryBals -> DeferredEntrySet -> (EntryBals, [BalEntry])
balanceEntrySet
bals
EntrySet
{ desFromEntry0
, desFromEntries
, desToEntryBal
, desToEntries
, desCurrency
, desTotalValue
} = flipTup $ runState doBalAll bals
where
flipTup (a, b) = (b, a)
doEntries es tot e0 = do
es' <- state (\b -> flipTup $ L.mapAccumL (balanceEntry desCurrency) b es)
let val0 = tot - entrySum es'
modify $ mapAdd_ (eAcnt e0, desCurrency) val0
return $ e0 {eValue = val0} : es'
doBalAll = do
fes <- doEntries desFromEntries desTotalValue desFromEntry0
tes <- doEntries desToEntries (-desTotalValue) desToEntryBal
return $ toFull <$> fes ++ tes
toFull e = FullEntry {feEntry = e, feCurrency = desCurrency}
entrySum :: Num v => [Entry a v t] -> v
entrySum = sum . fmap eValue
balanceEntry
:: CurID
-> EntryBals
-> Entry AcntID (Deferred Rational) TagID
-> (EntryBals, Entry AcntID Rational TagID)
balanceEntry curID bals e@Entry {eValue = Deferred toBal v, eAcnt}
| toBal = (bals, e {eValue = v})
| otherwise = (bals', e {eValue = newVal})
where
key = (eAcnt, curID)
curBal = M.findWithDefault 0 key bals
newVal = v - curBal
bals' = mapAdd_ key newVal bals
-- -- reimplementation from future version :/
-- mapAccumM
-- :: Monad m
-- => (s -> a -> m (s, b))
-- -> s
-- -> [a]
-- -> m (s, [b])
-- mapAccumM f s xs = foldrM go (s, []) xs
-- where
-- go x (s', acc) = second (: acc) <$> f s' x