pwncash/lib/Internal/Statement.hs

242 lines
7.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE RecordWildCards #-}
2023-01-05 22:23:22 -05:00
module Internal.Statement
( readImport
)
where
2023-05-07 20:29:33 -04:00
import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Csv
import Internal.Types
import Internal.Utils
import RIO
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.Text as T
import RIO.Time
import qualified RIO.Vector as V
2022-12-11 18:34:05 -05:00
2022-12-11 17:51:11 -05:00
-- TODO this probably won't scale well (pipes?)
2023-05-07 20:29:33 -04:00
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
readImport Statement {..} = do
2023-05-07 20:29:33 -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 stmtPaths
2023-05-04 21:48:21 -04:00
m <- askDBState kmCurrency
2023-05-07 20:29:33 -04:00
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
2023-01-05 22:23:22 -05:00
readImport_
2023-05-07 20:29:33 -04:00
:: (MonadUnliftIO m, MonadFinance m)
2023-01-05 22:23:22 -05:00
=> Natural
-> Word
-> TxOptsRe
2023-01-05 22:23:22 -05:00
-> FilePath
2023-05-07 20:29:33 -04:00
-> m [TxRecord]
2022-12-11 17:51:11 -05:00
readImport_ n delim tns p = do
2023-02-12 16:23:32 -05:00
dir <- askDBState kmConfigDir
2023-05-07 20:29:33 -04:00
res <- tryIO $ BL.readFile $ dir </> p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
2023-01-24 23:24:41 -05:00
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
2023-05-07 20:29:33 -04:00
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
Right (_, v) -> return $ catMaybes $ V.toList v
2022-12-11 17:51:11 -05:00
where
2023-01-05 22:23:22 -05:00
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
2022-12-11 17:51:11 -05:00
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)
2023-01-24 23:24:41 -05:00
parseTxRecord p TxOpts {..} r = do
2023-01-05 22:23:22 -05:00
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
2023-01-24 23:24:41 -05:00
return $ Just $ TxRecord d' a e os p
2023-05-07 20:29:33 -04:00
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
2023-01-24 23:24:41 -05:00
matchRecords ms rs = do
2023-05-07 20:29:33 -04:00
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
-- TODO record number of times each match hits for debugging
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
2022-12-11 17:51:11 -05:00
2023-02-01 23:02:07 -05:00
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
2023-01-05 22:23:22 -05:00
fmap matchToGroup
2023-04-30 23:28:16 -04:00
. L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority)
2022-12-11 17:51:11 -05:00
2023-02-01 23:02:07 -05:00
matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms =
2023-01-05 22:23:22 -05:00
uncurry MatchGroup $
2023-04-30 23:28:16 -04:00
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
2022-12-11 17:51:11 -05:00
-- TDOO could use a better struct to flatten the maybe date subtype
data MatchGroup = MatchGroup
2023-02-01 23:02:07 -05:00
{ mgDate :: ![MatchRe]
, mgNoDate :: ![MatchRe]
2023-01-05 22:23:22 -05:00
}
deriving (Show)
2022-12-11 17:51:11 -05:00
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
2023-01-27 20:31:13 -05:00
zipperSlice
2023-01-28 19:32:56 -05:00
:: (a -> b -> Ordering)
2023-01-27 20:31:13 -05:00
-> b
-> Zipped a
2023-01-28 19:32:56 -05:00
-> Either (Zipped a) (Unzipped a)
2022-12-11 17:51:11 -05:00
zipperSlice f x = go
where
2023-01-28 19:32:56 -05:00
go z@(Zipped _ []) = Left z
go z@(Zipped bs (a : as)) =
case f a x of
2023-01-25 23:04:54 -05:00
GT -> go $ Zipped (a : bs) as
2023-01-28 19:32:56 -05:00
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
2023-01-25 23:04:54 -05:00
GT -> goEq $ Unzipped (a : bs) cs as
EQ -> goEq $ Unzipped bs (a : cs) as
2023-01-28 19:32:56 -05:00
LT -> z
2022-12-11 17:51:11 -05:00
2023-05-04 21:48:21 -04:00
zipperMatch
:: Unzipped MatchRe
-> TxRecord
2023-05-07 20:29:33 -04:00
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
2022-12-11 17:51:11 -05:00
zipperMatch (Unzipped bs cs as) x = go [] cs
where
2023-05-07 20:29:33 -04:00
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = do
res <- matches m x
case res of
2023-05-07 20:29:33 -04:00
MatchFail -> go (m : prev) ms
skipOrPass ->
let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m)
2023-05-07 20:29:33 -04:00
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
2023-05-04 21:48:21 -04:00
-- TODO all this unpacking left/error crap is annoying
zipperMatch'
:: Zipped MatchRe
-> TxRecord
2023-05-07 20:29:33 -04:00
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
2022-12-11 17:51:11 -05:00
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
res <- matches a x
case res of
2023-05-07 20:29:33 -04:00
MatchFail -> go (Zipped (a : bs) as)
skipOrPass ->
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
2022-12-11 17:51:11 -05:00
2023-02-01 23:02:07 -05:00
matchDec :: MatchRe -> Maybe MatchRe
2023-04-30 23:28:16 -04:00
matchDec m = case spTimes m of
2023-01-29 11:36:12 -05:00
Just 1 -> Nothing
2023-04-30 23:28:16 -04:00
Just n -> Just $ m {spTimes = Just $ n - 1}
2023-01-28 21:38:54 -05:00
Nothing -> Just m
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
2022-12-11 17:51:11 -05:00
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
2023-05-07 20:29:33 -04:00
(_, []) -> return (matched, [], unused)
([], _) -> return (matched, rs, unused)
(g : gs', _) -> do
2023-05-07 20:29:33 -04:00
(ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched
2023-05-07 20:29:33 -04:00
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
2023-05-07 20:29:33 -04:00
(md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
2023-05-07 20:29:33 -04:00
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
2022-12-11 17:51:11 -05:00
matchDates ms = go ([], [], initZipper ms)
where
2023-01-07 23:42:04 -05:00
go (matched, unmatched, z) [] =
2023-05-07 20:29:33 -04:00
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
)
2023-01-28 19:32:56 -05:00
go (matched, unmatched, z) (r : rs) =
case zipperSlice findDate r z of
2023-01-25 23:04:54 -05:00
Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do
2023-05-07 20:29:33 -04:00
(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
2023-04-30 23:28:16 -04:00
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
2022-12-11 17:51:11 -05:00
matchNonDates ms = go ([], [], initZipper ms)
where
2023-01-07 23:42:04 -05:00
go (matched, unmatched, z) [] =
2023-05-07 20:29:33 -04:00
return
( catMaybes matched
, reverse unmatched
, recoverZipper z
)
go (matched, unmatched, z) (r : rs) = do
2023-05-07 20:29:33 -04:00
(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
balanceTx :: RawTx -> InsertExcept BalTx
2023-01-05 22:23:22 -05:00
balanceTx t@Tx {txSplits = ss} = do
bs <- balanceSplits ss
return $ t {txSplits = bs}
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
balanceSplits ss =
2023-01-05 22:23:22 -05:00
fmap concat
<$> mapM (uncurry bal)
$ groupByKey
2023-04-30 23:28:16 -04:00
$ fmap (\s -> (eCurrency s, s)) ss
2022-12-11 17:51:11 -05:00
where
2023-04-30 23:28:16 -04:00
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
2022-12-11 17:51:11 -05:00
bal cur rss
2023-05-07 20:29:33 -04:00
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
2023-04-30 23:28:16 -04:00
| otherwise = case partitionEithers $ fmap haeValue rss of
2023-05-07 20:29:33 -04:00
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
2022-12-11 17:51:11 -05:00
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))