Compare commits
6 Commits
5e967ae9cb
...
c791c5a692
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | c791c5a692 | |
Nathan Dwarshuis | 354310bf08 | |
Nathan Dwarshuis | dc484c6557 | |
Nathan Dwarshuis | 38c766e025 | |
Nathan Dwarshuis | 00a08d0fbe | |
Nathan Dwarshuis | 69ead7b40d |
|
@ -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
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Internal.Config
|
module Internal.Config
|
||||||
( readConfig
|
( readConfig
|
||||||
-- , readYaml
|
-- , readYaml
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue