module Internal.Database ( runDB , nukeTables , updateHashes , updateDBState , getDBState , tree2Records , flattenAcntRoot , paths2IDs , mkPool , whenHash0 , whenHash , whenHash_ , eitherHash , insertEntry , readUpdates , insertAll , updateTx ) where import Conduit import Control.Monad.Except import Control.Monad.Logger import Data.Hashable import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.)) import qualified Database.Esqueleto.Experimental as E import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Persist.Monad import Database.Persist.Sqlite hiding ( delete , deleteWhere , insert , insertKey , insert_ , runMigration , update , (==.) , (||.) ) import GHC.Err import Internal.Types.Main import Internal.Utils import RIO hiding (LogFunc, isNothing, on, (^.)) import RIO.List ((\\)) import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NE import qualified RIO.Text as T runDB :: MonadUnliftIO m => SqlConfig -> SqlQueryT (NoLoggingT m) a -> m a runDB c more = runNoLoggingT $ do pool <- mkPool c runSqlQueryT pool $ do _ <- lift askLoggerIO runMigration migrateAll more mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool mkPool c = case c of Sqlite p -> createSqlitePool p 10 -- conn <- open p -- wrapConnection conn logfn Postgres -> error "postgres not implemented" nukeTables :: MonadSqlQuery m => m () nukeTables = do deleteWhere ([] :: [Filter CommitR]) deleteWhere ([] :: [Filter CurrencyR]) deleteWhere ([] :: [Filter AccountR]) deleteWhere ([] :: [Filter TransactionR]) -- showBalances :: MonadUnliftIO m => SqlPersistT m () -- showBalances = do -- xs <- select $ do -- (accounts :& splits :& txs) <- -- from -- $ table @AccountR -- `innerJoin` table @SplitR -- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) -- `innerJoin` table @TransactionR -- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) -- where_ $ -- isNothing (txs ^. TransactionRBucket) -- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%)) -- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)) -- ) -- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) -- return -- ( accounts ^. AccountRFullpath -- , accounts ^. AccountRName -- , sum_ $ splits ^. SplitRValue -- ) -- -- TODO super stetchy table printing thingy -- liftIO $ do -- putStrLn $ T.unpack $ fmt "Account" "Balance" -- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-") -- mapM_ (putStrLn . T.unpack . fmtBalance) xs -- where -- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal) -- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"] -- pad n xs = T.append xs $ T.replicate (n - T.length xs) " " -- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] -- toBal = maybe "???" (fmtRational 2) . unValue hashConfig :: Config -> [Int] hashConfig Config_ { budget = bs , statements = ss } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) where (ms, ps) = partitionEithers $ fmap go ss go (HistTransfer x) = Left x go (HistStatement x) = Right x setDiff :: Eq a => [a] -> [a] -> ([a], [a]) -- setDiff = setDiff' (==) setDiff as bs = (as \\ bs, bs \\ as) -- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) -- setDiff' f = go [] -- where -- go inA [] bs = (inA, bs) -- go inA as [] = (as ++ inA, []) -- go inA (a:as) bs = case inB a bs of -- Just bs' -> go inA as bs' -- Nothing -> go (a:inA) as bs -- inB _ [] = Nothing -- inB a (b:bs) -- | f a b = Just bs -- | otherwise = inB a bs getDBHashes :: MonadSqlQuery m => m [Int] getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl nukeDBHash :: MonadSqlQuery m => Int -> m () nukeDBHash h = deleteE $ do c <- E.from E.table E.where_ (c ^. CommitRHash ==. E.val h) nukeDBHashes :: MonadSqlQuery m => [Int] -> m () nukeDBHashes = mapM_ nukeDBHash getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int]) getConfigHashes c = do let ch = hashConfig c dh <- getDBHashes return $ setDiff dh ch dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] dumpTbl = selectE $ E.from E.table deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () deleteAccount e = deleteE $ do c <- E.from $ E.table @AccountR E.where_ (c ^. AccountRId ==. E.val k) where k = entityKey e deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () deleteCurrency e = deleteE $ do c <- E.from $ E.table @CurrencyR E.where_ (c ^. CurrencyRId ==. E.val k) where k = entityKey e deleteTag :: MonadSqlQuery m => Entity TagR -> m () deleteTag e = deleteE $ do c <- E.from $ E.table @TagR E.where_ (c ^. TagRId ==. E.val k) where k = entityKey e -- TODO slip-n-slide code... insertFull :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) => Entity r -> m () insertFull (Entity k v) = insertKey k v currency2Record :: Currency -> Entity CurrencyR currency2Record c@Currency {curSymbol, curFullname, curPrecision} = Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap = M.fromList . fmap ( \e -> ( currencyRSymbol $ entityVal e , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e ) ) toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b toKey = toSqlKey . fromIntegral . hash tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h) $ AccountR name (toPath parents) des where p = AcntPath t (reverse (name : parents)) h = hash p toPath = T.intercalate "/" . (atName t :) . reverse tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))]) tree2Records t = go [] where go ps (Placeholder d n cs) = let e = tree2Entity t (fmap snd ps) n d k = entityKey e (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs a0 = acnt k n (fmap snd ps) d paths = expand k $ fmap fst ps in (a0 : concat as, paths ++ concat aps, concat ms) go ps (Account d n) = let e = tree2Entity t (fmap snd ps) n d k = entityKey e in ( [acnt k n (fmap snd ps) d] , expand k $ fmap fst ps , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))] ) toPath = T.intercalate "/" . (atName t :) . reverse acnt k n ps = Entity k . AccountR n (toPath ps) expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] sign = accountSign t paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] paths2IDs = uncurry zip . first trimNames . L.unzip . L.sortOn fst . fmap (first pathList) where pathList (AcntPath t []) = atName t :| [] pathList (AcntPath t ns) = NE.reverse $ atName t :| ns -- none of these errors should fire assuming that input is sorted and unique trimNames :: [NE.NonEmpty T.Text] -> [AcntID] trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0 where trimAll _ [] = [] trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of (a, [], bs) -> reverse $ trim i a : bs (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as) matchPre i (y, ys, old) new = case (y !? i, new !? i) of (Nothing, Just _) -> case ys of [] -> (new, [], trim i y : old) _ -> err "unsorted input" (Just _, Nothing) -> err "unsorted input" (Nothing, Nothing) -> err "duplicated inputs" (Just a, Just b) | a == b -> (new, y : ys, old) | otherwise -> let next = case ys of [] -> [trim i y] _ -> trimAll (i + 1) (reverse $ y : ys) in (new, [], reverse next ++ old) trim i = NE.take (i + 1) err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg (!?) :: NE.NonEmpty a -> Int -> Maybe a xs !? n | n < 0 = Nothing -- Definition adapted from GHC.List | otherwise = foldr ( \x r k -> case k of 0 -> Just x _ -> r (k - 1) ) (const Nothing) xs n flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} = ((IncomeT,) <$> arIncome) ++ ((ExpenseT,) <$> arExpenses) ++ ((LiabilityT,) <$> arLiabilities) ++ ((AssetT,) <$> arAssets) ++ ((EquityT,) <$> arEquity) indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) indexAcntRoot r = ( concat ars , concat aprs , M.fromList $ paths2IDs $ concat ms ) where (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r getDBState :: (MonadInsertError m, MonadSqlQuery m) => Config -> m (DBState, DBUpdates) getDBState c = do (del, new) <- getConfigHashes c combineError bi si $ \b s -> ( DBState { kmCurrency = currencyMap cs , kmAccount = am , kmBudgetInterval = b , kmStatementInterval = s , kmTag = tagMap ts , kmNewCommits = new } , DBUpdates { duOldCommits = del , duNewTagIds = ts , duNewAcntPaths = paths , duNewAcntIds = acnts , duNewCurrencyIds = cs } ) where bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c si = liftExcept $ resolveDaySpan $ statementInterval $ global c (acnts, paths, am) = indexAcntRoot $ accounts c cs = currency2Record <$> currencies c ts = toRecord <$> tags c toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) updateHashes :: (MonadSqlQuery m) => DBUpdates -> m () updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () updateTags DBUpdates {duNewTagIds} = do tags' <- selectE $ E.from $ E.table @TagR let (toIns, toDel) = setDiff duNewTagIds tags' mapM_ deleteTag toDel mapM_ insertFull toIns updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do acnts' <- dumpTbl let (toIns, toDel) = setDiff duNewAcntIds acnts' deleteWhere ([] :: [Filter AccountPathR]) mapM_ deleteAccount toDel mapM_ insertFull toIns mapM_ insert duNewAcntPaths updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () updateCurrencies DBUpdates {duNewCurrencyIds} = do curs' <- selectE $ E.from $ E.table @CurrencyR let (toIns, toDel) = setDiff duNewCurrencyIds curs' mapM_ deleteCurrency toDel mapM_ insertFull toIns updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () updateDBState u = do updateHashes u updateTags u updateAccounts u updateCurrencies u deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] selectE q = unsafeLiftSql "esqueleto-select" (E.select q) whenHash :: (Hashable a, MonadFinance m, MonadSqlQuery m) => ConfigType -> a -> b -> (CommitRId -> m b) -> m b whenHash t o def f = do let h = hash o hs <- askDBState kmNewCommits if h `elem` hs then f =<< insert (CommitR h t) else return def whenHash0 :: (Hashable a, MonadFinance m) => ConfigType -> a -> b -> (CommitR -> m b) -> m b whenHash0 t o def f = do let h = hash o hs <- askDBState kmNewCommits if h `elem` hs then f (CommitR h t) else return def eitherHash :: (Hashable a, MonadFinance m) => ConfigType -> a -> (CommitR -> m b) -> (CommitR -> m c) -> m (Either b c) eitherHash t o f g = do let h = hash o let c = CommitR h t hs <- askDBState kmNewCommits if h `elem` hs then Right <$> g c else Left <$> f c whenHash_ :: (Hashable a, MonadFinance m) => ConfigType -> a -> m b -> m (Maybe (CommitR, b)) whenHash_ t o f = do let h = hash o let c = CommitR h t hs <- askDBState kmNewCommits if h `elem` hs then Just . (c,) <$> f else return Nothing readUpdates :: (MonadInsertError m, MonadSqlQuery m) => [Int] -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet]) readUpdates hashes = do xs <- selectE $ do (commits :& txs :& entrysets :& entries :& currencies) <- E.from $ E.table @CommitR `E.innerJoin` E.table @TransactionR `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit) `E.innerJoin` E.table @EntrySetR `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction) `E.innerJoin` E.table @EntryR `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset) `E.innerJoin` E.table @CurrencyR `E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId) E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes return ( entrysets ^. EntrySetRRebalance , ( ( entrysets ^. EntrySetRId , txs ^. TransactionRDate , txs ^. TransactionRBudgetName , txs ^. TransactionRPriority , ( entrysets ^. EntrySetRCurrency , currencies ^. CurrencyRPrecision ) ) , entries ) ) let (toUpdate, toRead) = L.partition (E.unValue . fst) xs toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate) return (makeRE . snd <$> toRead, toUpdate') where makeUES ((_, day, name, pri, (curID, prec)), es) = do let res = bimap NE.nonEmpty NE.nonEmpty $ NE.partition ((< 0) . entryRIndex . snd) $ NE.sortWith (entryRIndex . snd) $ fmap (\e -> (entityKey e, entityVal e)) es case res of (Just froms, Just tos) -> do let tot = sum $ fmap (entryRValue . snd) froms (from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos -- TODO WAP (wet ass programming) return $ case from0' of Left x -> Left $ UpdateEntrySet { utDate = E.unValue day , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec) , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO , utToRO = toRO , utFromUnk = fromUnk , utToUnk = toUnk , utTotalValue = tot , utBudget = E.unValue name , utPriority = E.unValue pri } Right x -> Right $ UpdateEntrySet { utDate = E.unValue day , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec) , utFrom0 = x , utTo0 = to0 , utFromRO = fromRO , utToRO = toRO , utFromUnk = fromUnk , utToUnk = toUnk , utTotalValue = () , utBudget = E.unValue name , utPriority = E.unValue pri } _ -> throwError undefined makeRE ((_, day, name, pri, (curID, _)), entry) = let e = entityVal entry in ReadEntry { reDate = E.unValue day , reCurrency = E.unValue curID , reAcnt = entryRAccount e , reValue = entryRValue e , reBudget = E.unValue name , rePriority = E.unValue pri } splitFrom :: NonEmpty (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk]) splitFrom (f0 :| fs) = do -- ASSUME entries are sorted by index -- TODO combine errors here let f0Res = readDeferredValue f0 let fsRes = mapErrors splitDeferredValue fs combineErrorM f0Res fsRes $ \f0' fs' -> do let (ro, unk) = partitionEithers fs' -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs' return (f0', ro, unk) splitTo :: Either UEBlank (Either UE_RO UEUnk) -> [UEUnk] -> NonEmpty (EntryRId, EntryR) -> InsertExcept ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink])) , [(UEUnk, [UELink])] , UEBlank , [UE_RO] , [UEUnk] ) splitTo from0 fromUnk (t0 :| ts) = do -- How to split the credit side of the database transaction in 1024 easy -- steps: -- -- 1. Split incoming entries (except primary) into those with links and not let (unlinked, linked) = partitionEithers $ fmap splitLinked ts -- 2. For unlinked entries, split into read-only and unknown entries let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked -- 3. For linked entries, split into those that link to the primary debit -- entry and not let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked -- 4. For linked entries that don't link to the primary debit entry, split -- into those that link to an unknown debit entry or not. Those that -- are not will be read-only and those that are will be collected with -- their linked debit entry let linkedRes = zipPaired fromUnk linkedN -- 5. For entries linked to the primary debit entry, turn them into linked -- entries (lazily only used when needed later) let from0Res = mapErrors (makeLinkUnk . snd) linked0 combineErrorM3 from0Res linkedRes unlinkedRes $ -- 6. Depending on the type of primary debit entry we have, add linked -- entries if it is either an unknown or a blank (to be solved) entry, -- or turn the remaining linked entries to read-only and add to the other -- read-only entries \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do let (from0', toROLinked0) = case from0 of Left blnk -> (Left (blnk, from0Links), []) Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0) Right (Right unk) -> (Right $ Right (unk, from0Links), []) return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk) where primary = uncurry makeUnkUE t0 splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e -- | Match linked credit entries with unknown entries, returning a list of -- matches and non-matching (read-only) credit entries. ASSUME both lists are -- sorted according to index and 'fst' respectively. NOTE the output will NOT be -- sorted. zipPaired :: [UEUnk] -> [(Int, NonEmpty (EntryRId, EntryR))] -> InsertExcept ([(UEUnk, [UELink])], [UE_RO]) zipPaired = go ([], []) where nolinks = ((,[]) <$>) go acc fs [] = return $ first (nolinks fs ++) acc go (facc, tacc) fs ((ti, tls) : ts) = do let (lesser, rest) = L.span ((< ti) . ueIndex) fs links <- NE.toList <$> mapErrors makeLinkUnk tls let (nextLink, fs') = case rest of (r0 : rs) | ueIndex r0 == ti -> (Just (r0, links), rs) | otherwise -> (Nothing, rest) _ -> (Nothing, rest) let acc' = (nolinks lesser ++ facc, tacc) let ros = NE.toList $ makeRoUE . snd <$> tls let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink go (f acc') fs' ts -- go (facc, tacc) (f : fs) ((ti, tls) : ts) -- | ueIndex f == ti = do -- tls' <- mapErrors makeLinkUnk tls -- go ((f, NE.toList tls') : facc, tacc) fs ts -- | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts -- go (facc, tacc) fs ts = -- return -- ( reverse facc ++ ((,[]) <$> fs) -- , tacc ++ concatMap (toRO . snd) ts -- ) makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink makeLinkUnk (k, e) = maybe (throwError $ InsertException undefined) (return . makeUE k e . LinkScale) $ entryRCachedValue e splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk) splitDeferredValue p = do res <- readDeferredValue p case res of Left _ -> throwError $ InsertException undefined Right x -> return x readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk)) readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e (Just v, Just TBalance) -> go EVBalance v (Just v, Just TPercent) -> go EVPercent v (Nothing, Nothing) -> return $ Left $ makeUnkUE k e _ -> throwError $ InsertException undefined where go c = return . Right . Right . fmap c . makeUE k e makeUE :: i -> EntryR -> v -> UpdateEntry i v makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e) makeRoUE :: EntryR -> UpdateEntry () StaticValue makeRoUE e = makeUE () e $ StaticValue (entryRValue e) makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId () makeUnkUE k e = makeUE k e () insertAll :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => [EntryBin] -> m () insertAll ebs = do (toUpdate, toInsert) <- balanceTxs ebs mapM_ updateTx toUpdate forM_ (groupWith itxCommit toInsert) $ \(c, ts) -> do ck <- insert c mapM_ (insertTx ck) ts -- where -- getCommit (HistoryCommit c) = c -- getCommit (BudgetCommit c _) = c insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets) where insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do let fs = NE.toList iesFromEntries let ts = NE.toList iesToEntries let rebalance = any (isJust . ieDeferred) (fs ++ ts) esk <- insert $ EntrySetR tk iesCurrency i rebalance mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs go k i e = void $ insertEntry k i e -- case itxCommit of -- BudgetCommit _ name -> insert_ $ BudgetLabelR ek name -- _ -> return () insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId insertEntry k i InsertEntry { ieEntry = Entry {eValue, eTags, eAcnt, eComment} , ieDeferred } = do ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink mapM_ (insert_ . TagRelationR ek) eTags return ek where (cval, ctype, deflink) = case ieDeferred of (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index) (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing) (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing) Nothing -> (Nothing, Just TFixed, Nothing) updateTx :: MonadSqlQuery m => UEBalanced -> m () updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]