pwncash/lib/Internal/History.hs

module Internal.History
  ( readHistStmt
  , readHistTransfer
  , splitHistory
  , readHistoryCRUD
  )
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)

readHistoryCRUD
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> PreHistoryCRUD
  -> m FinalHistoryCRUD
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
  -- TODO multithread this for some extra fun :)

  ss' <- mapErrorsIO (readHistStmt root) ss
  fromEitherM $ runExceptT $ do
    let sRes = mapErrors (ExceptT . return) ss'
    let tRes = mapErrors readHistTransfer ts
    combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}

-- 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
  :: (MonadAppError m, MonadFinance m)
  => PairedTransfer
  -> m [Tx CommitR]
readHistTransfer ht = do
  bounds <- asks (unHSpan . tsHistoryScope)
  expandTransfer c bounds ht
  where
    c = CommitR (CommitHash $ hash ht) CTHistoryTransfer

--------------------------------------------------------------------------------
-- Statements

readHistStmt
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
  -> m (Either AppException [Tx CommitR])
readHistStmt root i = do
  bounds <- asks (unHSpan . tsHistoryScope)
  bs <- readImport root i
  return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
  where
    go t@Tx {txMeta = m} =
      t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}

-- TODO this probably won't scale well (pipes?)
readImport
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
  -> m (Either AppException [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
  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 (AppException . (: []) . StatementIOError . tshow) res
  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
    Left m -> throwIO $ AppException [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
    , toDesc
    , toAmount
    , toOther
    , toDateFmt
    , toSkipBlankDate
    , toSkipBlankAmount
    , toSkipBlankDescription
    , toSkipBlankOther
    }
  r =
    do
      -- Parse date, desc, and other fields first. If these are blank and we
      -- allow them to be blank, then skip the line.
      d <- getField toDate
      e <- getField toDesc
      os <- M.fromList <$> mapM (\n -> (n,) <$> getField n) toOther
      let skipLine =
            (toSkipBlankDate && d == "")
              || (toSkipBlankDescription && e == "")
              || elem "" (mapMaybe (`M.lookup` os) toSkipBlankOther)
      if skipLine
        then return Nothing
        else do
          d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
          -- Next try to parse the amount field, which can also trigger a line
          -- skip (or cause a parse fail)
          ((\a -> TxRecord d' a e os p) <$>) <$> parseTxAmount
    where
      parseTxAmount = case toAmount of
        -- The amount column is extra confusing because it can either be one
        -- or two columns, so keep track of this with a maybe. Return Nothing
        -- to indicate we want to skip the line.
        --
        -- In the case of one column, parse the amount with the indicated regex,
        -- and force the sign if we are given a column that specifies the sign.
        -- If the amount is blank, skip the line if we allow blanks.
        AmountSingle TxAmount1 {a1Column, a1Fmt, a1Sign} -> do
          v <- getField a1Column
          signf <- case a1Sign of
            Nothing -> return id
            Just (TxSign signCol positive) -> do
              s <- getField signCol
              let k = if s == positive then 1 else -1
              return ((* k) . abs)
          fmap signf <$> parseOrSkipDecimal True a1Fmt v
        -- In the case of dual columns, each column represents either debit or
        -- credit. Only one is expected to be populated at once, so throw parse
        -- error if both or neither are blank. In the case where only one is
        -- present, parse the value and force the sign depending on which column
        -- it was. Note that in this case, we can't skip the line if the amount
        -- is blank, because by extension this implies that both columns are
        -- blank which we don't allow.
        AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
          f1 <- getField a2Positive
          f2 <- getField a2Negative
          (sign, v) <- case (f1, f2) of
            ("", "") -> fail "Positive and Negative fields undefined"
            (v, "") -> return (1, v)
            ("", v) -> return (-1, v)
            (_, _) -> fail "Positive and Negative fields defined"
          Just . (sign *) . abs <$> parseDecimal False a2Fmt v

      parseOrSkipDecimal wantSign fmt s = do
        case (s, toSkipBlankAmount) of
          ("", True) -> return Nothing
          (s', _) -> Just <$> parseDecimal wantSign fmt s'

      getField :: FromField a => T.Text -> Parser a
      getField f = r .: T.encodeUtf8 f

matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords ms rs = do
  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
  case (matched, unmatched, notfound) of
    (ms_, [], []) -> return ms_
    (_, us, ns) -> throwError $ AppException [StatementError us ns]

matchPriorities :: [StatementParserRe] -> [MatchGroup]
matchPriorities =
  fmap matchToGroup
    . L.groupBy (\a b -> spPriority a == spPriority b)
    . L.sortOn (Down . spPriority)

matchToGroup :: [StatementParserRe] -> MatchGroup
matchToGroup ms =
  uncurry MatchGroup $
    first (L.sortOn spDate) $
      L.partition (isJust . spDate) ms

data MatchGroup = MatchGroup
  { mgDate :: ![StatementParserRe]
  , mgNoDate :: ![StatementParserRe]
  }
  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 StatementParserRe
  -> TxRecord
  -> AppExceptT m (Zipped StatementParserRe, 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 StatementParserRe
  -> TxRecord
  -> AppExceptT m (Zipped StatementParserRe, 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 :: StatementParserRe -> Maybe StatementParserRe
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]
  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
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]
  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
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
  => [StatementParserRe]
  -> [TxRecord]
  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
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
  => [StatementParserRe]
  -> [TxRecord]
  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
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
  => StatementParserRe
  -> TxRecord
  -> AppExceptT 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 (unTxDesc trDesc) . snd) spDesc
      convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r

toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
toTx
  priority
  TxGetter
    { tgFrom
    , tgTo
    , tgCurrency
    , tgOtherEntries
    , tgScale
    }
  r@TxRecord {trAmount, trDate, trDesc} = do
    combineError curRes subRes $ \(cur, f, t) ss ->
      Tx
        { txMeta = TxMeta trDate priority trDesc ()
        , txPrimary =
            Left $
              EntrySet
                { esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
                , esCurrency = cpID cur
                , esFrom = f
                , esTo = t
                }
        , txOther = Left <$> ss
        }
    where
      curRes = do
        m <- asks tsCurrencyMap
        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
  -> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
  m <- asks tsCurrencyMap
  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 -> AppExcept v')
  -> Precision
  -> TxRecord
  -> v
  -> TxHalfGetter (EntryGetter n)
  -> AppExcept (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 -> AppExcept 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 -> AppExcept v)
  -> Precision
  -> TxRecord
  -> EntryGetter n
  -> AppExcept (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 -> AppExcept EntryValue
resolveFromValue = resolveValue

resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g

resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept 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 = realFracToDecimalP prec

resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)

resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
resolveCurrency m r c = do
  i <- resolveEntryField CurField r (unCurID <$> c)
  case M.lookup (CurID i) m of
    Just k -> return k
    Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]

resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept 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 -> AppExcept v
    lookup_ = lookupErr (EntryIDField t)

readDouble :: T.Text -> AppExcept Double
readDouble s = case readMaybe $ T.unpack s of
  Just x -> return x
  Nothing -> throwError $ AppException [ConversionError s True]

readRational :: T.Text -> AppExcept 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 $ AppException [ConversionError s False]

compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions = mapM (compileRegex True)

-- compileOptions o@TxOpts {toAmount = pat} = case pat of
--   AmountSingle (TxAmount1 {a1Fmt}) -> do
--     re <- compileRegex True a1Fmt
--     return $ o {toAmountFmt = re}
--   AmountDual (TxAmount2 {a2Fmt}) -> do
--     re <- compileRegex True a2Fmt
--     return $ o {toAmountFmt = re}

compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
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

parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
  (True, [sign, num]) -> do
    k <- readSign sign
    x <- readNum num
    return $ k * x
  (False, [num]) -> readNum num
  _ -> msg $ T.append "malformed decimal: " s
  where
    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
    readNum x =
      maybe
        (msg $ T.unwords ["could not parse", singleQuote x])
        return
        $ readMaybe
        $ T.unpack
        $ T.filter (/= ',') x