pwncash/lib/Internal/History.hs

544 lines
17 KiB
Haskell

module Internal.History
( readHistStmt
, readHistTransfer
, splitHistory
)
where
import Control.Monad.Except
import Data.Csv
import Data.Decimal
import Data.Foldable
import Data.Hashable
import GHC.Real
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.Text as T
import RIO.Time
import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
-- 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
-> m [Tx CommitR]
readHistTransfer ht = do
bounds <- askDBState (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht
where
c = CommitR (hash ht) CTHistoryTransfer
--------------------------------------------------------------------------------
-- Statements
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m [Tx CommitR]
readHistStmt root i = do
bs <- readImport root i
bounds <- askDBState (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
where
c = CommitR (hash i) CTHistoryStatement
-- 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
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
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 . tshow) 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 <- 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 :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> return 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
:: MonadFinance m
=> Unzipped MatchRe
-> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
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
-> TxRecord
-> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
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])
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])
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])
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])
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
matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT 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
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 trDesc . snd) spDesc
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> InsertExceptT 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 = roundTo (cpPrec cur) trAmount *. tgScale
, esCurrency = cpID cur
, esFrom = f
, esTo = t
}
, txOther = Left <$> ss
, txBudget = historyName
, txPriority = priority
}
where
curRes = do
m <- askDBState 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
-> InsertExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- askDBState 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 -> InsertExcept v')
-> Precision
-> TxRecord
-> v
-> TxHalfGetter (EntryGetter n)
-> InsertExcept (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 -> 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
:: (Precision -> TxRecord -> n -> InsertExcept v)
-> Precision
-> TxRecord
-> EntryGetter n
-> InsertExcept (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 -> InsertExcept EntryValue
resolveFromValue = resolveValue
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
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 _ -> []
-- 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
[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 :: T.Text
historyName = "history"