pwncash/lib/Internal/History.hs

module Internal.History
  ( readHistStmt
  , readHistTransfer
  , splitHistory
  )
where

import Control.Monad.Except
import Data.Csv
import Data.Foldable
import GHC.Real
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.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 (Either CommitR [Tx TxCommit])
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
  bounds <- askDBState kmStatementInterval
  expandTransfer (HistoryCommit c) bounds ht

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

readHistStmt
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
  -> m (Either CommitR [Tx TxCommit])
readHistStmt root i = eitherHash CTImport i return $ \c -> do
  bs <- readImport root i
  bounds <- askDBState kmStatementInterval
  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs

-- 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 . 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

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}
  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 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 tg r

toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
toTx
  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 = roundPrecisionCur cur $ tgScale * fromRational trAmount
                , esCurrency = cur
                , esFrom = f
                , esTo = t
                }
        , txOther = fmap Left ss
        }
    where
      curRes = do
        m <- askDBState kmCurrency
        cur <- liftInner $ resolveCurrency m r tgCurrency
        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
        let toRes = liftInner $ resolveHalfEntry resolveToValue cur 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 kmCurrency
  cur <- liftInner $ resolveCurrency m r tsgCurrency
  let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
  liftInner $ combineErrorM toRes valRes $ \t v -> do
    f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
    return $
      EntrySet
        { esTotalValue = ()
        , esCurrency = cur
        , esFrom = f
        , esTo = t
        }

resolveHalfEntry
  :: Traversable f
  => (TxRecord -> n -> InsertExcept (f Double))
  -> CurrencyPrec
  -> TxRecord
  -> v
  -> TxHalfGetter (EntryGetter n)
  -> InsertExcept (HalfEntrySet v (f Rational))
resolveHalfEntry f cur 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 cur 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
  :: Traversable f
  => (TxRecord -> n -> InsertExcept (f Double))
  -> CurrencyPrec
  -> TxRecord
  -> EntryGetter n
  -> InsertExcept (Entry AcntID (f Rational) TagID)
resolveEntry f cur r s@Entry {eAcnt, eValue} = do
  combineError acntRes valRes $ \a v ->
    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
  where
    acntRes = resolveAcnt r eAcnt
    valRes = f r eValue

resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveFromValue = resolveValue

resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
resolveToValue _ (Linked l) = return $ LinkIndex l
resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g

resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveValue TxRecord {trOther, trAmount} s = case s of
  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
  (ConstN c) -> return $ EntryValue TFixed c
  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
  BalanceN x -> return $ EntryValue TBalance x
  PercentN x -> return $ EntryValue TPercent x

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)