buchhaltung 0.0.5 → 0.0.6
raw patch · 15 files changed
+1299/−555 lines, 15 filesdep ~Decimaldep ~ListLikedep ~MissingH
Dependency ranges changed: Decimal, ListLike, MissingH, aeson, ansi-wl-pprint, array, async, boxes, bytestring, cassava, containers, data-default, deepseq, directory, edit-distance, file-embed, filepath, formatting, hashable, haskeline, hint, hledger, hledger-lib, lens, lifted-base, megaparsec, monad-control, mtl, optparse-applicative, parsec, process, regex-compat, regex-tdfa, regex-tdfa-text, safe, semigroups, split, strict, temporary, text, time, transformers, unordered-containers, vector, yaml
Files
- README.md +43/−22
- buchhaltung.cabal +168/−160
- config.yml +23/−0
- src/Buchhaltung/Add.hs +127/−89
- src/Buchhaltung/Ask.hs +15/−9
- src/Buchhaltung/Commandline.hs +22/−30
- src/Buchhaltung/Common.hs +88/−27
- src/Buchhaltung/Import.hs +23/−15
- src/Buchhaltung/Importers.hs +550/−57
- src/Buchhaltung/Match.hs +70/−46
- src/Buchhaltung/OptionParsers.hs +52/−8
- src/Buchhaltung/Types.hs +40/−22
- src/Buchhaltung/Uniques.hs +77/−49
- src/Buchhaltung/Utils.hs +0/−5
- stack.yaml +1/−16
README.md view
@@ -6,7 +6,15 @@ *Buchhaltung* (['buːχˌhaltʊŋ], German *book keeping*), written in Haskell, helps you keep track of your finances on the command line with minimal effort. It provides tools that help you in creating a complete ledger of all your bank and savings accounts', credit cards', and other transactions, in a text-based ledger format, that is readable by the [ledger CLI tool](http://www.ledger-cli.org/) and its many [derivatives](http://plaintextaccounting.org/). * Fetch your bank transaction directly via FinTS/HBCI/OFXDirectConnect-* Import transactions from PayPal (can be customized to other formats)+* Import transactions from + * PayPal+ * Barclaycard Visa+ * comdirect Visa+ * Revolut+ * Barclays UK CSV+ * NatWest International CSV+ * and Monefy expense tracker app+ * ... or define your own formats * Semi-automatically match transactions to accounts using Bayesian classification * Semi-automatic transaction entry with meaningful suggestions in keyboard-based speed mode * It is couples/room-mates aware: Create several transaction simultaneously (see [Multi-user add](#multi-user-add))@@ -70,16 +78,16 @@ If you want a folder under a different location, either create a symlink or set the `BUCHHALTUNG` environment variable to that location. -2. Edit the `config.yml`.+2. Edit the [`config.yml`](config.yml). 3. Make sure the configured ledger files exist. # Getting help -* The `config.yml` file provides excessive comments.+* The [`config.yml`](config.yml) file provides excessive comments. * This readme documents most functionality. * Every command and subcommand shows a help message when invoked with `-h`.-* Read the haddock documentation and source code on [Hackage](https://hackage.haskell.org/package/hashtables).+* Read the haddock documentation and source code on [Hackage](https://hackage.haskell.org/package/buchhaltung). * Open an issue. * Write an email. @@ -93,17 +101,17 @@ buchhaltung setup ``` -To clean everything aqbanking related remove the configured `aqBanking.configDir` and rerun the `setup` command.+To clean everything aqbanking related remove the configured [`aqBanking.configDir`](config.yml) and rerun the `setup` command. ### Manual AqBanking setup -Currently only the HBCI `PinTan` method is supported by the `setup` command (pull requests welcome). For other methods or if the AqBanking setup fails due to other reasons, you can configure AqBanking manually into the configured `aqBanking.configDir` (see for help [here](https://www.aquamaniac.de/sites/download/download.php?package=09&release=09&file=01&dummy=aqbanking4-handbook-20091231.pdf) or [here](https://wiki.gnucash.org/wiki/AqBanking), usually via `aqhbci-tool4 -C <aqBanking.configDir>`).+Currently only the HBCI `PinTan` method is supported by the `setup` command (pull requests welcome). For other methods or if the AqBanking setup fails due to other reasons, you can configure AqBanking manually into the configured [`aqBanking.configDir`](config.yml) (see for help [here](https://www.aquamaniac.de/sites/download/download.php?package=09&release=09&file=01&dummy=aqbanking4-handbook-20091231.pdf) or [here](https://wiki.gnucash.org/wiki/AqBanking), usually via `aqhbci-tool4 -C <aqBanking.configDir>`). So far, I have not tested the OFXDirectConnect capabilities of AqBanking (please share your experiences), but `buchhaltung` should transparently support any method offered by AqBanking. ## Importing transactions -There various ways (including from PayPal CSV files) to import transactions into your configured `ledgers.imported` file. They are presented in the following, but consult+There various ways (including from PayPal CSV files) to import transactions into your configured [`ledgers.imported`](config.yml) file. They are presented in the following, but consult ```shell buchhaltung import -h@@ -111,7 +119,7 @@ and the `-h` calls to its subcommands to see the currently available functionality. -The accounts of the imported transactions will be taken from the configured `bankAccounts` and the offsetting balance will be posted to an account named `TODO`, and will be replaced by [`match`](#match-accounts).+The accounts of the imported transactions will be taken from the configured [`bankAccounts`](config.yml) and the offsetting balance will be posted to an account named `TODO`, and will be replaced by [`match`](#match-accounts). The original source information will be included in the second posting's comment and used for learning the account mappings and to find and handle duplicates. @@ -133,19 +141,23 @@ For other CSV formats you have two options: -1) Hack the source, which is fun and should be easy since you only need to-copy and adapt from the other importers.+1) Use the importers for PayPal, Barclaycard Visa, comdirect Visa, Revolut, and Monefy expense tracker app. 2) Bring your CSV into a currently supported format. The AqBanking format works especially well -In both cases, you can look at `aqbankingImporter`,-`comdirectVisaImporter` and `paypalImporter` in [Buchhaltung/Importers.hs](https://hackage.haskell.org/package/buchhaltung-0.0.3/docs/buchhaltung/Buchhaltung-Importers.html).+3) Hack the source, which is fun and should be easy since you only need to+copy and adapt from the other importers. +You can look at `aqbankingImporter`, `comdirectVisaImporter` and+`paypalImporter`+in+[Buchhaltung/Importers.hs](https://hackage.haskell.org/package/buchhaltung-0.0.3/docs/buchhaltung/Buchhaltung-Importers.html) (or on [GitHub](src/Buchhaltung/Importers.hs)).+ ### Resolve duplicates Banks often minimally change the way they report transactions which leads to unwanted duplicates. -When importing, *Buchhaltung* will identify duplicates based on `([(Commodity,Quantity)], AccountName, Day)` and interactively resolve them by showing the user what fields have changed. If there are several candidates, it sorts the candidates according to similarity using `levenshteinDistance` from [edit-distance](https://hackage.haskell.org/package/edit-distance-0.2.1.3). (See [`Buchhaltung.Uniques.addNew`](https://github.com/johannesgerer/buchhaltung/blob/master/src/Buchhaltung/Uniques.hs#L27))+When importing, *Buchhaltung* will identify duplicates based on `([(Commodity,Quantity)], AccountName, Day)` and interactively resolve them by showing the user what fields have changed. If there are several candidates, it sorts the candidates according to similarity using `levenshteinDistance` from [edit-distance](https://hackage.haskell.org/package/edit-distance-0.2.1.3). (See [`Buchhaltung.Uniques.addNew`](src/Buchhaltung/Uniques.hs#L27)) ## Match accounts @@ -153,12 +165,13 @@ buchhaltung match ``` -This command asks the user for the offsetting accounts of imported transactions, or more specifically, transaction whose second posting's account begins with `TODO`. +This command asks the user for the offsetting accounts of imported transactions, or more specifically, transaction whose second posting's account begins with `TODO` and does not match any regex in [`ignoredAccountsOnMatch`](config.yml). Have a look at the example output [here](example_output/match.md). -The significantly speed up this process, it learns the account mapping from existing transactions in the configured `ledgers.imported` file using the original source of the imported transaction. +The significantly speed up this process, it learns the account mapping from existing transactions in the configured [`ledgers.imported`](config.yml) file using the original source of the imported transaction. +Please note that you will have to enter account information in **reverse order**: for example `Expenses:Food` has to be entered as `Food:Expenses`. See [this](#input-and-tab-completion) information about the account input field. @@ -178,6 +191,8 @@ * ... +See also [this issues](https://github.com/johannesgerer/buchhaltung/issues/16) on how you could use this.+ ## Enter transactions ```shell@@ -192,7 +207,7 @@ All input fields save their history in the current directory. It can be browsed using up and down arrow keys. -The account input fields support TAB completion. To make this even more useful, the account hierarchy is read in reverse order. For example `Expenses:Food` has to be entered as `Food:Expenses`.+The account input fields support TAB completion. To make this even more useful, the account hierarchy is read in reverse order. For example `Expenses:Food` has to be entered as `Food:Expenses`. This behaviour can be deactivated by setting [`reverseAccountInput`](config.yml) to `False`. ### Suggested transactions @@ -200,11 +215,11 @@ * whose second posting has not been cleared (i.e. marked with an asterisk in front of the account name, and * whose first posting's amount has the absolute value as the entered amount-* whose first posting's account is contained in the configured `bankAccounts` and does not match any of regexes in `ignoredAccountsOnAdd`.+* whose first posting's account is contained in the configured [`bankAccounts`](config.yml) and does not match any of regexes in [`ignoredAccountsOnAdd`](config.yml). ### Suggested accounts -Once the first posting's account has been entered, the editor suggests accounts for the second posting based on the frequency of the resulting transaction's accounts in the configured `ledgers.addedByThisUser` file.+Once the first posting's account has been entered, the editor suggests accounts for the second posting based on the frequency of the resulting transaction's accounts in the configured [`ledgers.addedByThisUser`](config.yml) file. ### Assertions \& assignments @@ -212,7 +227,7 @@ ### Default currency -In order to be able to enter naked amounts and have the currency added automatically, add a [default currency](http://hledger.org/manual.html#default-commodity) to the configured `addedByThisUser` ledger file. Example:+In order to be able to enter naked amounts and have the currency added automatically, add a [default currency](http://hledger.org/manual.html#default-commodity) to the configured [`addedByThisUser`](config.yml) ledger file. Example: ``` D 1,000.000 EUR@@ -225,7 +240,7 @@ buchhaltung add -w alice ``` -If there is more than one user configured — possibly each with their own ledger, they can be included/activated via the command-line argument `-w`. This enables you to enter a transaction where postings belong to different users. When done, a transaction for each user will be generated containing their respective postings and a balancing posting to an account prefixed with the configured `accountPrefixOthers`.+If there is more than one user configured — possibly each with their own ledger, they can be included/activated via the command-line argument `-w`. This enables you to enter a transaction where postings belong to different users. When done, a transaction for each user will be generated containing their respective postings and a balancing posting to an account prefixed with the configured [`accountPrefixOthers`](config.yml). Example taken from the [output](example_output/add_multi_user.md) of the above command: @@ -278,7 +293,7 @@ buchhaltung hledger ``` -This calls the respective program with the `LEDGER` environment variable set to the configured `mainLedger` or `mainHledger`.+This calls the respective program with the `LEDGER` environment variable set to the configured [`mainLedger`](config.yml) or [`mainHledger`](config.yml). ### Commit the changes @@ -286,4 +301,10 @@ buchhaltung commit -a -m'checking account ok' ``` -this commits all changes to the git repository that contains the `mainLedger` file. The commit message will also contain the output of `buchhaltung lb` and `buchhaltung ledger balance --end tomorrow`.+or++```shell+buchhaltung commitHledger -a -m'checking account ok'+```++this commits all changes to the git repository that contains the [`mainLedger`](config.yml) file. The commit message will also contain the output of `buchhaltung lb` and `buchhaltung ledger balance --end tomorrow`.
buchhaltung.cabal view
@@ -1,167 +1,175 @@-name: buchhaltung-version: 0.0.5-cabal-version: >=1.10-build-type: Custom-license: MIT-license-file: LICENSE-maintainer: Johannes Gerer <oss@johannesgerer.com>-stability: Experimental-homepage: http://johannesgerer.com/buchhaltung-bug-reports: http://github.com/johannesgerer/buchhaltung/issues-synopsis: Automates most of your plain text accounting data entry in ledger format.+name: buchhaltung+version: 0.0.6+Bug-Reports: http://github.com/johannesgerer/buchhaltung/issues+License: MIT+License-file: LICENSE+Author: Johannes Gerer+Maintainer: Johannes Gerer <oss@johannesgerer.com>+Homepage: http://johannesgerer.com/buchhaltung+Stability: Experimental+category: Finance+synopsis: Automates most of your plain text accounting data entry in ledger format. description:- Automatic import and deduplication (from CSV\/FinTS\/HBCI\/OFX), bayesian account matching, and efficient manual entry of <http://plaintextaccounting.org/ ledger> transactions.- .- See <https://github.com/johannesgerer/buchhaltung Readme> on Github.-category: Finance-author: Johannes Gerer-tested-with: GHC ==7.10.1-extra-source-files:- README.md- example_output/add.md- example_output/add_multi_user.md- example_output/match.md- stack.yaml- config.yml- buchhaltung_autocomplete.bash- buchhaltung_autocomplete.zsh- exchange_rates/btc_eur+ Automatic import and deduplication (from CSV\/FinTS\/HBCI\/OFX), bayesian account matching, and efficient manual entry of <http://plaintextaccounting.org/ ledger> transactions. -source-repository head- type: git- location: http://github.com/johannesgerer/buchhaltung+ .+ See <https://github.com/johannesgerer/buchhaltung Readme> on Github. +tested-with: GHC == 7.10.1+cabal-version: >= 1.10+build-type: Custom++Extra-source-files:+ README.md+ example_output/add.md+ example_output/add_multi_user.md+ example_output/match.md+ stack.yaml+ config.yml+ buchhaltung_autocomplete.bash+ buchhaltung_autocomplete.zsh+ exchange_rates/btc_eur++custom-setup+ setup-depends: base >= 4.0.0.0 && < 5, Cabal++ library- exposed-modules:- Buchhaltung.Add- Buchhaltung.AQBanking- Buchhaltung.Ask- Buchhaltung.Common- Buchhaltung.Import- Buchhaltung.Importers- Buchhaltung.Match- Buchhaltung.Commandline- Buchhaltung.OptionParsers- Buchhaltung.Types- Buchhaltung.Uniques- Buchhaltung.Utils- Buchhaltung.ZipEdit2- Buchhaltung.Zipper- build-depends:- Decimal >=0.4.2 && <0.5,- ListLike ==4.5.*,- MissingH >=1.4.0.1 && <1.5,- aeson >=1.0.0 && <1.1,- ansi-wl-pprint >=0.6.7.3 && <0.7,- array >=0.5.1.1 && <0.6,- async >=2.1.1 && <2.2,- base >=4.0.0.0 && <5,- boxes >=0.1.4 && <0.2,- bytestring >=0.10.8.1 && <0.11,- lens >=4.15.1 && <4.16,- cassava >=0.4.1.0 && <0.5,- containers >=0.5.7.1 && <0.6,- data-default >=0.7.1.1 && <0.8,- deepseq >=1.4.2.0 && <1.5,- directory >=1.2.6.2 && <1.3,- edit-distance >=0.2.2.1 && <0.3,- file-embed >=0.0.10 && <0.1,- filepath >=1.4.1.0 && <1.5,- formatting >=6.2.4 && <6.3,- hashable >=1.2.4.0 && <1.3,- haskeline >=0.7.2.3 && <0.8,- hint >=0.6.0 && <0.7,- hledger ==1.1.*,- hledger-lib ==1.1.*,- lifted-base >=0.2.3.8 && <0.3,- megaparsec >=5.0.0 && <5.2,- monad-control >=1.0.1.0 && <1.1,- mtl >=2.2.1 && <2.3,- optparse-applicative ==0.13.*,- parsec >=3.1.11 && <3.2,- process >=1.1.0.2 && <1.5,- regex-compat >=0.95.1 && <0.96,- regex-tdfa >=1.2.2 && <1.3,- regex-tdfa-text >=1.0.0.3 && <1.1,- safe >=0.3.10 && <0.4,- semigroups >=0.18.2 && <0.19,- split >=0.2.3.1 && <0.3,- strict >=0.3.2 && <0.4,- temporary >=1.2.0.4 && <1.3,- text >=1.2.2.1 && <1.3,- time >=1.6.0.1 && <1.7,- transformers >=0.5.2.0 && <0.6,- unordered-containers >=0.2.7.2 && <0.3,- vector >=0.11.0.0 && <0.12,- yaml >=0.8.21.1 && <0.9- default-language: Haskell2010- hs-source-dirs: src+ Hs-Source-Dirs: src+ exposed-modules: Buchhaltung.Add+ Buchhaltung.AQBanking+ Buchhaltung.Ask+ Buchhaltung.Common+ Buchhaltung.Import+ Buchhaltung.Importers+ Buchhaltung.Match+ Buchhaltung.Commandline+ Buchhaltung.OptionParsers+ Buchhaltung.Types+ Buchhaltung.Uniques+ Buchhaltung.Utils+ Buchhaltung.ZipEdit2+ Buchhaltung.Zipper+ default-language: Haskell2010+ build-depends:+ Decimal >= 0.4.2+ , ListLike+ , MissingH+ , aeson >= 1.0.0+ , ansi-wl-pprint+ , array+ , async+ , base >= 4.0.0.0 && < 5+ , boxes+ , bytestring+ , lens+ , cassava >= 0.4.1.0+ , containers+ , data-default+ , deepseq+ , directory+ , edit-distance+ , file-embed+ , filepath+ , formatting+ , hashable+ , haskeline+ , hint+ , hledger >= 1.1+ , hledger-lib >= 1.1+ , lifted-base+ , megaparsec >= 5.0.0+ , monad-control+ , mtl+ , optparse-applicative >= 0.13+ , parsec+ , process >= 1.1.0.2+ , regex-compat+ , regex-tdfa+ , regex-tdfa-text+ , safe+ , semigroups+ , split+ , strict+ , temporary+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , yaml executable buchhaltung- main-is: main.hs- build-depends:- Decimal >=0.4.2 && <0.5,- ListLike ==4.5.*,- MissingH >=1.4.0.1 && <1.5,- aeson >=1.0.0 && <1.1,- ansi-wl-pprint >=0.6.7.3 && <0.7,- array >=0.5.1.1 && <0.6,- async >=2.1.1 && <2.2,- base >=4.0.0.0 && <5,- boxes >=0.1.4 && <0.2,- bytestring >=0.10.8.1 && <0.11,- lens >=4.15.1 && <4.16,- cassava >=0.4.1.0 && <0.5,- containers >=0.5.7.1 && <0.6,- data-default >=0.7.1.1 && <0.8,- deepseq >=1.4.2.0 && <1.5,- directory >=1.2.6.2 && <1.3,- edit-distance >=0.2.2.1 && <0.3,- file-embed >=0.0.10 && <0.1,- filepath >=1.4.1.0 && <1.5,- formatting >=6.2.4 && <6.3,- hashable >=1.2.4.0 && <1.3,- haskeline >=0.7.2.3 && <0.8,- hint >=0.6.0 && <0.7,- hledger ==1.1.*,- hledger-lib ==1.1.*,- lifted-base >=0.2.3.8 && <0.3,- megaparsec >=5.0.0 && <5.2,- monad-control >=1.0.1.0 && <1.1,- mtl >=2.2.1 && <2.3,- optparse-applicative ==0.13.*,- parsec >=3.1.11 && <3.2,- process >=1.1.0.2 && <1.5,- regex-compat >=0.95.1 && <0.96,- regex-tdfa >=1.2.2 && <1.3,- regex-tdfa-text >=1.0.0.3 && <1.1,- safe >=0.3.10 && <0.4,- semigroups >=0.18.2 && <0.19,- split >=0.2.3.1 && <0.3,- strict >=0.3.2 && <0.4,- temporary >=1.2.0.4 && <1.3,- text >=1.2.2.1 && <1.3,- time >=1.6.0.1 && <1.7,- transformers >=0.5.2.0 && <0.6,- unordered-containers >=0.2.7.2 && <0.3,- vector >=0.11.0.0 && <0.12,- yaml >=0.8.21.1 && <0.9- default-language: Haskell2010- hs-source-dirs: src- other-modules:- Buchhaltung.Add- Buchhaltung.AQBanking- Buchhaltung.Ask- Buchhaltung.Common- Buchhaltung.Import- Buchhaltung.Importers- Buchhaltung.Match- Buchhaltung.Commandline- Buchhaltung.OptionParsers- Buchhaltung.Types- Buchhaltung.Uniques- Buchhaltung.Utils- Buchhaltung.ZipEdit2- Buchhaltung.Zipper- ghc-options: -threaded+ Hs-Source-Dirs: src+ main-is: main.hs+ other-modules: Buchhaltung.Add+ Buchhaltung.AQBanking+ Buchhaltung.Ask+ Buchhaltung.Common+ Buchhaltung.Import+ Buchhaltung.Importers+ Buchhaltung.Match+ Buchhaltung.Commandline+ Buchhaltung.OptionParsers+ Buchhaltung.Types+ Buchhaltung.Uniques+ Buchhaltung.Utils+ Buchhaltung.ZipEdit2+ Buchhaltung.Zipper+ default-language: Haskell2010+ ghc-options: -threaded+ -fwarn-unused-binds+ -fwarn-unused-matches+ -fwarn-incomplete-patterns+ build-depends:+ Decimal >= 0.4.2+ , ListLike+ , MissingH+ , aeson >= 1.0.0+ , ansi-wl-pprint+ , array+ , async+ , base >= 4.0.0.0 && < 5+ , boxes+ , bytestring+ , lens+ , cassava >= 0.4.1.0+ , containers+ , data-default+ , deepseq+ , directory+ , edit-distance+ , file-embed+ , filepath+ , formatting+ , hashable+ , haskeline+ , hint+ , hledger >= 1.1+ , hledger-lib >= 1.1+ , lifted-base+ , megaparsec >= 5.0.0+ , monad-control+ , mtl+ , optparse-applicative >= 0.13+ , parsec+ , process >= 1.1.0.2+ , regex-compat+ , regex-tdfa+ , regex-tdfa-text+ , safe+ , semigroups+ , split+ , strict+ , temporary+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , yaml ++Source-repository head+ Type: git+ Location: http://github.com/johannesgerer/buchhaltung
config.yml view
@@ -1,6 +1,20 @@+# optional: custom executables (names or full paths). The following shows the default values++ledgerExecutable: ledger+hledgerExecutable: hledger+dbaclExecutable: dbacl+aqBankingExecutable: aqbanking-cli+aqhbciToolExecutable: aqhbci-tool4++# user config users: - name: jo ledgers:+ ### IMPORTANT NOTE: make sure the following files exist.+ + ### As a safety feature `buchhaltung` will NOT create them on the fly, as+ ### it cannot differentiate between a misconfigured config and the user's wish+ ### to create an empty ledger. (enhancement: ask the user) # main ledger file passed to `hledger` or `ledger` and used to create the commit message. # this file should (at least) include the other files.@@ -21,6 +35,15 @@ # optional: account prefix used when 'add'ing transactions for other users accountPrefixOthers: Accounts receivable:Friends++ # reverse the order of account paths+ # (e.g. `Expenses:Food` has to be entered as `Food:Expenses`)+ # (default: True)+ reverseAccountInput: True++ # regex matchind accounts whose should not be suggested when 'match'ing+ ignoredAccountsOnMatch:+ - "Old" # regex matchind accounts whose transactions should not be suggested when 'add'ing ignoredAccountsOnAdd:
src/Buchhaltung/Add.hs view
@@ -39,13 +39,13 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format+import Data.Void import Formatting (sformat, (%), (%.)) import qualified Formatting as F import qualified Formatting.ShortFormatters as F import Hledger hiding (at) import Safe-import qualified Text.Megaparsec as MP hiding (State)-import qualified Text.Megaparsec.Text as MP+import qualified Text.Megaparsec as MP import Text.Parsec.Char import Text.Parsec.Combinator (eof,many1) import Text.Parsec.Prim (parse,try)@@ -70,8 +70,9 @@ -- * Types -type AddT' env m = RWST (FullOptions env) () Journal (ErrorT m)+type UserJournals = M.Map Username Journal +type AddT' env m = RWST (FullOptions env) () UserJournals (ErrorT m) -- | Monad Transformer used to describe the 'add' program --@@ -107,9 +108,18 @@ add :: AddT' [Username] IO () add = do- partner <- mapM (toPartner <=< lookupUser) =<< reader oEnv- liftIO . putStr =<< hello- withRWST (\r s -> (r{oEnv = partner}, s)) $ do+ user <- user+ partners <- mapM (toPartner <=< lookupUser) =<< reader oEnv+ options <- ask+ let f (user, files) = do+ journal <- loadJournal+ (files ++ [Just . addedByThisUser , addedByOthers])+ options{ oUser = user }+ return (name user , journal )+ journals <- fmap M.fromList . mapM f $ (user, [Just . imported])+ : (fmap (\x -> (pUser x, []) ) partners)+ withRWST (\r _ -> (r{oEnv = partners}, journals)) $ do+ liftIO . putStr =<< hello forever mainLoop -- | Convert given 'Username' to 'Partner'.@@ -123,16 +133,16 @@ -- | Welcome message-hello :: Monad m => AddT' env m String+hello :: Monad m => AddT m String hello = do un <- readUser name- j <- get+ j <- gets M.elems return $ intercalate "\n\n" [ "Hi "<> fshow un <> "!" ,"Use readline keys to edit, use tab key to complete account names." ,"A code (in parentheses) may be entered following transaction dates." ,"A comment may be entered following descriptions or amounts."- , show ( length $ jtxns j) ++ " Transactions found"+ , show ( sum $ length . jtxns <$> j) ++ " Transactions found" ] @@ -141,12 +151,13 @@ mainLoop = do liftIO $ putStr "\n\nStarting new transaction...\n" (iAm, match) <- sugTrans- let ask j = do iDa <- askDate Nothing- iDe <- askDescription Nothing- iAc <- myAskAccount j Nothing (Just "learn") (Left "Enter source account" )- return (nulltransaction{tdate=fst iDa, tcode=snd iDa- ,tdescription=iDe}- ,iAc,iAm)+ let ask = do iDa <- liftIO $ askDate Nothing+ iDe <- liftIO $ askDescription Nothing+ user <- user+ iAc <- myAskAccount user Nothing (Just "learn") (Left "Enter source account" )+ return (nulltransaction{tdate=fst iDa, tcode=snd iDa+ ,tdescription=iDe}+ ,iAc,iAm) useMatch t = return ( nulltransaction{tdate=tdate t, tdescription=tdescription t} ,paccount p2, AA "" Nothing $ negate $ pamount p2)@@ -157,7 +168,7 @@ -- pos = tpostings t -- PROBLEM1: it's not HBCI, instead sugTrans and clearSecondPosting -- emphazises on the "second" posting- (transa,iAc,iAm2) <- maybe (get >>= liftIO . ask) useMatch match+ (transa,iAc,iAm2) <- maybe ask useMatch match suggs <- suggestedPostings iAc $ Just iAm2 result <- edit myEd transa suggs moveToNextEmpty saveAndClear match (isJust result) =<< finishTransaction True result@@ -172,36 +183,38 @@ -- ^ transactioons to be saved: ((user's,other's), -> AddT IO () saveAndClear match clearIt (userT, partnerTS) = do- j <- get- let saveMine Nothing = clear j- saveMine (Just res) = do+ user <- user++ forM_ userT $ \res -> do -- clear the first posting, of the new transaction, if there was a -- match -- ReferenceA let newt = (if isJust match then clearNthPosting 0 else id) res -- add it to the user's journal (+ file) file <- readLedger addedByThisUser- j' <- myJournalAddTransaction file [newt]- infoNewTx =<< user- -- clear the matching transactions second posting in the file- clear j'- clear j = maybe (return j)- (saveChanges . changeTransaction .- (:[]) . clearSecondPosting) $ guard clearIt *> match- savePartners (partner, tx) = do- myJournalAddTransaction (partnerLedger partner) [tx]- infoNewTx $ pUser partner- j' <- saveMine userT- mapM savePartners partnerTS- put j'+ myJournalAddTransaction file user [newt] + forM_ partnerTS $ \(partner, tx) ->+ myJournalAddTransaction (partnerLedger partner) (pUser partner) [tx] -clearSecondPosting :: Transaction -> (Transaction, Transaction)-clearSecondPosting t = (t, clearNthPosting 1 t)+ -- clear the matching transactions second posting in the file+ flip traverse_ (guard clearIt *> match) $ \trans -> do+ oldJ <- getJournal user+ newJ <- saveChanges (Just oldJ) .+ changeTransaction . (:[]) $ clearSecondPosting trans+ modifyJournal user $ const newJ +-- TODO use alterF from containers-0.5.9.1+modifyJournal :: MonadState UserJournals m+ => User -> (Journal -> Journal) -> m ()+modifyJournal user mod = modify $ M.adjust mod $ name user -infoNewTx = liftIO . L.putStr .- sformat ("\nNew transaction created for '" %F.sh% "'\n") . name+getJournal :: MonadState UserJournals m+ => User -> m Journal+getJournal user = gets (M.! (name user)) +clearSecondPosting :: Transaction -> (Transaction, Transaction)+clearSecondPosting t = (t, clearNthPosting 1 t)+ -- | Split 'EditablePosting's in User's Postings and (Partner, -- Postings, Open Balance) split :: [EditablePosting] -> ([Posting],@@ -236,10 +249,15 @@ userTransfer (partner, _, sum) = nullP (partnerAccount partner) sum - partnerT (partner, ps, sum) = (,) partner $- toTP $ nullP (userAccount partner) (negate sum)+ partnerT (partner, ps, sum) = (,) partner $ toTP $+ -- this posting allows the other posting to be added to the+ -- suggested postings+ maybeToList (phantom <$> userT)+ ++ nullP (userAccount partner) (negate sum) ++ E.toList ps + phantom t = (head $ tpostings t) { pamount = nullmixedamt }+ toTP ps = (if check then either err id . balanceTransactionIfRequired else id) tr {tpostings = increasePrec <$> ps ,tcomment = comment}@@ -258,19 +276,20 @@ iso8601 :: UTCTime -> String iso8601 = formatTime defaultTimeLocale "%FT%TZ" --- | add transaction to ledger file-myJournalAddTransaction :: FilePath -> [Transaction] -> AddT IO Journal-myJournalAddTransaction relative trans = do+-- | add transaction to ledger file and return new ledger+myJournalAddTransaction ::+ FilePath -> User -> [Transaction] -> AddT IO ()+myJournalAddTransaction relative user trans = do file <- absolute relative liftIO $ ensureJournalFileExists file -- creates empty journal- j <- get liftIO $ L.appendFile file $ "\n" <> intercalateL "\n\n" trans' <> "\n"- return j{jtxns=jtxns j ++ trans }+ liftIO . L.putStr .+ sformat ("\nNew transaction created for '" %F.sh% "'\n") . name $ user+ modifyJournal user $ \j -> j{jtxns=jtxns j ++ trans } where trans' = L.dropWhileEnd (=='\n') . fshow <$> trans :: [T.Text] - clearNthPosting :: Int -> Transaction -> Transaction clearNthPosting n t = t{tpostings=p'} where p' = modifyNth (\x -> x{pstatus=Cleared}) n $ tpostings t@@ -306,9 +325,9 @@ user <- readUser id let f user Transaction{tpostings=p1:(p2:_)} =- -- the first posting's account is part of the accounts- -- automaticcaly handled by csv2ledger- (paccount p1 `S.member` accs)+ -- the first posting's account contains as prefix one of the accounts+ -- automatically handled by csv2ledger+ (any (`T.isPrefixOf` paccount p1) accs) -- the first amount of the first posting matched the entered -- amount in absolute values && (on (==) (abs.aquantity.head.amounts) iAm ( pamount p1 )@@ -327,7 +346,7 @@ -- toMyP t p2{pamount=negate $ pamount p2}) -- ignore certain accounts- && (not $ isIgnored user $ paccount p2)+ && (not $ isIgnored (ignoredAccountsOnAdd user) $ paccount p2) f _ _ = False -- s :: S.Set MyPosting -- s = error "doch benutzt?" -- Set.fromList $ toMyPs =<< jtxns j@@ -339,7 +358,7 @@ g Manual = return (answ, Nothing) g (Choose i) = return $ (answ, Just $ atNote "selectMatch" m' i) g Reenter = sugTrans- selectMatch =<< gets (filter (f user) . jtxns)+ selectMatch =<< filter (f user) . jtxns <$> getJournal user sugTrans' a = return (a, Nothing) -- data MyPosting = MyP {mypDay::Day, mypAcc::AccountName,mypAmt::Amount} -- deriving (Show)@@ -562,23 +581,31 @@ ,"next"] -- | HLedger's 'smartdate' and code-dateandcodep :: MP.Parser (SmartDate, T.Text)+dateandcodep :: MP.Parsec Void T.Text (SmartDate, T.Text) dateandcodep = do d <- smartdate c <- optional codep many spacenonewline MP.eof return (d, maybe "" T.pack c) -myAskAccount j = askAccount completionList- where completionList = nub $ sort [ paccount p | t <- jtxns j- , p <- tpostings t]+myAskAccount+ :: User+ -> Maybe AccountName+ -> Maybe String+ -> Either T.Text T.Text+ -> AddT IO AccountName+myAskAccount user a1 a2 a3= do+ j <- getJournal user+ let completionList = nub $+ sort [ paccount p | t <- jtxns j, p <- tpostings t]+ askAccount completionList a1 a2 a3 askAmount :: Maybe AssertedAmount -- ^ default value, if "" is entered -> T.Text -- ^ prompt -> Maybe T.Text -- ^ initial -> AddT IO AssertedAmount askAmount def pr init = do- j <- get+ j <- getJournal =<< user liftIO $ editLoop (extract j) "Amount" ((id &&& showAssertedAmount) <$> def) Nothing (Left pr) init where@@ -599,7 +626,7 @@ parseAmount :: Journal- -> T.Text -> Either (MP.ParseError Char MP.Dec) AssertedAmount+ -> T.Text -> Either (MP.ParseError Char Void) AssertedAmount parseAmount j = parseWithState' j $ ((flip $ AA "") <$> (fmap (Mixed . pure) $ amountp MP.<|> return missingamt) <*> partialbalanceassertionp@@ -611,7 +638,7 @@ MP.<|> MP.try rightsymbolamountp MP.<|> nosymbolamountp2 -nosymbolamountp2 :: Monad m => JournalStateParser m Amount+nosymbolamountp2 :: Monad m => JournalParser m Amount nosymbolamountp2 = do (q,prec,mdec,mgrps) <- lift numberp p <- priceamountp@@ -620,7 +647,7 @@ let (c,s) = case defcs of Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec}) Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})- return $ Amount c q p s+ return $ Amount c q p s False MP.<?> "no-symbol amount" getDefaultCommodityAndStyle2@@ -662,16 +689,22 @@ type EditablePostings = Zipper EditablePosting -- | construct an 'EditablePosting'-editablePosting account amt n = do- ps <- partners- user <- user- return $ addPosting account amt EditablePosting+editablePosting account amt freq n users =+ addPosting account amt EditablePosting { epAccount = account- , epFreq=Nothing+ , epFreq=freq , epNumber=n , epPosting = Nothing- , epUser = differentiate $ E.cycle $ Left user E.:| (Right <$> ps)}+ , epUser = users } +-- for each user and partner a zipper that has them at the front and+-- an infinite repetition of the other users in the past.+userZippers = do+ partners <- partners+ user <- user+ return $ take (succ $ length partners) $ iterate fwd $+ differentiate $ E.cycle $ Left user E.:| (Right <$> partners)+ -- | generate and add new 'Posting' to 'EditablePosting' addPosting :: AccountName@@ -736,11 +769,28 @@ defNumSuggestedAccounts :: Int defNumSuggestedAccounts = 20 +suggestedPostingsSingleUser :: Monad m =>+ T.Text -> Zipper (Either User Partner) -> AddT m [EditablePosting]+suggestedPostingsSingleUser account userZipper = do+ j <- getJournal user+ return $ filterOtherUsersAccounts $ sortBy (flip $ comparing epFreq)+ $ fmap toEp $ group $ sort $ concatMap tail $ filter filt $+ ((paccount<$>) . tpostings) <$> jtxns j+ where+ user = getUser $ present userZipper+ filt x = account == head x && not ( null x )+ toEp accounts = editablePosting (head accounts) Nothing+ (Just $ length accounts) 0 userZipper+ filterOtherUsersAccounts = maybe id+ (\x -> filter $ not . L.isPrefixOf (x <> ":") . epAccount)+ $ accountPrefixOthers user+ -- | retrieve a number of suggested contra postings for a given -- account, sort frequency of that contra account for the given -- account. --+-- TODO incorporate old behavior: -- duplicate each posting for both users, but only if the -- other user's account is present in the suggestions. suggestedPostings :: MonadIO m@@ -748,31 +798,16 @@ -> Maybe AssertedAmount -> AddT m (E.NonEmpty EditablePosting) suggestedPostings account am = do- j <- get- filterPref <- maybe id (\x -> filter $ not . L.isPrefixOf (x <> ":") . epAccount)- <$> readUser accountPrefixOthers- nP <- succ . length <$> partners- let- toEp l = editablePosting (head l) Nothing 0- >>= \x -> return $ x{epFreq=Just $ length l}- matches = concatMap tail $ filter filt $- ((paccount<$>) . tpostings) <$> jtxns j- sugaccounts <- sortBy (flip $ comparing epFreq)- <$> mapM toEp (group $ sort matches)- let- s = filterPref sugaccounts- transformed :: [EditablePosting]- transformed = if length sugaccounts == length s then s- else do x <- s- take nP $ iterate next x- firstP <- editablePosting account am 0 -- ReferenceA+ userZippers <- userZippers+ let firstP =+ editablePosting account am Nothing 0 $ head userZippers -- ReferenceA num <- fromMaybe defNumSuggestedAccounts <$> readUser numSuggestedAccounts- return $ (E.:|) firstP $ take (pred num) $- zipWith (\n p -> p{epNumber=n}) [1..] transformed- where- filt x = account == head x && not ( null x )+ (E.:|) firstP . take (pred num) .+ zipWith (\n p -> p{epNumber=n}) [1..] . concat <$>+ mapM (suggestedPostingsSingleUser account) userZippers + -- | change posting's user to the next user next :: EditablePosting -> EditablePosting next s = s{epUser = fwd $ epUser s}@@ -800,7 +835,7 @@ [ let mark = if marked then "->" else " " :: String in [ sformat (F.d % "," %F.sh% " " %F.s% " " %F.st)- (epNumber x) (either name (name.pUser) $ present $ epUser x) mark+ (epNumber x) (name $ getUser $ present $ epUser x) mark $ epAccount x ,maybe "" (showMissing . pamount) $ epPosting x ,maybe "" (("= " <>) . showAmount2)@@ -814,6 +849,9 @@ showMissing amt | normaliseMixedAmount amt == missingmixedamt = "missing" | True = showMixedAmount2 amt +getUser :: Either User Partner -> User+getUser = either id pUser + totalBalance :: [EditablePosting] -> MixedAmount totalBalance = negate . sum . fmap pamount . mapMaybe epPosting @@ -829,13 +867,13 @@ addNewPosting :: Bool -- ^ for next partner -> EditablePostings -> AddT IO EditablePostings addNewPosting forNext old' = do- j <- get let postings = integrate old' nextP = (if forNext then fwd else id) $ epUser $ present old'- account <- liftIO $ myAskAccount j+ account <- myAskAccount (getUser $ present nextP) (Just $ epAccount $ present old') Nothing $ Left "Account"- new <- editablePosting account Nothing $ length postings+ new <- editablePosting account Nothing Nothing (length postings)+ . head <$> userZippers let loop (ep:eps) done = if isNothing (epPosting ep) && epAccount ep == account
src/Buchhaltung/Ask.hs view
@@ -2,8 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} module Buchhaltung.Ask where +import Buchhaltung.Types import Control.Arrow import Control.Monad+import Control.Monad.Reader import Control.Monad.Trans.Class import Data.Char import Data.Function@@ -82,18 +84,22 @@ runInputT2 defaultSettings{historyFile = Just ".haskeline_history"} $ getInputLineWithInitial "edit: " (show v,"") -askAccount :: [AccountName] -- ^ completion list+askAccount :: (MonadReader (Options User config env) m, MonadIO m)+ => [AccountName] -- ^ completion list -> Maybe AccountName -- ^ default value, if "" is entered -> Maybe String -- ^ history file suffix -> Either T.Text T.Text -- ^ prompt- -> IO AccountName-askAccount completionList def suf pr =- revAccount2 <$> editLoop (maybe notNull (const Right) def)- (fromMaybe "Account" suf)- ((id &&& id) . revAccount2 <$> def)- (Just $ revAccount2 <$> completionList) pr Nothing --def+ -> m AccountName+askAccount completionList def suf pr = do+ revAccount <- askReverseAccount+ fmap revAccount . liftIO $ editLoop (maybe notNull (const Right) def)+ (fromMaybe "Account" suf)+ ((id &&& id) . revAccount <$> def)+ (Just $ revAccount <$> completionList) pr Nothing --def where notNull s = if s=="" then Left "Blank Account not allowed" else Right s -revAccount2 :: T.Text -> T.Text-revAccount2 = T.intercalate ":" . reverse . T.splitOn ":"+askReverseAccount :: MonadReader (Options User config env) m => m (T.Text -> T.Text)+askReverseAccount = g <$> readUser reverseAccountInput+ where g x = if fromMaybe True x then T.intercalate ":" . reverse . T.splitOn ":"+ else id
src/Buchhaltung/Commandline.hs view
@@ -13,6 +13,7 @@ import Control.Exception import Control.Monad.RWS.Strict import Control.Monad.Reader+import Data.Maybe import qualified Data.Text as T import Hledger.Data (Journal) import Hledger.Read (readJournalFile)@@ -26,7 +27,7 @@ runMain :: IO () runMain = do opts <- evaluate . force =<<- customExecParser (prefs $ showHelpOnError <> showHelpOnEmpty)+ customExecParser (prefs showHelpOnEmpty) =<< mainParser :: IO (RawOptions ()) let@@ -40,14 +41,25 @@ run :: Action -> FullOptions () -> ErrorT IO () run (Add partners) options =- void $ withJournals [imported, addedByThisUser] options- $ runRWST add options{oEnv = partners}+ void $ runRWST add options{oEnv = partners} mempty run (Import version file action) options = runImport action where runImport (Paypal puser) = importReadWrite paypalImporter (options' puser) file+ runImport NatwestIntl =+ importReadWrite natwestIntlImporter (options' ()) file+ runImport BarclaysUk =+ importReadWrite barclaysUkImporter (options' ()) file+ runImport BarclaycardUs =+ importReadWrite barclaycardusImporter (options' ()) file runImport (ComdirectVisa blz) = importReadWrite comdirectVisaImporter (options' blz) file+ runImport (Pncbank accountId) =+ importReadWrite pncbankImporter (options' accountId) file+ runImport (Revolut user) =+ importReadWrite revolutImporter (options' user) file+ runImport (Monefy settings) =+ importReadWrite monefyImporter (options' settings) file runImport AQBankingImport = importReadWrite aqbankingImporter (options' ()) file options' env = options{oEnv = (env, version)}@@ -59,34 +71,33 @@ options{oEnv = ((), version)} () when doMatch $ run Match options -run (Commit args) options = flip runReaderT options $ do+run (Commit hledger args) options = flip runReaderT options $ do un <- readUser $ show . name dir <- takeDirectory <&> absolute =<< readLedger mainLedger bal <- lift $ runAQ options $ readAqbanking ["listbal"]- sheet <- lift $ runLedger readProcess' ["balance", "-e", "tomorrow"] options+ sheet <- lift $ run readProcess' ["balance", "-e", "tomorrow"] options liftIO $ do setCurrentDirectory dir callProcess "git" $ "commit":args ++ ["-m", intercalateL "\n" $ ["User " ++ un, ""] ++ bal ++ ["Balance Sheet:", sheet]]+ where run = if hledger then runHledger else runLedger run ListBalances options = void $ runAQ options $ callAqbanking ["listbal"] run Setup options = void $ runAQ options aqbankingSetup run Match options =- withSystemTempDirectory "dbacl" $ \tmpdir -> do- withJournals [imported] options $ match options{oEnv = tmpdir}+ withSystemTempDirectory "dbacl" $ \tmpdir -> + loadJournal [Just . imported] options >>= match options{oEnv = tmpdir} run (AQBanking args) options = void $ runAQ options $ callAqbanking args run (Ledger args) options = runLedger callProcess args options -run (HLedger args) options =- runLedger' callProcess cHledgerExecutable- (maybe mainLedger const =<< mainHledger)- args options+run (HLedger args) options = runHledger callProcess args options runLedger run = runLedger' run cLedgerExecutable mainLedger+runHledger run = runLedger' run cHledgerExecutable (maybe mainLedger const =<< mainHledger) runLedger' run getExec getLedger args options = flip runReaderT options $ do exec <- readConfig getExec@@ -95,22 +106,3 @@ setEnv "LEDGER" ledger run exec args --- | performs an action taking a journal as argument. this journal is--- read from 'imported' and 'addedByThisUser' ledger files--- withJournals ::--- [Ledgers -> FilePath]--- -> FullOptions ()--- -> (Journal -> ErrorT IO b) -> ErrorT IO b-withJournals- :: (MonadError Msg m, MonadIO m) =>- [Ledgers -> FilePath]- -> Options User config env -> (Journal -> m b) -> m b-withJournals journals options f = do- liftIO $ printf "(Reading journal from \n%s)\n...\n\n"- $ intercalateL "\n" $ show <$> jfiles- journal <- liftIO $- -- to conquer problems with the `instance Monoid Journal`- right mconcat' . sequence <$> mapM (readJournalFile Nothing Nothing False) jfiles- either (throwError . T.pack) f journal- where jfiles = runReader (mapM (absolute <=< readLedger)- journals) options
src/Buchhaltung/Common.hs view
@@ -22,8 +22,9 @@ import Buchhaltung.Utils import Control.Applicative ((<$>)) import Control.Arrow-import Control.Lens hiding (noneOf, Getter, (<&>))+import Control.Lens (Traversal', Lens', lens) import Control.Monad.RWS.Strict+import Control.Monad.Reader import Control.Monad.Writer import qualified Data.Aeson as A import Data.Char@@ -38,6 +39,7 @@ import qualified Data.ListLike as L import qualified Data.ListLike.String as L import qualified Data.Map.Strict as M+import Data.Maybe import Data.Ord import qualified Data.Set as S import qualified Data.Text as T@@ -49,8 +51,8 @@ import Data.Time.Format import Data.Traversable (traverse) import qualified Data.Vector as V-import Hledger.Data hiding (at) import Hledger (textstrip)+import Hledger.Data hiding (at) import Hledger.Query import Hledger.Read import Hledger.Reports (defreportopts)@@ -106,7 +108,7 @@ -> String -> Either ParseError [(AccountName,String)] dbacl_parse accounts = fmap conv . parse (dbacl_parser sorted) ""- where conv = map (liftM2 (,) fst (L.unwords . snd))+ where conv = fmap $ second L.unwords sorted = sortBy (flip $ comparing T.length) $ accounts dbacl_parser :: [AccountName] -> Parsec String () [(AccountName, [String])]@@ -141,10 +143,12 @@ -- -> IO Journal saveChanges :: (MonadReader (Options User config env) m, MonadIO m)- => (Journal -> (Journal, Integer))+ => Maybe Journal+ -- this journal will be also changed and then returned+ -> (Journal -> (Journal, Integer)) -- ^ modifier, returning number of changed -> m Journal-saveChanges change = do+saveChanges journal change = do journalPath <- absolute =<< readLedger imported liftIO $ do ej <- readJournalFile Nothing Nothing False -- ignore balance assertions@@ -157,7 +161,12 @@ else do let res = showTransactions j writeFile journalPath res putStrLn $ "\n"++ show n ++" Transactions were changed"- return j+ return $ maybe j (\j -> + let (j2, m) = change j+ in if (n == m) then j2+ else error $ printf+ "Error 123, see source code. Solution: Use a proper database instead of a file. read: %d passed: %d" n m+ ) journal mixed' :: Amount -> MixedAmount mixed' = mixed . (:[])@@ -240,11 +249,10 @@ injectSource :: ImportTag -> Source -> Transaction -> Transaction injectSource tag source t = t- {tpostings = [ p1- , p2{pcomment =- commentPrefix tag <> TL.toStrict (json source)- }]}- where [p1,p2] = tpostings t+ {tpostings = reverse $ p1{pcomment =+ commentPrefix tag <> TL.toStrict (json source)+ } : rest}+ where (p1 : rest) = reverse $ tpostings t -- instance MonadReader (Options user Config env) m => ReaderM user env m @@ -261,8 +269,12 @@ -- http://hackage.haskell.org/package/cassava-0.4.1.0/docs/Data-Csv.html#t:NamedRecord -- parseCsv :: CSV.FromField a => String -> V.Vector (HM.HashMap B.ByteString a) -type MyRecord = (HM.HashMap T.Text T.Text)+type MyRecord = HM.HashMap T.Text T.Text +stripCsv :: ([T.Text], [MyRecord]) -> ([T.Text], [MyRecord])+stripCsv = fmap textstrip ***+ fmap (HM.fromList . fmap (textstrip *** textstrip ) . HM.toList)+ parseCsv :: Char -- ^ separator -> TL.Text -> ([T.Text], [MyRecord]) parseCsv sep = either error ((fmap T.decodeUtf8 . V.toList)@@ -271,10 +283,24 @@ { decDelimiter = fromIntegral $ ord sep } . encodeUtf8 -getCsvConcat- :: [T.Text] -> MyRecord -> T.Text-getCsvConcat x record = L.unwords $ flip getCsv record <$> x+getCsvCreditDebit :: T.Text -> T.Text -> MyRecord -> T.Text+getCsvCreditDebit creditColumn debitColumn record =+ if T.any isDigit creditValue + then "-" <> creditValue + else debitValue where+ creditValue = getCsv creditColumn record+ debitValue = getCsv debitColumn record +getCsvConcat :: [T.Text] -> MyRecord -> T.Text+getCsvConcat fields record = L.unwords $ flip getCsv record <$> fields+ +getCsvConcatDescription+ :: env -> [Description env] -> MyRecord -> T.Text+getCsvConcatDescription env x record = L.unwords $ g <$> x+ where g (Field f) = getCsv f record+ g (Const t) = t+ g (Read f) = f env+ getCsv :: T.Text -> MyRecord -> T.Text getCsv c x = lookupErrD (show (HM.keys x)) HM.lookup c x @@ -287,7 +313,8 @@ ,ieSource :: s -- ^ source to check for duplicates and for Bayesian matching } deriving Show -type ImportedEntry = ImportedEntry' (AccountId, T.Text) Source+type ImportedEntry = ImportedEntry'+ [(AccountId, T.Text, Maybe T.Text, Bool)] Source -- ^ postings of [acount,amount]: only ImportedEntry with one -- posting is currently implemented in the statists functionality of -- Add.hs (See PROBLEM1) as well in the duplicates algorithm in 'addNew'@@ -319,29 +346,47 @@ windoof = Just $ \h -> hSetEncoding h latin1 >> hSetNewlineMode h universalNewlineMode +parseDate :: String -> T.Text -> Day+parseDate format = parseTimeOrError True defaultTimeLocale format . T.unpack -parseDatum :: T.Text -> Day-parseDatum = parseTimeOrError True defaultTimeLocale "%d.%m.%Y" . T.unpack+parseDateM :: Monad m => String -> T.Text -> m Day+parseDateM format = parseTimeM True defaultTimeLocale format . T.unpack +parseDateDE = parseDate "%d.%m.%Y"+parseDateUS = parseDate "%m/%d/%Y"+ -- | retrieval function type Getter a = MyRecord -> a -data CsvImport a = CSV+data CsvPostingImport = CsvPosting+ { cAccount :: Getter T.Text+ , cAmount :: Getter T.Text+ , cSuffix :: Maybe (Getter T.Text)+ , cNegate :: Getter Bool+ -- ^ Amount parsable by 'mamoumtp\''+ }++data CsvImport env = CSV { cFilter :: MyRecord -> Bool -- ^ should this csv line be processed?- , cAmount :: Getter T.Text- -- ^ Amount parsable by 'mamoumtp\'' , cDate :: Getter Day+ , cStrip :: Bool , cVDate :: Getter (Maybe Day)- , cBank :: a -> Getter T.Text- , cAccount :: a -> Getter T.Text+ , cBank :: env -> Getter T.Text , cHeader :: [T.Text] , cBayes :: [T.Text]- , cDescription :: [T.Text]+ , cDescription :: [Description env] , cVersion :: Version , cSeparator :: Char+ , cPostings :: [env -> CsvPostingImport] } +data Description env = Field T.Text | Const T.Text | Read (env -> T.Text)++toField (Field t) = Just t+toField _ = Nothing++ data CheckedCsvImport a = UnsafeCSV { cRaw :: CsvImport a } -- deriving (Show) @@ -351,8 +396,8 @@ toVersionedCSV format headers = sequence $ (,) format $ fromListUnique $ (cVersion . cRaw &&& id) . checkRawCSV format <$> headers -type VersionedCSV a = forall m. MonadError Msg m- => m (SFormat DefaultVersion, M.Map Version (CheckedCsvImport a))+type VersionedCSV env = forall m. MonadError Msg m+ => m (SFormat DefaultVersion, M.Map Version (CheckedCsvImport env)) -- ^ (format with default version, _) data DefaultVersion = DefaultVersion { fromDefaultVersion :: Version }@@ -364,7 +409,8 @@ ("format '%s', version '%s': The configured header misses the following " ++ "fields required for Bayes or Description:\n%s") (fName format) (cVersion rh) $ unlines $ uncurry (printf "%s: %s") <$> missing- where [head, bayes, desc] = S.fromList . ($rh) <$> [cHeader, cBayes, cDescription]+ where [head, bayes, desc] = S.fromList . ($rh) <$>+ [cHeader, cBayes, mapMaybe toField . cDescription] missing = concatMap (uncurry zip <&> repeat *** (fmap T.unpack . toList . flip S.difference head)) [("cBayes", bayes), ("cDescription", desc)] :: [(String, String)]@@ -405,3 +451,18 @@ text' :: T.Text -> P.Box text' = P.text . T.unpack++loadJournal+ :: (MonadError Msg m, MonadIO m) =>+ [Ledgers -> Maybe FilePath]+ -> Options User config env -> m Journal+loadJournal journals options = do+ liftIO $ printf "(Reading journal from \n%s)\n...\n\n"+ $ intercalateL "\n" $ show <$> jfiles+ journal <- liftIO $+ -- to conquer problems with the `instance Monoid Journal`+ right mconcat' . sequence <$> mapM (readJournalFile Nothing Nothing False) jfiles+ either (throwError . T.pack) return journal+ where jfiles = runReader (catMaybes <$> mapM (mapM absolute <=< readLedger)+ journals) options+ jfiles :: [FilePath]
src/Buchhaltung/Import.hs view
@@ -29,24 +29,24 @@ :: (MonadError Msg m, MonadReader (Options User Config env) m) => T.Text -- ^ current time string -> ImportedEntry -> m FilledEntry-fillTxn datetime e@(ImportedEntry t (accId, am) source) = do+fillTxn datetime e@(ImportedEntry t postings source) = do tag <- askTag todo <- readConfig cTodoAccount- acc <- lookupErrM "Account not configured" M.lookup accId- =<< askAccountMap- let tx = injectSource tag source $ + postings' <- mapM toPosting postings+ let amount = sum $ pamount <$> postings'+ tx = injectSource tag source $ t{tcomment = "generated by 'buchhaltung' " <> datetime <> com (tcomment t)- ,tpostings =- [ nullposting{paccount= acc- ,pamount = amount }- , nullposting{paccount= todo <> ":" <>- todoAcc (isNegativeMixedAmount amount)- ,pamount = missingmixedamt }- -- leaves amount missing. (alternative: use- -- balanceTransaction Nothing)- ]}- amount = mamountp' $ T.unpack am+ ,tpostings = postings' +++ if isZeroMixedAmount amount then []+ else+ [ nullposting+ {paccount= todo <> ":" <> todoAcc+ (isNegativeMixedAmount amount)+ ,pamount = missingmixedamt }+ -- leaves amount missing. (alternative: use+ -- balanceTransaction Nothing)+ ]} todoAcc Nothing = "Mixed" todoAcc (Just False) = "Negative" todoAcc (Just True) = "Positive"@@ -57,6 +57,14 @@ where com "" = "" com b = " (" <> b <> ")"+ toPosting (accId, am, suff, negateQ) = do+ acc <- lookupErrM "Account not configured" M.lookup accId+ =<< askAccountMap+ return nullposting{paccount= acc <> maybe "" (":" <>) suff+ ,pamount = (if negateQ+ then Mixed . fmap negate . amounts else id)+ $ mamountp' $ T.unpack am }+ -- use this to debug amount parsing: mamountp' -- | read entries from handle linewise, process and add to ledger@@ -72,7 +80,7 @@ journalPath datetime <- liftIO $ fshow <$> getZonedTime entries <- mapM (fillTxn datetime) =<< conv text - newTxns <- addNew entries oldJ+ newTxns <- addNewEntriesToJournal entries oldJ liftIO $ hPutStrLn stderr $ printf "found %d new of %d total transactions" (length newTxns - length (jtxns oldJ)) $ length entries comp <- dateAmountSource <$> askTag
src/Buchhaltung/Importers.hs view
@@ -8,7 +8,13 @@ ( paypalImporter , aqbankingImporter- , comdirectVisaImporter + , comdirectVisaImporter+ , monefyImporter+ , natwestIntlImporter+ , barclaysUkImporter+ , revolutImporter+ , barclaycardusImporter+ , pncbankImporter , module Buchhaltung.Import , getBayesFields )@@ -17,7 +23,9 @@ import Buchhaltung.Common import Buchhaltung.Import import Control.Arrow+import Control.Monad.Cont import Control.Monad.RWS.Strict+import Data.Foldable import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import Data.List@@ -31,11 +39,15 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import Data.Time.Calendar+import Debug.Trace import Formatting (sformat, (%), shown) import qualified Formatting.ShortFormatters as F+import Safe as S import Text.Parsec import qualified Text.ParserCombinators.Parsec as C import Text.Printf+import qualified Text.Regex.TDFA as R+import Text.Regex.TDFA.Text () -- * CSV @@ -52,31 +64,41 @@ (printf "Version is not defined for format '%s%'" $ fName format) M.lookup (fromMaybe (fromDefaultVersion $ fVersion format) v) map --- csvImport--- :: MonadError Msg m--- => CsvImport--- -> T.Text -> m [ImportedEntry]-csvImport- :: (MonadError Msg m- ,MonadReader (Options user config (a, Maybe Version)) m)- => VersionedCSV a -> T.Text -> m [ImportedEntry]-csvImport versionedCsv csv = do+-- | Data type for preprocessing and meta-data extraction of CSV files+type Preprocessor env1 env2 = forall m. MonadError Msg m+ => (T.Text, env1) -> m (T.Text, env2)++processLines :: ([T.Text] -> [T.Text]) -> Preprocessor env env+processLines f = return . (first $ T.unlines . f . T.lines)++csvImport = csvImportPreprocessed return++csvImportPreprocessed :: Preprocessor env1 env2+ -> VersionedCSV env2+ -> T.Text+ -> CommonM (env1, Maybe Version) [ImportedEntry]+csvImportPreprocessed pp versionedCsv csv1 = do (env, version) <- reader oEnv+ (csv2, env2) <- pp (csv1, env) (form, g@CSV{cHeader=expected, cDescription = desc, cVersion = version }) <- headerInfo versionedCsv version let toEntry x = ImportedEntry { ieT = genTrans date (vdate =<< cVDate g x)- (getCsvConcat desc x)+ (getCsvConcatDescription env2 desc x) , ieSource = fromMapToSource form x- , iePostings = (AccountId (cBank g env $ x) (cAccount g env $ x)- , cAmount g x)+ , iePostings = + (\p -> (AccountId (cBank g env2 x) (cAccount p x)+ , cAmount p x+ , ($ x) <$> cSuffix p+ , cNegate p x)) . ($ env2) <$> cPostings g } where vdate vd = if date == vd then Nothing else Just vd date = cDate g x- (header, rows) = parseCsv (cSeparator g) . TL.fromStrict $ csv+ (header, rows) = (if cStrip g then stripCsv else id) $+ parseCsv (cSeparator g) . TL.fromStrict $ csv2 if expected == header then return $ fmap toEntry $ filter (cFilter g) rows else throwError $ L.unlines@@ -100,12 +122,18 @@ aqbankingImport = toVersionedCSV (SFormat "aqBanking" $ DefaultVersion "4") [CSV { cFilter = const True- , cAmount = getCsvConcat [ "value_value"- , "value_currency"] , cDate = readdate . getCsv "date"+ , cStrip = False , cVDate = Just . readdate . getCsv "valutadate" , cBank = const $ getCsv "localBankCode"- , cAccount = const $ getCsv "localAccountNumber"+ , cPostings =+ [ const CsvPosting+ { cAccount = getCsv "localAccountNumber"+ , cAmount = getCsvConcat [ "value_value"+ , "value_currency"]+ , cSuffix = Nothing+ , cNegate = const False+ }] , cSeparator = ';' , cVersion= "4" , cHeader = ["transactionId"@@ -140,7 +168,7 @@ ,"category5" ,"category6" ,"category7"]- , cDescription = desc+ , cDescription = Field <$> desc , cBayes = ["remoteBankCode","remoteAccountNumber"] ++ desc }]@@ -148,7 +176,7 @@ [ ("remoteName", ["1"]) , ("purpose", fshow <$> [1..11]) , ("category", fshow <$> [1..7])]- + -- * Postbank Germany Kontoauszüge (from PDF with @pdftotext@) -- fromPostbankPDF2 :: T.Text -> [ImportedEntry]@@ -156,7 +184,7 @@ -- where y a b = head b=="" -- f :: [T.Text] -> ImportedEntry -- f l@(dat:(_:(des:(am:rest)))) = ImportedEntry{--- ieT = genTrans (parseDatum $ dat <> "2014") Nothing (L.unwords s)+-- ieT = genTrans (parseDateDE $ dat <> "2014") Nothing (L.unwords s) -- ,ieSource = v $ T.intercalate (v $ T.singleton hbci_sep) l -- ,iePostings=("Aktiva:Konten:Giro", a <> " EUR") -- }@@ -171,7 +199,7 @@ -- where y a b = head b=="" -- f :: [T.Text] -> ImportedEntry -- f l@(dat:(des:(am:rest))) = ImportedEntry{--- ieT = genTrans (parseDatum $ dat <> "2013") Nothing (L.unwords s)+-- ieT = genTrans (parseDateDE $ dat <> "2013") Nothing (L.unwords s) -- ,ieSource = v $ T.intercalate (v $ T.singleton hbci_sep) l -- ,iePostings=("Aktiva:Konten:Giro", a <> " EUR") -- }@@ -279,21 +307,387 @@ -- transformation = map snd mapping' csv_header = undefined +-- * PNC Bank USA transaction logs++pncbankImporter :: Importer T.Text+pncbankImporter = Importer windoof $ csvImport pncbank++pncbank :: VersionedCSV T.Text+pncbank = toVersionedCSV (SFormat "pncbank" $ DefaultVersion "May 2017")+ [CSV+ { cFilter =(/= "") . getCsv "Date"+ , cDate = parseDateUS . getCsv "Date"+ , cStrip = False+ , cVDate = Just . parseDateUS . getCsv "Date"+ , cBank = const $ const "PNC Bank"+ , cPostings =+ [ \env -> CsvPosting+ { cAccount = const env+ , cAmount = textstrip . (T.replace "$" "") .+ (T.replace "," "") . (<> " USD") .+ getCsvCreditDebit "Withdrawals" "Deposits"+ , cSuffix = Nothing+ , cNegate = const False+ }]+ , cSeparator = ','+ , cHeader = ["Date"+ ,"Description"+ ,"Withdrawals"+ ,"Deposits"+ ,"Balance"+ ]+ , cDescription = Field <$> desc+ , cBayes = desc+ , cVersion = "May 2017"+ }+ ]+ where desc = ["Description"]+++-- * Barclaycard US transaction logs++barclaycardusImporter :: Importer ()+barclaycardusImporter = Importer windoof $ csvImportPreprocessed barclaycardPreprocessor barclaycardus++barclaycardPreprocessor :: Preprocessor () AccountId+barclaycardPreprocessor (wholeFile, _) =+ maybe e (return . (,) (T.unlines body) . AccountId bank . T.dropWhile (== 'X'))+ $ T.stripPrefix accountPrefix accountLine+ where+ (bank : accountLine : _ : _ : body) = T.lines wholeFile+ accountPrefix = "Account Number: "+ e = throwError $+ "Expected second line of file to begin with prefix " `T.append` accountPrefix++barclaycardus :: VersionedCSV AccountId+barclaycardus = toVersionedCSV (SFormat "barclaycard" $ DefaultVersion "May 2017")+ [CSV+ { cFilter =(/= "") . getCsv "Transaction Date"+ , cDate = parseDateUS . getCsv "Transaction Date"+ , cStrip = False+ , cVDate = Just . parseDateUS . getCsv "Transaction Date"+ , cBank = const . aBank+ , cPostings =+ [ \env -> CsvPosting+ { cAccount = const $ aAccount env+ , cAmount = textstrip . (<> " USD") . getCsv "Amount"+ , cSuffix = Nothing+ , cNegate = const False+ }]+ , cSeparator = ','+ , cHeader = ["Transaction Date"+ ,"Description"+ ,"Category"+ ,"Amount"+ ]+ , cDescription = Field <$> desc+ , cBayes = "Category" : desc+ , cVersion = "May 2017"+ }+ ]+ where desc = ["Description"]++-- * Revolut Csv+ +revolutImporter :: Importer (RevolutSettings ())+revolutImporter = Importer Nothing $ csvImportPreprocessed extractCurrency revolut++extractCurrency :: Preprocessor (RevolutSettings ()) (RevolutSettings T.Text)+extractCurrency (text, env) = do+ cur <- maybe (throwError $ "Cannot find currency (regular expression: "+ <> T.pack (show currencyColumn) <> " in header:\n" <> header)+ (return . fst) $ (flip atMay 1 . toList =<<)+ $ listToMaybe $ currencyRegex header+ return (T.unlines $ T.replace (" (" <> cur <> ")") "" header:rest+ , const cur <$> env)+ where header:rest = T.lines text ++currencyRegex = R.matchAllText (R.makeRegex currencyColumn :: R.Regex)++currencyColumn = "\\bPaid Out \\(([^)]+)\\)" :: T.Text + ++revolut :: VersionedCSV (RevolutSettings T.Text)+revolut = toVersionedCSV (SFormat "revolut" $ DefaultVersion "2017")+ [ CSV { cFilter = (/= "") . getCsv "Completed Date"+ , cDate = (\x -> headNote ("no parse of " <> T.unpack x) $ mapMaybe+ (\format -> parseDateM format x) ["%b %e, %Y", "%e %b %Y"]) . getCsv "Completed Date"+ , cStrip = True+ , cVDate = const Nothing+ , cBank = const $ const "Revolut"+ , cPostings =+ [ \env -> CsvPosting+ { cAccount = const $ revolutUser env+ , cAmount = (<> revolutCurrency env) . getCsvCreditDebit "Paid Out" "Paid In"+ , cSuffix = Just $ const $ revolutCurrency env+ , cNegate = const False+ }+ ]+ , cSeparator = ';'+ , cHeader = ["Completed Date"+ ,"Reference"+ ,"Paid Out"+ ,"Paid In"+ ,"Exchange Out"+ ,"Exchange In"+ ,"Balance"+ ,"Category"+ ]+ , cDescription = [Const "Revolut"+ , Field "Reference"+ , Const ", Category"+ , Field "Category" ]+ , cBayes = ["Reference", "Category" ]+ , cVersion = "2017"+ }+ ]+ +-- remove currency signs and append corresponding currency name+normalizeCurrency :: T.Text -> T.Text+normalizeCurrency text = (`runCont` id) $ callCC $ \exit -> do+ let g (symbol, name) text1 = unless (T.length text2 == L.length text1)+ $ exit $ T.replace " " "" text2 <> " " <> name+ where text2 = T.replace symbol "" text1+ mapM_ (\x -> g x text) currencySymbols+ return text++currencySymbols = [ ("$", "USD")+ , ("€", "EUR")+ , ("£", "GBP") ]+ +-- * Monefy Csv+ +monefyImporter :: Importer MonefySettings+monefyImporter = Importer Nothing $ csvImportPreprocessed unambiguousHeader monefy++-- | replace the header by one with unique column names (currency2)+unambiguousHeader :: Preprocessor env env+unambiguousHeader = processLines $ (h2:) . tail+ where h2 = "date,account,category,amount,currency,converted amount,currency2,description"+ -- (T.replace "ü" "ue" <$> rest)++monefy :: VersionedCSV MonefySettings+monefy = toVersionedCSV (SFormat "monefy" $ DefaultVersion "2017")+ [CSV+ { cFilter = const True+ , cStrip = False+ , cDate = parseDate "%d/%m/%Y" . getCsv "date"+ , cVDate = const Nothing+ , cBank = const . monefyInstallation+ , cPostings =+ [ const CsvPosting+ { cAccount = getCsv "account"+ , cAmount = amt+ , cSuffix = Nothing+ , cNegate = const False+ }+ , \env -> let suf = monefyCategorySuffix env in CsvPosting + { cAccount = if suf then const "Monefy Category Account"+ else getCsv "category"+ , cAmount = amt+ , cSuffix = if suf then Just $ getCsv "category"+ else Nothing+ , cNegate = const True+ }+ ]+ , cSeparator = ','+ , cHeader = ["date"+ ,"account"+ ,"category"+ ,"amount"+ ,"currency"+ ,"converted amount"+ ,"currency2"+ ,"description"+ ]+ , cDescription = [Const "Monefy"+ , Read monefyInstallation+ , Field "description"]+ , cBayes = []+ , cVersion = "2017"+ }+ ]+ where amt = (\a b -> textstrip $ T.replace "," "" a <> " " <> b)+ <$> getCsv "amount" <*> getCsv "currency"++-- * BarclaysUk International CSV export++barclaysUkImporter :: Importer ()+barclaysUkImporter = Importer Nothing $ csvImport barclaysUk+ +barclaysUk :: VersionedCSV ()+barclaysUk = toVersionedCSV (SFormat "barclaysUk" $ DefaultVersion "2017")+ [CSV+ { cFilter = (/= "") . getCsv "Date"+ , cStrip = False+ , cDate = parseDate "%d/%m/%Y" . getCsv "Date"+ , cVDate = const Nothing+ , cBank = const $ fst <$> accountBank+ , cPostings =+ [ const CsvPosting+ { cAccount = snd <$> accountBank+ , cAmount = (<> " GBP") <$> getCsv "Amount"+ , cSuffix = Nothing+ , cNegate = const False+ }+ ]+ , cSeparator = ','+ , cHeader = ["Number"+ ,"Date"+ ,"Account"+ ,"Amount"+ ,"Subcategory"+ ,"Memo"+ ]+ , cDescription = Field <$> desc + , cBayes = desc+ , cVersion = "2017"+ }+ ]+ where accountBank = (g . T.splitOn " ") . getCsv "Account"+ g [acc,bank] = (acc, bank)+ g _ = error "Expected 'Account' to be of the format \"{sort code} {account number}\""+ desc = ["Subcategory", "Memo"]++-- * Natwest International CSV export++natwestIntlImporter :: Importer ()+natwestIntlImporter = Importer Nothing $ csvImportPreprocessed (processLines $ tail) natwestIntl+ +natwestIntl :: VersionedCSV ()+natwestIntl = toVersionedCSV (SFormat "natwestIntl" $ DefaultVersion "2017")+ [CSV+ { cFilter = (/= "") . getCsv "Date"+ , cStrip = False+ , cDate = parseDate "%d/%m/%Y" . getCsv "Date"+ , cVDate = const Nothing+ , cBank = const $ fst <$> accountBank+ , cPostings =+ [ const CsvPosting+ { cAccount = snd <$> accountBank+ , cAmount = (<> " GBP") <$> getCsv " Value"+ , cSuffix = Nothing+ , cNegate = const False+ }+ ]+ , cSeparator = ','+ , cHeader = ["Date"+ ," Type"+ ," Description"+ ," Value"+ ," Balance"+ ," Account Name"+ ," Account Number"+ ]+ , cDescription = [Field " Description"+ ,Const ", Type"+ ,Field " Type"]+ , cBayes = [" Description"+ ," Type"]+ , cVersion = "2017"+ }+ ]+ where accountBank = (g . T.splitOn "-" . T.tail ) . getCsv " Account Number"+ g [acc,bank] = (acc, bank)+ g _ = error "Expected ' Account Number' to be of the format \"'{sort code}-{account number}\""++-- natwestTransactionType = +-- [("103" ,"MT103 Payment")+-- ,("ACI" ,"Interest on Account Balance")+-- ,("ADV" ,"Separate Advice")+-- ,("AMD" ,"Amendments History")+-- ,("ATM" ,"Cash Withdrawal")+-- ,("BAC" ,"Automated Credit")+-- ,("BAE" ,"Branch Account Entry")+-- ,("BCO" ,"Non Market Close Out")+-- ,("BGC" ,"Bank Giro Credit")+-- ,("BGT" ,"Guarantees")+-- ,("BLN" ,"Bankline Charges")+-- ,("BOE" ,"Bill of Exchange")+-- ,("BSP" ,"Branch single payment")+-- ,("C/R" ,"Credit")+-- ,("C/L" ,"Automated teller machine cash withdrawal")+-- ,("CAE" ,"Cheque Collection")+-- ,("CCB" ,"Cheque Collection")+-- ,("CDM" ,"Cash and Deposit Machine")+-- ,("CHG" ,"Charges")+-- ,("CHP" ,"CHAPS Transfer (NatWest only)")+-- ,("CHQ" ,"Cheque")+-- ,("CNA" ,"Clean Cheque Neg")+-- ,("CND" ,"Cheque Negotiation")+-- ,("COM" ,"Commission")+-- ,("CRD" ,"Card Payment or Cash")+-- ,("D/D" ,"Direct Debit")+-- ,("D/R" ,"Debit")+-- ,("DCR" ,"Documentary Credit")+-- ,("DFT" ,"Foreign Draft")+-- ,("DIV" ,"Dividend")+-- ,("DPC" ,"Digital Banking Payment")+-- ,("EBP" ,"Electronic Payment")+-- ,("FPAY" ,"Faster Payment - Future Dated (Appears on statements as EBP)")+-- ,("GSD" ,"Gov Stamp Duty")+-- ,("IBP" ,"Inter Branch Payment")+-- ,("ICP" ,"Inward Currency Payment")+-- ,("INT" ,"Interest")+-- ,("INV" ,"Investment")+-- ,("IPAY" ,"Faster Payment -Immediate (Appears on statements as EBP)")+-- ,("ISP" ,"Inward Sterling Payment")+-- ,("ITL" ,"International Transfer & Treasury Settlements (and RBS CHAPS Payments)")+-- ,("ITM" ,"Incoming CHAPS")+-- ,("LON" ,"New Loan")+-- ,("LST" ,"Supplementary List")+-- ,("LVP" ,"Low Value Payment")+-- ,("MEC" ,"Export Credits")+-- ,("MFD" ,"Maturing Fwd Deal")+-- ,("MGT" ,"Bonds & Guarantees")+-- ,("MIB" ,"Inward Bills")+-- ,("MIC" ,"Import Credits")+-- ,("MKD" ,"Market Deal")+-- ,("MOB" ,"Outward Bills")+-- ,("MSC" ,"Miscellaneous Entry")+-- ,("NDC" ,"No Dividend Counterfoil")+-- ,("NPAY" ,"Faster Payment - Next Day (Appears on statement as EBP)")+-- ,("POS" ,"Maestro Transaction")+-- ,("RTF" ,"Relay Transfer")+-- ,("S/O" ,"Standing Order")+-- ,("SBT" ,"Funds Transfer")+-- ,("SCR" ,"Sundry Credit Item")+-- ,("SDE" ,"Urgent Euro Transfer")+-- ,("SDR" ,"Sundry Debit Item")+-- ,("STF" ,"Manually Keyed Standard Transfer")+-- ,("STL" ,"Settlement")+-- ,("TFP" ,"Trade Finance Product")+-- ,("TFR" ,"Transfer")+-- ,("TRF" ,"International Payment (NatWest only)")+-- ,("TLR" ,"Card Payment or Cash")+-- ,("TEL" ," Telephone Banking transaction")+-- ,("TSU" ,"Telephone Banking")+-- ,("U/D" ,"Unpaid Direct Debit")+-- ,("UTF" ,"Urgent Transfer")+-- ,("WSF" ,"Foreign Exchange Deal")+-- ,("WSM" ,"Money Market Deal")]+ -- * Comdirect Visa Statements comdirectVisaImporter :: Importer T.Text comdirectVisaImporter = Importer windoof $ csvImport comdirectVisa- + comdirectVisa :: VersionedCSV T.Text comdirectVisa = toVersionedCSV (SFormat "visa" $ DefaultVersion "manuell") [CSV- { cFilter =(/= "") . getCsv "Buchungstag" - , cAmount = textstrip . comma . (<> " EUR") . getCsv "Ausgang"- , cDate = parseDatum . getCsv "Buchungstag"- , cVDate = Just . parseDatum . getCsv "Valuta"+ { cFilter =(/= "") . getCsv "Buchungstag"+ , cStrip = False+ , cDate = parseDateDE . getCsv "Buchungstag"+ , cVDate = Just . parseDateDE . getCsv "Valuta" , cBank = const- , cAccount = const $ const "Visa"+ , cPostings =+ [ const CsvPosting+ { cAccount = const "Visa"+ , cAmount = textstrip . comma . (<> " EUR") . getCsv "Ausgang"+ , cSuffix = Nothing+ , cNegate = const False+ }] , cSeparator = ',' , cHeader = ["Buchungstag" ,"Vorgang"@@ -303,18 +697,24 @@ ,"Referenz" ,"Buchungstext2" ]- , cDescription = desc+ , cDescription = Field <$> desc , cBayes = desc , cVersion = "manuell" -- hand extracted from @pdftotext -layout@ } , CSV- { cFilter =(/= "") . getCsv "Buchungstag" - , cAmount = comma . (<> " EUR") . getCsv "Umsatz in EUR"- , cDate = parseDatum . getCsv "Buchungstag"- , cVDate = Just . parseDatum . getCsv "Umsatztag"+ { cFilter =(/= "") . getCsv "Buchungstag"+ , cDate = parseDateDE . getCsv "Buchungstag"+ , cStrip = False+ , cVDate = Just . parseDateDE . getCsv "Umsatztag" , cBank = const- , cAccount = const $ const "Visa"+ , cPostings =+ [ const CsvPosting+ { cAccount = const "Visa"+ , cAmount = comma . (<> " EUR") . getCsv "Umsatz in EUR"+ , cSuffix = Nothing+ , cNegate = const False+ }] , cSeparator = ',' , cHeader = ["Buchungstag" ,"Umsatztag"@@ -322,7 +722,7 @@ ,"Referenz" ,"Buchungstext" ,"Umsatz in EUR"]- , cDescription = desc2+ , cDescription = Field <$> desc2 , cBayes = desc2 , cVersion = "export" }@@ -334,7 +734,7 @@ desc2 = ["Vorgang" ,"Buchungstext" ]- + -- * Paypal (German) -- -- understands exports under the following setting:@@ -347,23 +747,112 @@ paypalImporter = Importer windoof $ csvImport paypalImport paypalImport :: VersionedCSV T.Text-paypalImport = +paypalImport = let base = CSV { cFilter = (/= "Storniert") . getCsv " Status"- , cAmount = comma . getCsvConcat [ " Netto"- , " Währung"]- , cDate = parseDatum . getCsv "Datum"+ , cDate = parseDateDE . getCsv "Datum"+ , cStrip = False , cVDate = const Nothing , cBank = const $ const "Paypal"- , cAccount = const+ , cPostings =+ [ \env -> CsvPosting+ { cAccount = const env+ , cAmount = comma . getCsvConcat [ " Netto"+ , " Währung"]+ , cSuffix = Nothing+ , cNegate = const False+ }] , cSeparator = ',' , cVersion = "undefined" , cHeader = [] , cBayes = ["undefined"]- , cDescription = ["undefined"]- } in toVersionedCSV (SFormat "paypal" $ DefaultVersion "2016")- [base { cVersion = "2016"+ , cDescription = [Field "undefined"]+ }+ desc = Field <$> [" Name"+ ," Verwendungszweck"+ ," Art"+ ," Zeit"]+ desc2 = Field <$> [" Name"+ ," Artikelbezeichnung"+ ," Typ"+ ," Zeit"]+ in toVersionedCSV (SFormat "paypal" $ DefaultVersion "2017")+ [base { cVersion = "2017" , cHeader = ["Datum"+ ," Zeit" + ," Zeitzone" + ," Name" + ," Typ" + ," Status" + ," Betreff" + ," W\195\164hrung" + ," Brutto" + ," Geb\195\188hr" + ," Netto" + ," Hinweis" + ," Von E-Mail-Adresse" + ," An E-Mail-Adresse" + ," Transactionscode" + ," Zahlungsart" + ,"Status der Gegenpartei" + ," Lieferadresse" + ," Adressstatus" + ," Artikelbezeichnung" + ," Artikelnummer" + ," Betrag f\195\188r Versandkosten" + ," Versicherungsbetrag" + ," Umsatzsteuer" + ," Trinkgeld" + ," Rabatt" + ," Mitgliedsname des Verk\195\164ufers" + ," Option 1 - Name" + ," Option 1 - Wert" + ," Option 2 - Name" + ," Option 2 - Wert" + ," Auktions-Site" + ," K\195\164ufer-ID" + ," Artikel-URL" + ," Angebotsende" + ," Txn-Referenzkennung" + ," Rechnungsnummer" + ," Abonnementnummer" + ," Individuelle Nummer" + ," Belegnummer" + ," Guthaben" + ," Adresszeile 1" + ," Zus\195\164tzliche Angaben" + ," Ort" + ," Staat/Provinz/Region/Landkreis/Territorium/Pr\195\164fektur/Republik" + ," PLZ" + ," Land" + ," Telefonnummer" + ," Auswirkung auf Guthaben" + ," "]+ , cBayes = [" Name"+ ," An E-Mail-Adresse"+ ," Von E-Mail-Adresse"+ ," Artikelbezeichnung"+ ," Typ"+ ," Status"+ ," K\195\164ufer-ID"+ , "Status der Gegenpartei"," Adressstatus"+ , " Option 1 - Name"+ , " Option 2 - Name"+ ," Auktions-Site"+ ," K\195\164ufer-ID"+ ," Artikel-URL"+ ," Adresszeile 1"+ ," Zus\195\164tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\195\164fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer"+ ]+ , cDescription = desc2+ }+ ,base { cVersion = "2016"+ , cHeader = ["Datum" ," Zeit" ," Zeitzone" ," Name"@@ -427,10 +916,7 @@ ," Land" ," Telefonnummer" ]- , cDescription = [" Name"- ," Artikelbezeichnung"- ," Typ"- ," Zeit"]+ , cDescription = desc2 } ,base { cVersion = "2014" , cHeader = ["Datum"@@ -497,10 +983,7 @@ ," Land" ," Telefonnummer der Kontaktperson" ]- , cDescription = [" Name"- ," Verwendungszweck"- ," Art"- ," Zeit"]+ , cDescription = desc } , base { cVersion = "2013" , cHeader = ["Datum"@@ -568,10 +1051,7 @@ ," Land" ," Telefonnummer der Kontaktperson" ]- , cDescription = [" Name"- ," Verwendungszweck"- ," Art"- ," Zeit"]+ , cDescription = desc }] -- * other stuff@@ -676,17 +1156,30 @@ => VersionedCSV a -> m (SFormat DefaultVersion, M.Map Version [T.Text]) toBayes = fmap (second $ fmap $ cBayes . cRaw)- ++-- create a map that associates each format with a map that associates+-- each version with a list of fields defaultFields :: MonadError Msg m => m (M.Map (SFormat ()) (M.Map Version [T.Text])) defaultFields = fromListUnique . fmap (first $ (() <$))- =<< sequence [toBayes paypalImport, toBayes aqbankingImport]+ =<< sequence [toBayes paypalImport+ ,toBayes aqbankingImport+ ,toBayes barclaycardus+ ,toBayes pncbank+ ,toBayes revolut+ ,toBayes natwestIntl+ ,toBayes barclaysUk+ ,toBayes monefy] +-- extract the values of all available bayes fields of a given+-- source. getBayesFields :: MonadError Msg m => Source -> m [T.Text] getBayesFields source = do+ -- extract the correct bayes fields that correspond to the source's+ -- format and version. fields <- lookupErrM "Version has to be configured" M.lookup (fVersion format) =<< lookupErrM "Format has to be configured" M.lookup
src/Buchhaltung/Match.hs view
@@ -35,7 +35,7 @@ import Text.Printf type MatchT m = RWST (FullOptions FilePath) ()- (S.Set AccountName, Zipper Update) (ErrorT m)+ (M.Map AccountName Bool, Zipper Update) (ErrorT m) -- ^ R: temporaray dbacl path -- -- W: Set of learned accounts@@ -49,7 +49,7 @@ where g (done, todos) = void $ runRWST (learn done >> mainLoop "") options- (S.fromList $ fst <$> done, differentiate todos) :: ErrorT IO ()+ (mempty, differentiate todos) :: ErrorT IO () -- | Apply the first matching 'Todo' updateAccountName :: Update -> Maybe (Transaction, Transaction)@@ -62,7 +62,7 @@ (\(x,z) -> [x,z]) . unzip . M.toList . sourceToMap mainLoop :: String -> MatchT IO ()-mainLoop i = do+mainLoop msg = do zip <- gets $ snd let tx = present zip liftIO $ do@@ -70,72 +70,83 @@ printf "Current Transaction: %d, Remaining: %d\n" (length $ past zip ) $ length $ future zip- putStr i+ putStr msg account <- myAskAccount =<< suggestAccount tx -- let- g "save" = void $ saveChanges $ changeTransaction+ next = modify (second fwd) >> mainLoop (fwdMsg zip)+ prev = modify (second back) >> mainLoop (backMsg zip)+ fwdMsg (LZ _ []) = "<< DONE! Use 'save' to exit >>\n\n"+ fwdMsg _ = ""+ backMsg (LZ (_ :| []) _) = "<< This is the first transaction >>\n\n"+ backMsg _ = ""+ g "save" = void $ saveChanges Nothing $ changeTransaction $ mapMaybe updateAccountName $ integrate zip- g "<" = prev zip- g ">" = next zip+ g "<" = prev+ g ">" = next g _ = do- modify $ first $ S.insert account learn [(account, return tx)]- modify $ second $ fwd . modifyPresent (fmap $ const $ Just account)- next zip+ modify $ second $ modifyPresent (fmap $ const $ Just account)+ next g account- where- next (LZ _ []) = mainLoop "<< DONE! Use 'save' to exit >>\n\n"- next z = modify (second $ const fwd z) >> mainLoop ""- prev (LZ (_ :| []) _) =- mainLoop "<< This is the first transaction >>\n\n"- prev z = modify (second $ const back z) >> mainLoop "" histfsuf :: String histfsuf = "learn" -data Default = Default { display :: T.Text, defAcc :: AccountName }+-- | Data type describing the suggested or 'default' account when+-- asking the user for account input+data Default = Default { prefixed :: T.Text, defAcc :: AccountName } suggestAccount :: Update -> MatchT IO (Maybe Default) suggestAccount tx = do- accs <- getAccountList+ accs <- getAccountList $ id args <- dbaclProcC <$> mapM tmp accs text <- bayesLine tx bin <- readConfig cDbaclExecutable let- g [] = return Nothing- g accounts = do- (code, output, _) <- liftIO $ readProcessWithExitCode bin args text+ g = if null accs || T.null text then return Nothing+ else do+ (code, output, _) <-+ liftIO $ readProcessWithExitCode bin args $ T.unpack text case code of ExitSuccess -> return Nothing ExitFailure x -> return $ Just $ Default info sa- where sa = accounts !! (x-1)+ where sa = accs !! (x-1) info :: T.Text info = either fshow (text . lookup sa) (dbacl_parse accs output) text Nothing = "failed\t\t" text (Just te) = "uncertainty: " <> T.pack te <> "\t"- maybe (g accs) (return . Just . Default "manual:\t\t\t") $ wInfo tx+ maybe g (return . Just . Default "manual:\t\t\t") $ wInfo tx -bayesLine :: Monad m => WithSource a -> MatchT m String-bayesLine w = T.unpack . T.unwords <$> getBayesFields (wSource w)+bayesLine :: Monad m => WithSource a -> MatchT m T.Text+bayesLine w = T.strip . T.unwords <$> getBayesFields (wSource w) learn :: [(AccountName, NonEmpty (WithSource a))] -> MatchT IO ()-learn pairs = liftIO . runConcurrently . mconcat =<< mapM learn' pairs+learn pairs = do+ accs <- liftIO . runConcurrently . sequenceA =<< mapM learn' pairs+ forM_ accs $ \(k,v) -> modify $ first $ M.insertWith const k v where learn' (name,txs) = do bin <- readConfig cDbaclExecutable- text <- L.unlines <$> mapM bayesLine (N.toList txs)+ text <- (L.unlines . filter (not . T.null)) <$>+ mapM bayesLine (N.toList txs) file <- tmp name- return $ Concurrently $ do- -- let text = if text'=="" then "\n" else text' PROBLEM-bayes_fields- L.putStrLn $ "Learning: " <> name- -- putStrLn $ "\n\n"++ (intercalate "\n\n" $ info <$> todos)- -- putStrLn text- out <- readProcess bin (dbaclProc file) text- appendFile (file <> "_raw" ) $ text <> "\n\n" <> out- L.putStrLn $ "Done: " <> name-+ let action = if T.null text then return (name, False)+ else do+ -- let text = if text'=="" then "\n" else text' PROBLEM-bayes_fields+ L.putStrLn $ "Learning: " <> name+ -- putStrLn $ "\n\n"++ (intercalate "\n\n" $ info <$> todos)+ -- putStrLn text+ let texts = T.unpack text+ (code, out, err) <- readProcessWithExitCode bin (dbaclProc file) texts+ appendFile (file <> "_raw" ) $ texts <> "\n\n" <>+ out <> "\n\nStd error:\n" <> err+ let success = code == ExitSuccess && null err + L.putStrLn $ if success then "Done: " <> name+ else "Failed: " <> name <> "\nwith Code "<> fshow code <> "\n\nAnd error:\n" <> T.pack err+ return (name, success)+ return $ Concurrently $ action accountCompletion :: [String] -> CompletionFunc IO accountCompletion cc = completeWord Nothing "" -- don't break words on whitespace, since account names@@ -146,32 +157,45 @@ type Update = WithSource (Maybe AccountName) -- | Group all transactions with source into those that already have--- an account and those that starting with 'cTodoAccount'+-- an account (ignoring those in 'ignoredAccountsOnMatch') and those+-- that start with 'cTodoAccount'+--+-- returns `Nothing` if there are no todo transactions groupByAccount- :: MonadReader (Options user Config env) m =>+ :: MonadReader (Options User Config env) m => Journal -> m (Maybe ( [(AccountName, NonEmpty (WithSource ()))]- , NonEmpty (WithSource (Maybe a))))+ , NonEmpty Update)) groupByAccount j = do+ ignored <- readUser ignoredAccountsOnMatch tag <- askTag todoFilt <- askTodoFilter let acc = paccount . wPosting f s = if todoFilt ac then Right $ fmap (const Nothing) <$> s else Left (ac, s) where ac = acc $ N.head s- return $ traverse (fmap S.sconcat . nonEmpty) $ partitionEithers $ fmap f+ return+ -- combine all transactions with different todo accounts+ $ traverse (fmap S.sconcat . nonEmpty)+ $ first (filter $ not . isIgnored ignored . fst)+ $ partitionEithers $ fmap f $ N.groupBy ((==) `on` acc) $ sortBy (comparing acc) $ rights $ extractSource tag <$> jtxns j myAskAccount :: Maybe Default -> MatchT IO AccountName-myAskAccount acc = getAccountList >>= \accs -> - liftIO $ askAccount accs (defAcc <$> acc) (Just histfsuf) prompt- where prompt = Right $ maybe "" showdef acc <> "\n[<, >, save, RET]:\t"- showdef (Default d a) = d <> (revAccount2 a) :: T.Text+myAskAccount acc = getAccountList (const True) >>= \accs -> do+ revAccount <- askReverseAccount+ let prompt = Right $ T.unlines+ [""+ ,maybe "" ((<> "\n\nHit 'Enter' to use the above account, or") . showdef) acc+ ,"enter one of the following: account name (in reverse notation), "<>+ "'<', '>' to navigate, or 'save'"]+ showdef (Default d a) = d <> (revAccount a) :: T.Text+ askAccount accs (defAcc <$> acc) (Just histfsuf) prompt -getAccountList :: Monad m => MatchT m [AccountName]-getAccountList = gets $ S.toList . fst+getAccountList :: Monad m => (Bool -> Bool) -> MatchT m [AccountName]+getAccountList f = gets $ M.keys . M.filter f . fst tmp :: Monad m => T.Text -> MatchT m FilePath tmp name = reader $ (</> T.unpack name) . oEnv
src/Buchhaltung/OptionParsers.hs view
@@ -23,7 +23,7 @@ env <- getEnvironment home <- try getHomeDirectory :: IO (Either SomeException FilePath) return $ info- ( helper *> (Options+ ( helper *> version *> (Options <$> userP <*> profile env home <*> subparser commands@@ -32,8 +32,11 @@ ) ) mempty +paragraph :: String -> D.Doc paragraph = foldr ((D.</>) . D.text) mempty . words +version = infoOption "buchhaltung, version 0.0.6" $ long "version" <> short 'v' <> help "Show version"+ userP :: Parser (Maybe Username) userP = optional $ (Username . T.pack) <&> strOption $ long "user" <> short 'u' <> metavar "USER"@@ -104,18 +107,22 @@ -- todo: pass through, that only sets env var and runs remaining args as "command args" - <> passThrough Commit "commit" (Just "c") (Just $ concat- ["run git commit in the dir of the user's mainLedger file and pass all "- ,"following arguments to git. "- ,"The Message will contain all AQBalances "- ,"and the Ledger balance sheet"])+ <> passThrough (Commit False) "commit" (Just "c") (commitMsg "ledger") + <> passThrough (Commit True) "commitHledger" (Just "ch") (commitMsg "hledger")+ <> passThrough Ledger "ledger" (Just "l") Nothing <> passThrough HLedger "hledger" (Just "hl") Nothing <> passThrough AQBanking "aqbanking" (Just "aq") Nothing +commitMsg x = (Just $ concat+ ["run git commit in the dir of the user's mainLedger file and pass all "+ ,"following arguments to git. "+ ,"The Message will contain all AQBalances "+ ,"and the ", x ," balance sheet"])+ passThrough :: ([String] -> Action) -> String -- ^ command@@ -139,6 +146,12 @@ <> commandGroup "Available FORMATS" <>+ command' "barclaycardus"+ (pure BarclaycardUs)+ (progDesc $ concat ["import from BarclaycardUs web export. "+ ,"versions: May 2017"])++ <> command' "comdirectVisa" (ComdirectVisa . T.pack <$> strArgument (metavar "BLZ"))@@ -146,6 +159,28 @@ ,"versions: manuell, export"]) <>+ command' "barclaysUk" (pure BarclaysUk)+ (progDesc $ concat ["import from Barclays UK CSV export. " ,"versions: 2017"])+ <>+ command' "natwestIntl" (pure NatwestIntl)+ (progDesc $ concat ["import from Natwest Internation CSV export. " ,"versions: 2017"])+ <>+ command' "monefy"+ (fmap Monefy $ MonefySettings . T.pack <$> strArgument+ (help "monefy instance or phone name (as configured in 'bankAccounts')"+ <> metavar "INSTANCE")+ <*> switch+ (short 's' <> help "Set this flag to use the following format for accounts: 'Monefy Category Account::<category>'"))+ (progDesc $ concat ["import from Monefy CSV export. "+ ,"versions: 2017"])+ <>+ command' "revolut"+ (fmap Revolut $ RevolutSettings () . T.pack <$> strArgument+ (help "Revolut user (as configured in 'bankAccounts')"+ <> metavar "USER"))+ (progDesc $ concat ["manually constructed CSV from Revolut's PDF export."])++ <> command' "paypal" (Paypal . T.pack <$> strArgument (help "paypal username (as configured in 'bankAccounts')"@@ -153,9 +188,18 @@ (progDesc $ concat ["import from german Paypal CSV export with " ,"\"alle guthaben relevanten Zahlungen " ,"(kommagetrennt) ohne warenkorbdetails\". "- ,"versions: 2013, 2014, 2016"])+ ,"versions: 2013, 2014, 2016, 2017"]) - <> command' "aqbanking"+ <>+ command' "pncbank"+ (Pncbank . T.pack <$> strArgument+ (help "PNC account identifier or number (as configured in 'bankAccounts')"+ <> metavar "ACCOUNT_ID"))+ (progDesc $ concat ["import from PNC Bank web export. "+ ,"versions: May 2017"])++ <> + command' "aqbanking" (pure AQBankingImport) (progDesc $ concat ["import CSV file generated by " ,"\"aqbankingcli listtrans\". "
src/Buchhaltung/Types.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-}-#define DERIVING Generic, Default, Show, FromJSON+#define DERIVING Generic, Default, Show, FromJSON, Eq, Ord module Buchhaltung.Types (module Control.Monad.Except ,module Buchhaltung.Types@@ -49,7 +49,7 @@ import System.FilePath import Text.Printf import qualified Text.Regex.TDFA as R-import Text.Regex.TDFA.Text ()+import Text.Regex.TDFA.Text () -- for instances -- * Monad used for most of the funtionality @@ -92,8 +92,9 @@ instance FromJSON Source where parseJSON (Object v) = do Source <$>- (SFormat <$> v .: "name" <*> v .: "version")+ (SFormat <$> v .: "formatName" <*> v .: "formatVersion") <*> v.: "store"+ parseJSON invalid = A.typeMismatch "Source" invalid instance ToJSON Source where toJSON s = Object $ HM.insert "store" (toJSON $ sStore s) $ toJSON@@ -152,7 +153,7 @@ fromListUnique :: (MonadError Msg m, Show k, Ord k) => [(k, a)] -> m (M.Map k a) fromListUnique = sequence . M.fromListWithKey- (\k a b -> throwFormat ("Duplicate key '"%shown%"' in M.fromList") ($ k))+ (\k _ _ -> throwFormat ("Duplicate key '"%shown%"' in M.fromList") ($ k)) . fmap (second pure) -- * Options@@ -166,6 +167,9 @@ } deriving (Show, Generic, NFData) +-- instance Functor (Options user config) where+-- fmap f o = o{oEnv = f $ oEnv o}+ type FullOptions = Options User Config type RawOptions = Options (Maybe Username) () @@ -191,7 +195,7 @@ readLedger :: MonadReader (Options User config env) m =>- (Ledgers -> FilePath) -> m FilePath+ (Ledgers -> a) -> m a readLedger = (<$> readUser ledgers) -- | get absolute paths in profile dir@@ -265,14 +269,16 @@ , aqBanking :: Maybe AQBankingConf , bankAccounts :: Maybe BankAccounts , ignoredAccountsOnAdd :: Maybe [Regex]+ , ignoredAccountsOnMatch :: Maybe [Regex] , numSuggestedAccounts :: Maybe Int+ , reverseAccountInput :: Maybe Bool }- deriving ( Generic, Show, FromJSON )+ deriving ( Generic, Show, FromJSON) type Users = HM.HashMap Username User newtype Username = Username T.Text- deriving ( Generic, FromJSON, NFData, Eq, Hashable, A.FromJSONKey)+ deriving ( Generic, FromJSON, NFData, Eq, Hashable, A.FromJSONKey, Ord) fromUsername :: Username -> T.Text fromUsername (Username n) = n@@ -313,7 +319,7 @@ , mainLedger :: FilePath -- ^ ledger file for 'ledger' CLI , mainHledger :: Maybe FilePath -- ^ ledger file for 'hledger' CLI }- deriving (Generic, Default, Show, FromJSON)+ deriving (Generic, Default, Show, FromJSON, Eq, Ord) -- | generates the receiable/payable account for between two users -- (suffixed by the current, the recording, user)@@ -338,17 +344,13 @@ askAccountMap :: MonadReader (Options User config env) m => m AccountMap askAccountMap = readUser $ maybe mempty fromBankAccounts . bankAccounts --newtype BankAccounts = BankAccounts AccountMap- deriving (Generic, Default, Show)+newtype BankAccounts = BankAccounts+ { fromBankAccounts :: AccountMap }+ deriving (Generic, Default, Show, Eq) -fromBankAccounts :: BankAccounts -> AccountMap-fromBankAccounts (BankAccounts b) = b--isIgnored :: User -> AccountName -> Bool-isIgnored user acc = or $ maybe [] (fmap g) $- ignoredAccountsOnAdd user+isIgnored :: Maybe [Regex] -> AccountName -> Bool+isIgnored regexes acc = or $ maybe [] (fmap g) $ regexes where g ign = R.match (rRegex ign) acc data Regex = Regex@@ -400,7 +402,7 @@ , aqName :: String , aqType :: AQType }- deriving ( Generic, Show)+ deriving ( Generic, Show, Eq, Ord) instance FromJSON AQConnection where parseJSON = A.genericParseJSON $ stripPrefixOptions 2@@ -420,13 +422,13 @@ -- manual. Use the '-C' to point to the configured 'configDir'. data AQType = PinTan | Other- deriving ( Generic, Show, FromJSON, ToJSON, Eq )+ deriving ( Generic, Show, FromJSON, ToJSON, Eq, Ord ) data HBCIv = HBCI201 | HBCI210 | HBCI220 | HBCI300- deriving ( Generic, Show, FromJSON, ToJSON )+ deriving ( Generic, Show, FromJSON, ToJSON, Eq, Ord ) toArg HBCI201 = "201" toArg HBCI210 = "210"@@ -454,7 +456,7 @@ , aqRequest :: Bool -- ^ request new transactions }- | Commit { cArgs :: [String] }+ | Commit { hledger :: Bool, cArgs :: [String] } | ListBalances | Setup | Ledger { lArgs :: [String] }@@ -463,11 +465,27 @@ deriving (Show, Generic, NFData) - data ImportAction = Paypal PaypalUsername | AQBankingImport | ComdirectVisa { comdirectVisaBlz :: T.Text }+ | BarclaycardUs+ | NatwestIntl+ | BarclaysUk+ | Pncbank { pncAccountIdentifier :: T.Text }+ | Monefy MonefySettings+ | Revolut (RevolutSettings ()) deriving (Show, Generic, NFData)++data MonefySettings = MonefySettings+ { monefyInstallation :: T.Text+ , monefyCategorySuffix :: Bool }+ deriving (Show, Generic, NFData)+++data RevolutSettings a = RevolutSettings+ { revolutCurrency :: a + , revolutUser :: T.Text }+ deriving (Show, Generic, NFData, Functor) -- * Misc
src/Buchhaltung/Uniques.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Buchhaltung.Uniques where@@ -18,6 +19,7 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import Data.Time.Calendar+import Debug.Trace import Formatting as F import qualified Formatting.ShortFormatters as F import Hledger.Data@@ -27,37 +29,48 @@ import Text.Printf -- | The monad stack-type M r m = ContT r (RWST () () (M.Map Key Entry) m)+type M r m = ContT r (RWST () () (M.Map KeyIx (Aged Entry)) m)+ +data Aged a = Aged { getAge :: Age+ , unAged :: a+ }+ deriving Show +data Age = Old | New+ deriving (Show, Eq)+ -- | the key that is used to compare transactions. The Int is a -- counter, to ensure there are no actual duplicates in the--- map.+-- map and to be able to update entries. ----- Instead duplicates are found by extraction of a key range using+-- Duplicates are then found by extraction of a key range using -- 'M.split'. See 'findDuplicates'.-type Key = ([(CommoditySymbol,Quantity)], AccountName, Day, Int)+type Key = ([(CommoditySymbol,Quantity)], AccountName, Day)+type KeyIx = (Key, Int) -addNew :: (MonadIO m, MonadReader (Options user Config env) m)++-- | Takes a list of new entries, removes duplicates or updates+-- existing transactions and adds new entries.+addNewEntriesToJournal :: (MonadIO m, MonadReader (Options user Config env) m) => [FilledEntry] -- ^ new candidates including entries already existing in -- journal possible duplicates -> Journal -> m [Entry]-addNew newTxs journal = do+addNewEntriesToJournal newTxs journal = do tag <- askTag- let g i tx = (key tx i- , ImportedEntry tx () $ wSource <$> extractSource tag tx)- fmap (M.elems . fst)+ let toKeyVal i tx = ((deriveKey tx, i)+ , Aged Old $ ImportedEntry tx () $+ wSource <$> extractSource tag tx)+ fmap (fmap unAged . M.elems . fst) <$> execRWST (evalContT $ callCC $ \exit -> zipWithM_ (loop exit $ length newTxs) [1..] newTxs)- () $ M.fromList- $ zipWith g [1..] (jtxns journal)-+ () $ M.fromList $ zipWith toKeyVal [1..] $ jtxns journal -key :: Transaction -> Int -> Key-key tx i = (compAmount $ pamount p, paccount p, tdate tx, i)- where compAmount (Mixed am) = sort- $ fmap (acommodity &&& aquantity) am+-- | Derive a key from a transaction and an index+deriveKey :: Transaction -> Key+deriveKey tx = (compAmount $ pamount p, paccount p, tdate tx)+ where compAmount (Mixed am) = sort $ fmap (acommodity &&& aquantity) am p = head $ tpostings tx -- | loop through all existing possible duplicates of a new@@ -66,41 +79,54 @@ => (() -> M r m ()) -> Int -> Int -> FilledEntry -> M r m () loop exit totalTx iTx new = do- new' <- gets $ \old -> (key (ieT new) $ M.size old + 1, new)- dups <- findDuplicates new' let msg = format ("Transaction: "%F.d%" of "%F.d%" new\n") iTx totalTx- checkOrAsk exit new' msg- $ sortBy (flip $ comparing snd)- $ (id &&& g) <$> dups- where g (_, y) = negate . on+ dups <- findFuzzy $ ieT new+ checkOrAsk exit new msg+ $ sortBy (flip $ comparing snd) $ (id &&& distance) <$> dups+ where distance (_, y) =+ -- careful: the negate is fmapped over the Maybe value+ -- which changes the relative order between Nothing and+ -- Justs.+ negate . on (restrictedDamerauLevenshteinDistance defaultEditCosts) (TL.unpack . json) (ieSource new)- <$> (eitherToMaybe $ ieSource y)+ <$> (eitherToMaybe $ ieSource $ unAged y) eitherToMaybe :: Either b a -> Maybe a eitherToMaybe = either (const Nothing) Just -findDuplicates :: Monad m => (Key, FilledEntry) -> M r m [(Key,Entry)]-findDuplicates ((ams,acc,day,ix), _) = lift $ gets $ \old ->- let later = snd $ M.split (ams,acc,day,0) old in- M.toList $ fst $ M.split (ams,acc,addDays 1 day,ix) later+-- | Find all duplicates for a given key+findDuplicates :: Monad m => Key -> M r m [(KeyIx,Aged Entry)]+findDuplicates key@(ams,acc,day) = lift $ gets $ \old ->+ let later = snd $ M.split (key,0) old in+ M.toList $ fst $ M.split ((ams,acc,addDays 1 day),0) later +findFuzzy :: Monad m => Transaction -> M r m [(KeyIx,Aged Entry)]+findFuzzy = fmap concat . mapM (findDuplicates . deriveKey) . alternatives+ where alternatives x = [x, conditionalDateShift x]+ conditionalDateShift tx = if paccount (head (tpostings tx)) == "Aktiva:Konten:Comdirect:Visa"+ then tx { tdate = addDays (-1) $ tdate tx }+ else tx+ -- | check single new entry against a list of conflict -- candidates, and insert new entry (if list is empty), or keep old -- entry (if identical to new one), or ask weither to modify old entry -- or insert new entry. checkOrAsk :: (MonadIO m, MonadReader (Options user Config env) m) => (() -> M r m ())- -> (Key, FilledEntry)+ -> FilledEntry -> TL.Text -- ^ message- -> [((Key,Entry), Maybe Int)] -> M r m ()+ -> [((KeyIx, Aged Entry), Maybe Int)] -> M r m () checkOrAsk _ new _ [] = do- modify $ uncurry M.insert $ second fromFilled new+ newIx <- gets $ \old -> M.size old + 1+ modify $ uncurry M.insert $ ((deriveKey $ ieT new, newIx), Aged New $ fromFilled new) liftIO $ T.putStrLn "\nSaved new transaction.\n"-checkOrAsk exit new msg (( (oldKey,oldEntry), cost):remaining) = do- if cost == Just 0 then return () -- do nothing, i.e. use old unchanged+checkOrAsk exit new msg (( (oldKey, oldEntry), cost):remaining) = do+ if getAge oldEntry == Old && cost == Just 0+ then return () -- do nothing, i.e. use old unchanged else if False && cost > Just ( - 98)- && on (==) (tdate.ieT) oldEntry (fromFilled $ snd new) then do+ && on (==) (tdate.ieT) (unAged oldEntry) (fromFilled new)+ then do -- liftIO $ do print (fst new) >> print (oldKey) -- print (tdate.ieT.snd $ new) >> print (tdate.ieT $ oldEntry) -- print (ieSource.snd $ new) >> print (ieSource $ oldEntry)@@ -108,7 +134,7 @@ else do let question = (answer =<<) . liftIO $ do L.putStr $ L.unlines- [ prettyPrint cost (snd new) oldEntry msg $ length remaining+ [ prettyPrint cost new oldEntry msg $ length remaining , "Yes, they are duplicates. Update the source [y]" , "No, " <> (if null remaining then "Save as new transaction" else "Show next duplicate") <> " [n]"@@ -126,23 +152,24 @@ where overwriteOldSource = lift $ do tag <- lift $ askTag- modify $ M.adjust (applyChanges tag new oldKey) oldKey+ modify $ M.adjust (applyChanges tag new (deriveKey $ ieT new) $ fst oldKey) oldKey liftIO $ T.putStrLn "\nUpdated duplicate's source.\n" -prettyPrint :: Maybe Int -> FilledEntry -> Entry -> TL.Text -- ^ Message+prettyPrint :: Maybe Int -> FilledEntry -> Aged Entry -> TL.Text -- ^ Message -> Int -- ^ Remaining -> T.Text-prettyPrint cost new old msg remain =- let union2 = f . second unzip . unzip- . M.toList . union- union old = M.mergeWithKey g+prettyPrint cost new (Aged age old) msg remain =+ let union2 = f . second unzip . unzip . M.toList $ M.mergeWithKey g (fmap $ flip (,) "<empty>") (fmap $ (,) "<empty>")- old $ sourceToMap $ ieSource new+ (either (const mempty) sourceToMap $ oldSource)+ $ sourceToMap $ ieSource new g _ x y | x == y = Just $ (x, "") | True = Just $ (x, y) f (k,(old,new)) = T.pack $ P.render $ table [20, 25, 25] header [k, old, new]- header = ["Field", "Old", "New"]+ oldName Old = "Old"+ oldName New = "Imported earlier"+ header = ["Field", oldName age, "New"] oldSource = ieSource old showError (Left x) = ["" ,"Error retrieving old transaction's source:"@@ -152,7 +179,7 @@ def f (Just x) = f x in L.unlines $- [ union2 . either (const mempty) sourceToMap $ oldSource ]+ [ union2 ] ++ [ sformat ("changes: "%F.s%"/"%F.s%"\n"%F.t%"Remaining existing duplicates: "%F.d) (def (show . negate) cost)@@ -163,13 +190,14 @@ ++ showError oldSource -applyChanges :: ImportTag -> (Key, FilledEntry)- -> Key -> Entry -> Entry-applyChanges tag ((ams2,acc2,day2,_),newEntry)- (ams1, acc1, _, _) oldEntry =+applyChanges :: ImportTag -> FilledEntry -> Key -- ^ new key+ -> Key -- ^ old key+ -> Aged Entry -> Aged Entry+applyChanges tag newEntry (ams2,acc2,day2) (ams1, acc1, _) oldEntry = if (ams2,acc2) /= (ams1,acc1) then error $ unlines ["Change not supported: " , show newEntry , show oldEntry]- else oldEntry{ieT= (injectSource tag (ieSource newEntry)- $ ieT oldEntry){tdate = day2}}+ else Aged New $ (unAged oldEntry){+ ieT= (injectSource tag (ieSource newEntry)+ $ ieT $ unAged oldEntry){tdate = day2} }
src/Buchhaltung/Utils.hs view
@@ -53,11 +53,6 @@ #endif -doesPathExist :: FilePath -> IO Bool-doesPathExist = fmap getAny . (a . doesFileExist <> a . doesDirectoryExist)- where a = fmap Any -- -- * Ported from 'System.IO.Temp' to work with 'MonadBaseControl' withSystemTempFile template action = liftIO getTemporaryDirectory >>= \tmpDir -> withTempFile tmpDir template action
stack.yaml view
@@ -1,16 +1,1 @@-flags: {}-packages:-- '.'-# - location:-# git: https://github.com/simonmichael/hledger.git-# commit: 282e85c6028227938457fb3b94eb333c4ba4ae65-# subdirs:-# - hledger-lib-# extra-dep: true--resolver: nightly-2017-01-10-pvp-bounds: both---extra-deps:- - regex-tdfa-text-1.0.0.3+resolver: lts-10.4