Compare commits

...

6 Commits

6 changed files with 56 additions and 54 deletions

View File

@ -1,8 +1,8 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main (main) where module Main (main) where
import qualified Data.Text.IO as TI
import Internal.Config import Internal.Config
import Internal.Database.Ops import Internal.Database.Ops
import Internal.Insert import Internal.Insert
@ -157,12 +157,16 @@ runDumpAccountKeys c = do
runSync :: MonadUnliftIO m => FilePath -> m () runSync :: MonadUnliftIO m => FilePath -> m ()
runSync c = do runSync c = do
config <- readConfig c config <- readConfig c
migrate_ (sqlConfig config) $ do handle err $ migrate_ (sqlConfig config) $ do
s <- getDBState config s <- getDBState config
flip runReaderT (s $ takeDirectory c) $ do flip runReaderT (s $ takeDirectory c) $ do
es1 <- insertBudget $ budget config es1 <- insertBudget $ budget config
es2 <- insertStatements config es2 <- insertStatements config
let es = es1 ++ es2 let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es unless (null es) $ throwIO $ InsertException es
where
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure
-- showBalances -- showBalances

View File

@ -1,3 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Config module Internal.Config
( readConfig ( readConfig
-- , readYaml -- , readYaml

View File

@ -14,6 +14,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Model where module Internal.Database.Model where

View File

@ -4,11 +4,12 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Database.Ops module Internal.Database.Ops
( migrate_ ( migrate_
, nukeTables , nukeTables
, showBalances -- , showBalances
, updateHashes , updateHashes
, getDBState , getDBState
, tree2Records , tree2Records
@ -24,6 +25,7 @@ import Database.Esqueleto.Experimental
import Database.Persist.Sql hiding (delete, (==.), (||.)) import Database.Persist.Sql hiding (delete, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, (==.), (||.)) import Database.Persist.Sqlite hiding (delete, (==.), (||.))
import Database.Sqlite hiding (Config) import Database.Sqlite hiding (Config)
import GHC.Err
import Internal.Database.Model import Internal.Database.Model
import Internal.Types import Internal.Types
import Internal.Utils import Internal.Utils
@ -64,38 +66,38 @@ nukeTables = do
deleteWhere ([] :: [Filter AccountR]) deleteWhere ([] :: [Filter AccountR])
deleteWhere ([] :: [Filter TransactionR]) deleteWhere ([] :: [Filter TransactionR])
showBalances :: MonadUnliftIO m => SqlPersistT m () -- showBalances :: MonadUnliftIO m => SqlPersistT m ()
showBalances = do -- showBalances = do
xs <- select $ do -- xs <- select $ do
(accounts :& splits :& txs) <- -- (accounts :& splits :& txs) <-
from -- from
$ table @AccountR -- $ table @AccountR
`innerJoin` table @SplitR -- `innerJoin` table @SplitR
`on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) -- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
`innerJoin` table @TransactionR -- `innerJoin` table @TransactionR
`on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) -- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
where_ $ -- where_ $
isNothing (txs ^. TransactionRBucket) -- isNothing (txs ^. TransactionRBucket)
&&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%)) -- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)) -- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
) -- )
groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) -- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
return -- return
( accounts ^. AccountRFullpath -- ( accounts ^. AccountRFullpath
, accounts ^. AccountRName -- , accounts ^. AccountRName
, sum_ $ splits ^. SplitRValue -- , sum_ $ splits ^. SplitRValue
) -- )
-- TODO super stetchy table printing thingy -- -- TODO super stetchy table printing thingy
liftIO $ do -- liftIO $ do
putStrLn $ T.unpack $ fmt "Account" "Balance" -- putStrLn $ T.unpack $ fmt "Account" "Balance"
putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-") -- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
mapM_ (putStrLn . T.unpack . fmtBalance) xs -- mapM_ (putStrLn . T.unpack . fmtBalance) xs
where -- where
fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal) -- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"] -- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
pad n xs = T.append xs $ T.replicate (n - T.length xs) " " -- 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] -- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
toBal = maybe "???" (fmtRational 2) . unValue -- toBal = maybe "???" (fmtRational 2) . unValue
hashConfig :: Config -> [Int] hashConfig :: Config -> [Int]
hashConfig hashConfig
@ -220,7 +222,7 @@ tree2Records t = go []
go ps (Placeholder d n cs) = go ps (Placeholder d n cs) =
let e = tree2Entity t (fmap snd ps) n d let e = tree2Entity t (fmap snd ps) n d
k = entityKey e k = entityKey e
(as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
a0 = acnt k n (fmap snd ps) d a0 = acnt k n (fmap snd ps) d
paths = expand k $ fmap fst ps paths = expand k $ fmap fst ps
in (a0 : concat as, paths ++ concat aps, concat ms) in (a0 : concat as, paths ++ concat aps, concat ms)
@ -240,7 +242,7 @@ paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
paths2IDs = paths2IDs =
uncurry zip uncurry zip
. first trimNames . first trimNames
. unzip . L.unzip
. L.sortOn fst . L.sortOn fst
. fmap (first pathList) . fmap (first pathList)
where where
@ -301,7 +303,7 @@ indexAcntRoot r =
, M.fromList $ paths2IDs $ concat ms , M.fromList $ paths2IDs $ concat ms
) )
where where
(ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
getDBState getDBState
:: MonadUnliftIO m :: MonadUnliftIO m

View File

@ -54,14 +54,13 @@ cronPatternMatches
, cronDay = d , cronDay = d
} }
x = x =
yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w yMaybe y' y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
where where
testMaybe = maybe True testMaybe = maybe True
yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z)) yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z)) mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
wdMaybe z = testMaybe (`weekdayPatternMatches` z) wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y', m', d') = toGregorian x (y', m', d') = toGregorian x
testYear z = if z > 99 then Just "year must be 2 digits" else Nothing
dayOfWeek_ :: Day -> Weekday dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of dayOfWeek_ d = case dayOfWeek d of
@ -77,16 +76,12 @@ weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
weekdayPatternMatches (OnDay x) = (== x) weekdayPatternMatches (OnDay x) = (== x)
weekdayPatternMatches (OnDays xs) = (`elem` xs) weekdayPatternMatches (OnDays xs) = (`elem` xs)
mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool mdyPatternMatches :: Natural -> MDYPat -> Bool
mdyPatternMatches check x p = case p of mdyPatternMatches x p = case p of
Single y -> errMaybe (check y) $ x == y Single y -> x == y
Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs Multi xs -> x `elem` xs
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) -> 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
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 -- budget
@ -261,8 +256,6 @@ timeAmountToTx
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError] insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
insertStatements conf = concat <$> mapM insertStatement (statements conf) insertStatements conf = concat <$> mapM insertStatement (statements conf)
-- unless (null es) $ throwIO $ InsertException es
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
insertStatement (StmtManual m) = insertManual m insertStatement (StmtManual m) = insertManual m
insertStatement (StmtImport i) = insertImport i insertStatement (StmtImport i) = insertImport i

View File

@ -147,7 +147,7 @@ zipperMatch' z x = go z
matchDec :: Match -> Maybe Match matchDec :: Match -> Maybe Match
matchDec m = case mTimes m of matchDec m = case mTimes m of
Just 0 -> Nothing Just 1 -> Nothing
Just n -> Just $ m {mTimes = Just $ n - 1} Just n -> Just $ m {mTimes = Just $ n - 1}
Nothing -> Just m Nothing -> Just m