Reactivate account verification and ledger balance verification

src/Main.purs

@@ -13,6 +13,7 @@ import Prelude
   , (<#>)
   , (<>)
   , (>)
+  , (>>=)
   )
 
 import Ansi.Codes (Color(..))
@@ -40,7 +41,12 @@ import Node.FS.Sync as Sync
 import Node.Path as Path
 import Node.Process (cwd, setExitCode)
 import Transity.Data.Config (ColorFlag(..), config)
-import Transity.Data.Ledger (Ledger(..), BalanceFilter(..))
+import Transity.Data.Ledger
+  ( BalanceFilter(..)
+  , Ledger(..)
+  , verifyAccounts
+  , verifyLedgerBalances
+  )
 import Transity.Data.Ledger as Ledger
 import Transity.Data.Transaction (Transaction(..))
 import Transity.Plot as Plot
@@ -191,9 +197,25 @@ buildLedgerAndRun currentDir journalPathRel extraJournalPaths callback = do
     Error message -> errorAndExit config message
     Ok paths -> do
       combineRes <- combineJournals currentDir paths
-      case combineRes of
-        Error message -> errorAndExit config message
-        Ok ledger -> callback ledger
+      case
+        combineRes
+          >>= verifyAccounts
+          >>= verifyLedgerBalances
+        of
+        Error msg -> pure $ Error msg
+        Ok ledger -> ledger # callback
+
+buildRunExit
+  :: String
+  -> String
+  -> Array CliArgPrim
+  -> (Ledger -> Effect (Result String Unit))
+  -> Effect (Result String Unit)
+buildRunExit currentDir journalPathRel extraJournalPaths callback = do
+  buildLedgerAndRun currentDir journalPathRel extraJournalPaths callback
+    >>= \res -> case res of
+      Ok val -> pure $ Ok val
+      Error msg -> errorAndExit config msg
 
 executor :: String -> String -> Array CliArgument -> Effect (Result String Unit)
 executor cmdName usageString args = do
@@ -204,7 +226,7 @@ executor cmdName usageString args = do
     , ValArgList extraJournalPaths
     ] -> do
       currentDir <- cwd
-      buildLedgerAndRun currentDir jourPathRel extraJournalPaths $
+      buildRunExit currentDir jourPathRel extraJournalPaths $
         \ledger@(Ledger { transactions }) -> do
           let
             journalDir =

src/Transity/Data/Ledger.purs

@@ -33,7 +33,7 @@ import Data.Argonaut.Parser (jsonParser)
 import Data.Array (concat, groupBy, sort, sortBy, uncons, (!!), length)
 import Data.Array as Array
 import Data.DateTime (DateTime)
-import Data.Foldable (all, find)
+import Data.Foldable (all, find, foldMap)
 import Data.Function (flip)
 import Data.Generic.Rep (class Generic)
 import Data.HeytingAlgebra (not)
@@ -188,7 +188,7 @@ verifyBalances balanceMap balancingTransfers =
       in
         if tfHeadRec.note == Just "___BALANCE___" then
           if not $ isAmountInMapZero newBal tfHeadRec.from targetCom then Error
-            ( "Error:\nThe verification balance of account '" <> tfHeadRec.from
+            ( "ERROR:\nThe verification balance of account '" <> tfHeadRec.from
                 <> "' on '"
                 <> (fromMaybe "" $ tfHeadRec.utc <#> dateShowPretty)
                 <> "'\nis off by "
@@ -241,28 +241,19 @@ fromJson json = do
   ledger <- stringifyJsonDecodeError $ fromEither $ decodeJson jsonObj
   pure ledger
 
--- TODO: >>= verifyAccounts
--- TODO: >>= verifyLedgerBalances
--- TODO: >>= addInitalBalance
-
 fromYaml :: String -> Result String Ledger
-fromYaml yaml =
+fromYaml yaml = do
   let
     result = yaml
       # parseYAMLToJson
       # runExcept
       # fromEither
-    unverified = case result of
-      Error error -> Error
-        ( "Could not parse YAML: "
-            <> fold (map renderForeignError error)
-        )
-      Ok json -> stringifyJsonDecodeError $ fromEither $ decodeJson json
-  in
-    unverified
 
--- TODO: >>= verifyAccounts
--- TODO: >>= verifyLedgerBalances
+  case result of
+    Error error ->
+      Error $ "Could not parse YAML: " <> foldMap renderForeignError error
+    Ok json ->
+      stringifyJsonDecodeError $ fromEither $ decodeJson json
 
 showPretty :: Ledger -> String
 showPretty = showPrettyAligned ColorNo

test/Main.purs

@@ -1,7 +1,8 @@
 module Test.Main where
 
-import Test.Fixtures
+import Prelude (Unit, (==))
 
+import CliSpec.Types (CliArgPrim(..))
 import Control.Applicative (pure)
 import Control.Bind (discard, bind, (>>=))
 import Data.Argonaut.Core (stringify)
@@ -32,16 +33,19 @@ import Data.Tuple (Tuple(..))
 import Data.Unit (unit)
 import Effect (Effect)
 import Effect.Aff (Aff, launchAff_)
+import Effect.Class (liftEffect)
 import JS.BigInt (fromString) as BigInt
 import Partial.Unsafe (unsafePartial)
-import Prelude (Unit, (==))
-import Test.CliSpec as Test.CliSpec
-import Test.Fixtures as Fixtures
 import Test.Spec (describe, it)
-import Test.Spec.Assertions (expectError, fail, shouldEqual)
+import Test.Spec.Assertions (expectError, fail, shouldEqual, shouldSatisfy)
 import Test.Spec.Assertions.String (shouldContain)
 import Test.Spec.Reporter.Console (consoleReporter)
 import Test.Spec.Runner (runSpec)
+
+import Main (buildLedgerAndRun)
+import Test.CliSpec as Test.CliSpec
+import Test.Fixtures
+import Test.Fixtures as Fixtures
 import Transity.Data.Account (Account(..))
 import Transity.Data.Account as Account
 import Transity.Data.Amount (Amount(..), Commodity(..))
@@ -553,13 +557,10 @@ main = launchAff_ $ runSpec [ consoleReporter ] do
           (show actual) `shouldEqualString` (show expected)
 
         describe "Verification" do
-
           it "ledger without verification balances is valid" do
             let verification = Ledger.verifyLedgerBalances ledger
 
-            (isOk verification) `shouldEqual` true
-          -- TODO: Use instead following with purescript-spec@v3.1.0
-          -- verification `shouldSatisfy` isOk
+            verification `shouldSatisfy` isOk
 
           it "fails if verification balances are incorrect" do
             let
@@ -813,6 +814,15 @@ main = launchAff_ $ runSpec [ consoleReporter ] do
 
             (isOk verification) `shouldEqual` true
 
+          it "verifies balances for combined journals" do
+            execResult <- liftEffect $ buildLedgerAndRun
+              "."
+              "test/fixtures/journal1.yaml"
+              [ TextArg "test/fixtures/journal2.yaml" ]
+              (\_ledger -> pure $ Ok unit)
+
+            (isError execResult) `shouldEqual` true
+
         it "subtracts a transfer from a balance map" do
           let
             result = balanceMap `Ledger.subtractTransfer` transferSimple

test/fixtures/journal1.yaml

@@ -0,0 +1,35 @@
+owner: john
+
+entities:
+  -
+    id: anna
+    accounts:
+      - id: wallet
+        balances:
+          - utc: '2000-01-01 12:00'
+            amounts: []
+          - utc: '2006-01-01 12:00'
+            amounts: [3 €]
+          - utc: '2010-01-01 12:00'
+            amounts: [3 €, 4 $]
+  -
+    id: ben
+    accounts: [id: wallet]
+
+  -
+    id: john
+    accounts: [id: wallet]
+
+transactions:
+  -
+    utc: '2005-01-01 12:00'
+    transfers:
+      - from: ben:wallet
+        to: anna:wallet
+        amount: 3 €
+  -
+    utc: '2007-01-01 12:00'
+    transfers:
+      - from: ben:wallet
+        to: anna:wallet
+        amount: 4 $

test/fixtures/journal2.yaml

@@ -0,0 +1,29 @@
+owner: John Doe
+
+entities:
+  -
+    id: lisa
+    accounts:
+      - id: wallet
+        balances:
+          - utc: '2020-01-01 12:00'
+            amounts: []
+          - utc: '2023-01-01 12:00'
+            amounts: [4 €, 7 $]
+  -
+    id: marc
+    accounts: [id: wallet]
+
+transactions:
+  -
+    utc: '2022-01-01 12:00'
+    transfers:
+      - from: lisa:wallet
+        to: marc:wallet
+        amount: 3 €
+  -
+    utc: '2023-01-01 12:00'
+    transfers:
+      - from: marc:wallet
+        to: john:wallet
+        amount: 8 $