pwncash/lib/Internal/Insert.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Internal.Insert
  ( insertStatements
  , insertBudget
  )
where

import Data.Bitraversable
import Data.Hashable
import Database.Persist.Class
import Database.Persist.Sql hiding (Single, Statement)
import Internal.Database.Model
import Internal.Statement
import Internal.Types hiding (sign)
import Internal.Utils
import RIO hiding (to)
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time

lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
lookupKey m k = do
  let v = M.lookup k m
  when (isNothing v) $
    liftIO $
      putStrLn $
        "key does not exist: " ++ show k
  return v

lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
lookupAccount p = do
  m <- asks kmAccount
  lookupKey m p

lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount

lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount

lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
lookupCurrency c = do
  m <- asks kmCurrency
  lookupKey m c

--------------------------------------------------------------------------------
-- intervals

expandDatePat :: Bounds -> DatePat -> EitherErr [Day]
expandDatePat (a, b) (Cron cp) = return $ filter (cronPatternMatches cp) [a .. b]
expandDatePat i (Mod mp) = expandModPat mp i

expandModPat :: ModPat -> Bounds -> EitherErr [Day]
expandModPat
  ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
  (lower, upper) = do
    start <- maybe (return lower) fromGregorian' s
    return $
      takeWhile (<= upper) $
        (`addFun` start) . (* b')
          <$> maybe id (take . fromIntegral) r [0 ..]
    where
      -- start = maybe lower fromGregorian' s
      b' = fromIntegral b
      addFun = case u of
        Day -> addDays
        Week -> addDays . (* 7)
        Month -> addGregorianMonthsClip
        Year -> addGregorianYearsClip

-- TODO this can be optimized to prevent filtering a bunch of dates for
-- one/a few cron patterns
cronPatternMatches :: CronPat -> Day -> Bool
cronPatternMatches
  CronPat
    { cronWeekly = w
    , cronYear = y
    , cronMonth = m
    , cronDay = d
    }
  x =
    yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
    where
      testMaybe = maybe True
      yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z))
      mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z))
      wdMaybe z = testMaybe (`weekdayPatternMatches` z)
      (y', m', d') = toGregorian x
      testYear z = if z > 99 then Just "year must be 2 digits" else Nothing

dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of
  Monday -> Mon
  Tuesday -> Tue
  Wednesday -> Wed
  Thursday -> Thu
  Friday -> Fri
  Saturday -> Sat
  Sunday -> Sun

weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
weekdayPatternMatches (OnDay x) = (== x)
weekdayPatternMatches (OnDays xs) = (`elem` xs)

mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool
mdyPatternMatches check x p = case p of
  Single y -> errMaybe (check y) $ x == y
  Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
  Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
    errMaybe (check s) $
      s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
  where
    errMaybe test rest = maybe rest err test
    err msg = error $ show p ++ ": " ++ msg

--------------------------------------------------------------------------------
-- budget

insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget Budget {income = is, expenses = es} = do
  es1 <- mapM insertIncome is
  es2 <- mapM insertExpense es
  return $ concat $ es1 ++ es2

-- TODO this hashes twice (not that it really matters)
whenHash
  :: (Hashable a, MonadUnliftIO m)
  => ConfigType
  -> a
  -> b
  -> (Key CommitR -> MappingT m b)
  -> MappingT m b
whenHash t o def f = do
  let h = hash o
  hs <- asks kmNewCommits
  if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def

insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
insertIncome
  i@Income
    { incCurrency = cur
    , incWhen = dp
    , incAccount = from
    , incTaxes = ts
    } =
    whenHash CTIncome i [] $ \c -> do
      bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
      case (balanceIncome i, expandDatePat bounds dp) of
        (Right balanced, Right days) -> do
          forM_ days $ \day -> do
            alloTx <- concat <$> mapM (allocationToTx from day) balanced
            taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
            lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
          return []
        (a, b) -> return $ catMaybes [leftToMaybe a, leftToMaybe b]

balanceIncome :: Income -> EitherErr [BalAllocation]
balanceIncome
  Income
    { incGross = g
    , incPretax = pre
    , incTaxes = tax
    , incPosttax = post
    } = (preRat ++) <$> balancePostTax bal postRat
    where
      preRat = mapAlloAmts dec2Rat <$> pre
      postRat = mapAlloAmts (fmap dec2Rat) <$> post
      bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)

mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b
mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as}

sumAllocations :: [BalAllocation] -> Rational
sumAllocations = sum . concatMap (fmap amtValue . alloAmts)

sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)

balancePostTax :: DatePat -> Rational -> [RawAllocation] -> EitherErr [BalAllocation]
balancePostTax dp bal as
  | null as = err NoAllocations
  | otherwise = case partitionEithers $ fmap hasVal as of
      ([([empty], nonmissing)], bs) ->
        let s = bal - sumAllocations (nonmissing : bs)
         in if s < 0
              then err ExceededTotal
              else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
      ([], _) -> err MissingBlank
      _ -> err TooManyBlanks
  where
    hasVal a@Allocation {alloAmts = xs} =
      case partitionEithers $ fmap maybeAmt xs of
        ([], bs) -> Right a {alloAmts = bs}
        (unbal, bs) -> Left (unbal, a {alloAmts = bs})
    maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
    maybeAmt a = Left a
    err t = Left $ AllocationError t dp

-- TODO lens reinvention
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}

allocationToTx
  :: MonadUnliftIO m
  => AcntID
  -> Day
  -> BalAllocation
  -> MappingT m [(KeyTx, Bucket)]
allocationToTx
  from
  day
  Allocation
    { alloPath = to
    , alloBucket = b
    , alloCurrency = cur
    , alloAmts = as
    } =
    fmap (,b) <$> mapM (transferToTx day from to cur) as

taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
  txPair day from to cur (dec2Rat v) ""

transferToTx
  :: MonadUnliftIO m
  => Day
  -> AcntID
  -> AcntID
  -> T.Text
  -> BalAmount
  -> MappingT m KeyTx
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
  txPair day from to cur v d

insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
insertExpense
  e@Expense
    { expFrom = from
    , expTo = to
    , expCurrency = cur
    , expBucket = buc
    , expAmounts = as
    } = do
    whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
    where
      go key amt = do
        res <- timeAmountToTx from to cur amt
        unlessLeft res $
          lift . mapM_ (insertTxBucket (Just buc) key)

timeAmountToTx
  :: MonadUnliftIO m
  => AcntID
  -> AcntID
  -> CurID
  -> TimeAmount
  -> MappingT m (EitherErr [KeyTx])
timeAmountToTx
  from
  to
  cur
  TimeAmount
    { taWhen = dp
    , taAmt =
      Amount
        { amtValue = v
        , amtDesc = d
        }
    } = do
    bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
    bimapM return (mapM tx) $ expandDatePat bounds dp
    where
      tx day = txPair day from to cur (dec2Rat v) d

--------------------------------------------------------------------------------
-- statements

insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
insertStatements conf = concat <$> mapM insertStatement (statements conf)

-- unless (null es) $ throwIO $ InsertException es

insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i

insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
insertManual
  m@Manual
    { manualDate = dp
    , manualFrom = from
    , manualTo = to
    , manualValue = v
    , manualCurrency = u
    , manualDesc = e
    } = do
    whenHash CTManual m [] $ \c -> do
      bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
      unlessLeft (expandDatePat bounds dp) $ \days -> do
        ts <- mapM tx days
        lift $ mapM_ (insertTx c) ts
    where
      tx day = txPair day from to u (dec2Rat v) e

insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do
  bounds <- asks kmStatementInterval
  res <- readImport i
  -- TODO this isn't efficient, the whole file will be read and maybe no
  -- transactions will be desired
  unlessLefts res $ \bs -> do
    rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
    lift $ mapM_ (insertTx c) rs

--------------------------------------------------------------------------------
-- low-level transaction stuff

txPair
  :: MonadUnliftIO m
  => Day
  -> AcntID
  -> AcntID
  -> T.Text
  -> Rational
  -> T.Text
  -> MappingT m KeyTx
txPair day from to cur val desc = resolveTx tx
  where
    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
    tx =
      Tx
        { txDescr = desc
        , txDate = day
        , txTags = []
        , txSplits = [split from (-val), split to val]
        }

resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
resolveTx t@Tx {txSplits = ss} = do
  rs <- catMaybes <$> mapM resolveSplit ss
  return $ t {txSplits = rs}

resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
  aid <- lookupAccountKey p
  cid <- lookupCurrency c
  sign <- lookupAccountSign p
  -- TODO correct sign here?
  -- TODO lenses would be nice here
  return $ case (aid, cid, sign) of
    (Just aid', Just cid', Just sign') ->
      Just $
        s
          { sAcnt = aid'
          , sCurrency = cid'
          , sValue = v * fromIntegral (sign2Int sign')
          }
    _ -> Nothing

insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
  k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
  mapM_ (insertSplit k) ss

insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx = insertTxBucket Nothing

insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
  insert_ $ SplitR t cid aid c v