pwncash/lib/Internal/Insert.hs

module Internal.Insert
  ( insertStatements
  , insertBudget
  )
where

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

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

expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = Right $ expandModPat mp i

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

expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
  concatEither3 yRes mRes dRes $ \ys ms ds ->
    filter validWeekday $
      mapMaybe (uncurry3 toDay) $
        takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
          dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
            [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
  where
    yRes = case cronYear of
      Nothing -> return [yb0 .. yb1]
      Just pat -> do
        ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
        return $ dropWhile (< yb0) $ fromIntegral <$> ys
    mRes = expandMD 12 cronMonth
    dRes = expandMD 31 cronDay
    (s, e) = expandBounds b
    (yb0, mb0, db0) = toGregorian s
    (yb1, mb1, db1) = toGregorian $ addDays (-1) e
    expandMD lim =
      fmap (fromIntegral <$>)
        . maybe (return [1 .. lim]) (expandMDYPat 1 lim)
    expandW (OnDay x) = [fromEnum x]
    expandW (OnDays xs) = fromEnum <$> xs
    ws = maybe [] expandW cronWeekly
    validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
    toDay (y, leap) m d
      | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
      | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
      | otherwise = Just $ fromGregorian y m d

expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural]
expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = Right [max lower x .. upper]
expandMDYPat lower upper (Before x) = Right [lower .. min upper x]
expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
  | b < 1 = Left $ PatternError s b r ZeroLength
  | otherwise = do
      k <- limit r
      return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
  where
    limit Nothing = Right upper
    limit (Just n)
      -- this guard not only produces the error for the user but also protects
      -- from an underflow below it
      | n < 1 = Left $ PatternError s b r ZeroRepeats
      | otherwise = Right $ min (s + b * (n - 1)) upper

dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7

withDates
  :: MonadFinance m
  => DatePat
  -> (Day -> SqlPersistT m (EitherErrs a))
  -> SqlPersistT m (EitherErrs [a])
withDates dp f = do
  bounds <- lift $ askDBState kmBudgetInterval
  case expandDatePat bounds dp of
    Left es -> return $ Left es
    Right days -> concatEithersL <$> mapM f days

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

-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
--    each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
--    transaction (some of which depend on the 'current' balance of the
--    target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions

insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget
  b@Budget
    { budgetLabel
    , incomes
    , transfers
    , shadowTransfers
    , pretax
    , tax
    , posttax
    } =
    whenHash CTBudget b [] $ \key -> do
      unlessLefts intAllos $ \intAllos_ -> do
        res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
        res2 <- expandTransfers key budgetLabel transfers
        unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
          \txs -> do
            unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
              let bals = balanceTransfers $ txs ++ shadow
              concat <$> mapM insertBudgetTx bals
    where
      intAllos =
        let pre_ = sortAllos pretax
            tax_ = sortAllos tax
            post_ = sortAllos posttax
         in concatEithers3 pre_ tax_ post_ (,,)
      sortAllos = concatEithersL . fmap sortAllo

type BoundAllocation = Allocation (Day, Day)

type IntAllocations =
  ( [BoundAllocation PretaxValue]
  , [BoundAllocation TaxValue]
  , [BoundAllocation PosttaxValue]
  )

-- TODO this should actually error if there is no ultimate end date?
sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
  bs <- foldBounds (Right []) $ L.sortOn amtWhen as
  return $ a {alloAmts = reverse bs}
  where
    foldBounds acc [] = acc
    foldBounds acc (x : xs) =
      let res = case xs of
            [] -> resolveBounds $ amtWhen x
            (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
          concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
       in foldBounds (concatEithers2 (plural res) acc concatRes) xs

-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
  :: [ShadowTransfer]
  -> [UnbalancedTransfer]
  -> EitherErrs [UnbalancedTransfer]
addShadowTransfers ms txs =
  fmap catMaybes $
    concatEitherL $
      fmap (uncurry fromShadow) $
        [(t, m) | t <- txs, m <- ms]

fromShadow
  :: UnbalancedTransfer
  -> ShadowTransfer
  -> EitherErr (Maybe UnbalancedTransfer)
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
  res <- shadowMatches (stMatch t) tx
  return $
    if not res
      then Nothing
      else
        Just $
          -- TODO does this actually share the same metadata as the "parent" tx?
          FlatTransfer
            { cbtMeta = cbtMeta tx
            , cbtWhen = cbtWhen tx
            , cbtCur = stCurrency
            , cbtFrom = stFrom
            , cbtTo = stTo
            , cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
            , cbtDesc = stDesc
            }

shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
  valRes <- valMatches smVal $ cvValue $ cbtValue tx
  return $
    memberMaybe (taAcnt $ cbtFrom tx) smFrom
      && memberMaybe (taAcnt $ cbtTo tx) smTo
      && maybe True (`dateMatches` cbtWhen tx) smDate
      && valRes
  where
    memberMaybe x AcntSet {asList, asInclude} =
      (if asInclude then id else not) $ x `elem` asList

balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers ts =
  snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
  where
    go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
      let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
          x = amtToMove v cvType cvValue
       in (bals', f {cbtValue = x})
    -- TODO might need to query signs to make this intuitive; as it is this will
    -- probably work, but for credit accounts I might need to supply a negative
    -- target value
    amtToMove _ BTFixed x = x
    amtToMove bal BTPercent x = -(x / 100 * bal)
    amtToMove bal BTTarget x = x - bal

mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v m = fst $ mapAdd k v m

mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
  where
    new = M.alter (maybe (Just v) (Just . (+ v))) k m

data BudgetMeta = BudgetMeta
  { bmCommit :: !CommitRId
  , bmName :: !T.Text
  }
  deriving (Show)

data FlatTransfer v = FlatTransfer
  { cbtFrom :: !TaggedAcnt
  , cbtTo :: !TaggedAcnt
  , cbtValue :: !v
  , cbtWhen :: !Day
  , cbtDesc :: !T.Text
  , cbtMeta :: !BudgetMeta
  , cbtCur :: !BudgetCurrency
  }

data UnbalancedValue = UnbalancedValue
  { cvType :: !BudgetTransferType
  , cvValue :: !Rational
  }

type UnbalancedTransfer = FlatTransfer UnbalancedValue

type BalancedTransfer = FlatTransfer Rational

insertIncome
  :: MonadFinance m
  => CommitRId
  -> T.Text
  -> IntAllocations
  -> Income
  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
insertIncome
  key
  name
  (intPre, intTax, intPost)
  Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
    -- TODO check that the other accounts are not income somewhere here
    fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
    case fromRes of
      Left e -> return $ Left [e]
      -- TODO this will scan the interval allocations fully each time
      -- iteration which is a total waste, but the fix requires turning this
      -- loop into a fold which I don't feel like doing now :(
      Right _ -> fmap concat <$> withDates incWhen (return . allocate)
    where
      meta = BudgetMeta key name
      gross = dec2Rat incGross
      flatPre = concatMap flattenAllo incPretax
      flatTax = concatMap flattenAllo incTaxes
      flatPost = concatMap flattenAllo incPosttax
      sumAllos = sum . fmap faValue
      -- TODO ensure these are all the "correct" accounts
      allocate day =
        let (preDeductions, pre) =
              allocatePre gross $
                flatPre ++ concatMap (selectAllos day) intPre
            tax =
              allocateTax gross preDeductions $
                flatTax ++ concatMap (selectAllos day) intTax
            aftertaxGross = sumAllos $ tax ++ pre
            post =
              allocatePost aftertaxGross $
                flatPost ++ concatMap (selectAllos day) intPost
            balance = aftertaxGross - sumAllos post
            bal =
              FlatTransfer
                { cbtMeta = meta
                , cbtWhen = day
                , cbtFrom = incFrom
                , cbtCur = NoX incCurrency
                , cbtTo = incToBal
                , cbtValue = UnbalancedValue BTFixed balance
                , cbtDesc = "balance after deductions"
                }
         in if balance < 0
              then Left [IncomeError day name balance]
              else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)

allocatePre
  :: Rational
  -> [FlatAllocation PretaxValue]
  -> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre gross = L.mapAccumR go M.empty
  where
    go m f@FlatAllocation {faValue} =
      let c = preCategory faValue
          p = dec2Rat $ preValue faValue
          v = if prePercent faValue then p * gross else p
       in (mapAdd_ c v m, f {faValue = v})

allo2Trans
  :: BudgetMeta
  -> Day
  -> TaggedAcnt
  -> FlatAllocation Rational
  -> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
  FlatTransfer
    { cbtMeta = meta
    , cbtWhen = day
    , cbtFrom = from
    , cbtCur = faCur
    , cbtTo = faTo
    , cbtValue = UnbalancedValue BTFixed faValue
    , cbtDesc = faDesc
    }

allocateTax
  :: Rational
  -> M.Map T.Text Rational
  -> [FlatAllocation TaxValue]
  -> [FlatAllocation Rational]
allocateTax gross deds = fmap (fmap go)
  where
    go TaxValue {tvCategories, tvMethod} =
      let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
       in case tvMethod of
            TMPercent p -> dec2Rat p * agi
            TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
              foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets

allocatePost
  :: Rational
  -> [FlatAllocation PosttaxValue]
  -> [FlatAllocation Rational]
allocatePost aftertax = fmap (fmap go)
  where
    go PosttaxValue {postValue, postPercent} =
      let v = dec2Rat postValue in if postPercent then aftertax * v else v

foldBracket :: Rational -> [TaxBracket] -> Rational
foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
  where
    go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
      let l = dec2Rat tbLowerLimit
          p = dec2Rat tbPercent
       in if remain < l then (acc + p * (remain - l), l) else (acc, remain)

data FlatAllocation v = FlatAllocation
  { faValue :: !v
  , faDesc :: !T.Text
  , faTo :: !TaggedAcnt
  , faCur :: !BudgetCurrency
  }
  deriving (Functor)

flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
  where
    go Amount {amtValue, amtDesc} =
      FlatAllocation
        { faCur = NoX alloCur
        , faTo = alloTo
        , faValue = amtValue
        , faDesc = amtDesc
        }

-- ASSUME allocations are sorted
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
  fmap go $
    takeWhile ((`inBounds` day) . amtWhen) $
      dropWhile ((day <) . fst . amtWhen) alloAmts
  where
    go Amount {amtValue, amtDesc} =
      FlatAllocation
        { faCur = NoX alloCur
        , faTo = alloTo
        , faValue = amtValue
        , faDesc = amtDesc
        }

expandTransfers
  :: MonadFinance m
  => CommitRId
  -> T.Text
  -> [BudgetTransfer]
  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
expandTransfers key name ts = do
  txs <- mapM (expandTransfer key name) ts
  return $ L.sortOn cbtWhen . concat <$> concatEithersL txs

expandTransfer
  :: MonadFinance m
  => CommitRId
  -> T.Text
  -> BudgetTransfer
  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
  -- whenHash CTExpense t (Right []) $ \key ->
  fmap (fmap concat . concatEithersL) $
    forM transAmounts $
      \Amount
        { amtWhen = pat
        , amtValue = BudgetTransferValue {btVal = v, btType = y}
        , amtDesc = desc
        } ->
          do
            withDates pat $ \day ->
              let meta =
                    BudgetMeta
                      { bmCommit = key
                      , bmName = name
                      }
                  tx =
                    FlatTransfer
                      { cbtMeta = meta
                      , cbtWhen = day
                      , cbtCur = transCurrency
                      , cbtFrom = transFrom
                      , cbtTo = transTo
                      , cbtValue = UnbalancedValue y $ dec2Rat v
                      , cbtDesc = desc
                      }
               in return $ Right tx

insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
  res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
  unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
    insertPair sFrom sTo
    forM_ exchange $ uncurry insertPair
  where
    insertPair from to = do
      k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
      insertBudgetLabel k from
      insertBudgetLabel k to
    insertBudgetLabel k split = do
      sk <- insertSplit k split
      insert_ $ BudgetLabelR sk $ bmName cbtMeta

type SplitPair = (KeySplit, KeySplit)

splitPair
  :: MonadFinance m
  => TaggedAcnt
  -> TaggedAcnt
  -> BudgetCurrency
  -> Rational
  -> m (EitherErrs (SplitPair, Maybe SplitPair))
splitPair from to cur val = case cur of
  NoX curid -> fmap (,Nothing) <$> pair curid from to val
  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
    let middle = TaggedAcnt xAcnt []
    res1 <- pair xFromCur from middle val
    res2 <- pair xToCur middle to (val * dec2Rat xRate)
    return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
  where
    pair curid from_ to_ v = do
      s1 <- split curid from_ (-v)
      s2 <- split curid to_ v
      return $ concatEithers2 s1 s2 (,)
    split c TaggedAcnt {taAcnt, taTags} v =
      resolveSplit $
        Entry
          { sAcnt = taAcnt
          , sValue = v
          , sComment = ""
          , sCurrency = c
          , sTags = taTags
          }

checkAcntType
  :: MonadFinance m
  => AcntType
  -> AcntID
  -> m (EitherErr AcntID)
checkAcntType t = checkAcntTypes (t :| [])

checkAcntTypes
  :: MonadFinance m
  => NE.NonEmpty AcntType
  -> AcntID
  -> m (EitherErr AcntID)
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
  where
    go t
      | t `L.elem` ts = Right i
      | otherwise = Left $ AccountError i ts

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

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

insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
insertStatement (HistTransfer m) = insertManual m
insertStatement (HistStatement i) = insertImport i

insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
insertManual
  m@Transfer
    { transFrom = from
    , transTo = to
    , transCurrency = u
    , transAmounts = amts
    } = do
    whenHash CTManual m [] $ \c -> do
      bounds <- lift $ askDBState kmStatementInterval
      -- let days = expandDatePat bounds dp
      es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
        let v = dec2Rat amtValue
        let dayRes = expandDatePat bounds amtWhen
        unlessLefts dayRes $ \days -> do
          let tx day = txPair day from to u v amtDesc
          txRes <- mapM (lift . tx) days
          unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
      return $ concat es

insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do
  -- TODO this isn't efficient, the whole file will be read and maybe no
  -- transactions will be desired
  recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
    bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
    res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
    unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
  where
    recoverIO x rest = do
      res <- tryIO x
      case res of
        Right r -> rest r
        -- If file is not found (or something else happens) then collect the
        -- error try the remaining imports
        Left e -> return [InsertIOError $ showT e]

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

-- TODO tags here?
txPair
  :: MonadFinance m
  => Day
  -> AcntID
  -> AcntID
  -> CurID
  -> Rational
  -> T.Text
  -> m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx
  where
    split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
    tx =
      Tx
        { txDescr = desc
        , txDate = day
        , txSplits = [split from (-val), split to val]
        }

resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
  res <- concatEithersL <$> mapM resolveSplit ss
  return $ fmap (\kss -> t {txSplits = kss}) res

resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
  aid <- lookupAccountKey sAcnt
  cid <- lookupCurrency sCurrency
  sign <- lookupAccountSign sAcnt
  tags <- mapM lookupTag sTags
  -- TODO correct sign here?
  -- TODO lenses would be nice here
  return $
    concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
      \(aid_, cid_, sign_) tags_ ->
        s
          { sAcnt = aid_
          , sCurrency = cid_
          , sValue = sValue * fromIntegral (sign2Int sign_)
          , sTags = tags_
          }

insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
  k <- insert $ TransactionR c d e
  mapM_ (insertSplit k) ss

insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
  k <- insert $ SplitR t sCurrency sAcnt sComment sValue
  mapM_ (insert_ . TagRelationR k) sTags
  return k

lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount

lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fstOf3) . lookupAccount

lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount

lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
lookupAccountType = fmap (fmap thdOf3) . lookupAccount

lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency

lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag

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