diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,65 @@ # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow) + + +## 0.17.0 + +- If you use a custom `preprocess` hook, write to the path supplied as its + second argument. It now points into a temporary directory and keeps the + final filename and extension. Failed hooks preserve the previous + preprocessed CSV or constructed journal. +- If you use the `Hledger.Flow.*` library, update calls that use Turtle + types to use `path` and `Text` types. The `TurtlePath` alias has been + removed. +- Building from source now requires GHC 9.10 or 9.12. Stack builds use + LTS 24.65 (GHC 9.10.3), and Hackage builds use tested dependency bounds. +- Windows x64 users can download `hledger-flow-windows-x64.zip` and extract + `hledger-flow.exe`. +- macOS release binaries are signed with a Developer ID and submitted to + Apple for notarization so Gatekeeper can verify them. +- You can now use the GitHub CLI to verify a downloaded release archive and + check that it was built from the release tag. See “Verifying a download” + in the README. +- Sequential imports now write the same journal as parallel imports and + keep diagnostics visible. Previously, `--sequential import` could print + transactions to the terminal and overwrite the journal with an empty file. +- Importing a single account or year now refreshes the root ledger from + journals already on disk, including newly imported years. Statements + outside the selected directory are left for a later import. +- When an owner, bank, or account is named `1-in` or `2-preprocessed`, + generated files now go under the correct account and the root ledger + includes its journals. +- On Windows, imports now handle native path separators, preserve the year + in include filenames, and write relative journal paths with forward slashes. +- Include generation stays within the requested directory, and an empty + import index can now be read by hledger. +- Reports use the full owner directory name. Owners such as `gawie` and + `gawie.jr` each get reports from their own journal. +- If an owner is named `all` in any capitalization, aggregate reports now go + in `reports/_all_/` so both sets of reports are available. Otherwise, + aggregate reports go in `reports/all/`. +- Reports now discover owners when `import` is a Windows directory junction, + as they do for a Unix symbolic link. +- Parallel imports now report an error for a zero or negative `--batch-size` + instead of hanging. Sequential imports still ignore the batch size. + ## 0.16.4 - Add a new command-line option: `--hledger-conf /path/to/hledger/conf`. @@ -192,7 +252,7 @@ - Re-organised the command-line interface: moved various command-line options out of subcommands, into the top-level. -- Added a [contributor's agreement](https://github.com/apauley/hledger-flow/blob/master/CONTRIBUTING.org) +- Added a [contributor's agreement](https://github.com/apauley/hledger-flow/blob/master/CONTRIBUTING.md) after receiving some more valued contributions from [jecaro](https://github.com/apauley/hledger-flow/pull/42) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,224 @@ +# hledger-flow + +## What is it? + +`hledger-flow` is a command-line program that gives you a guided [Hledger](https://hledger.org/) +workflow. It is important to note that most of the heavy lifting is done by the +upstream `hledger` project. For example, `hledger-flow` cares about where you +put your files for long-term maintainability, but the actual conversion to +classified accounting journals is done by `hledger`. + +`hledger-flow` focuses on automated processing of electronic statements as much as possible, +as opposed to manually adding your own hledger journal entries. Manual entries +are still possible, it just saves time in the long run to automatically process +a statement whenever one is available. + +Within `hledger-flow` you will keep your original bank statements around +permanently as input, and generate (h)ledger journals each time +you run the program. The classification is done with [hledger's rules files](https://hledger.org/csv.html), +and/or your own script hooks. + +Keeping the original statements means that you never have to worry too +much about "am I doing this accounting thing right?" or "what happens if +I make a mistake?". If you want to change your mind about some +classification, or if you made a mistake, you just change your +classification rules, and run the program again. + +It started when I realized that the scripts I wrote while playing around with +[adept's Full-fledged Hledger](https://github.com/adept/full-fledged-hledger/wiki) aren't really specific to my own finances, and can +be shared. + +## Overview of the Basic Workflow + +1. Save an input transaction file (typically CSV) to a [specific directory](docs/README.md#input-files). +2. Add an hledger [rules file](docs/README.md#rules-files). + Include some classification rules if you want. +3. Run `hledger-flow import` + +Add all your files to your favourite version control system. + +The generated journal that you most likely want to use as your +`LEDGER_FILE` is called `all-years.journal`. This has include directives +to all the automatically imported journals, as well as includes for your +own manually managed journal entries. + +In a typical software project we don't add generated files to version +control, but in this case I think it is a good idea to add all the +generated files to version control as well - when you inevitably change +something, e.g. how you classify transactions in your rules file, then +you can easily see if your change had the desired effect by looking at a +diff. + +## Who should use this? + +`hledger-flow` is intended for you if: + +- You want a way to organise your finances into a structure that will be + maintainable over the long term. +- You like the idea of treating your source transactions (typically CSV files) + as input, and having your hledger journals (mostly) being generated as output. +- You want to automate as much as possible when dealing with your + financial life. +- You don't mind writing some scripts when needed, as long as it saves + you time over the long term. + +## How do I install it? + +If you can compile it yourself, please do so by following the [build instructions](https://github.com/apauley/hledger-flow/blob/master/CONTRIBUTING.md#build-the-project). + +Otherwise download [the latest release](https://github.com/apauley/hledger-flow/releases) for your OS, extract the archive, and copy the `hledger-flow` executable (`hledger-flow.exe` on Windows) to a directory in your PATH. + +On Mac you may see a warning. + +Install `hledger` separately and ensure it is on `PATH`, or supply +`--hledger-path`. Account-specific `preprocess` and `construct` scripts need +an available interpreter; on Windows, Unix shell scripts may need adapting. + +### Verifying a download + +Releases from 0.17 onwards are immutable and attested by GitHub. With the +[GitHub CLI](https://cli.github.com/), check that a downloaded archive is the +one published in the release, and that it was built by this project's GitHub +Actions workflow from the release tag: + +``` bash +gh release verify-asset v0.17.0 hledger-flow-macos-arm64.tar.gz -R apauley/hledger-flow +gh attestation verify hledger-flow-macos-arm64.tar.gz -R apauley/hledger-flow +``` + +The macOS binaries are also signed with a Developer ID and notarized by Apple. + +## Getting Started + +Have a look at the [detailed step-by-step instructions](step-by-step/README.md) and the [feature reference](docs/README.md). + +You can see the example imported financial transactions as it was +generated by the step-by-step instructions here: + + + +## Compatibility with hledger + +`hledger-flow` should work with any recent version of `hledger`. + +## Compatibility with ledger-cli + +`hledger-flow` uses `hledger` to produce journal's, so this page about [hledger and Ledger](https://hledger.org/ledger.html) should be relevant for all `hledger-flow` users. + +That said, here are some observations that are specifically relevant to `hledger-flow`: + +When writing out the journal include files, `hledger-flow` sorts the +include statements by filename. + +[Ledger](https://www.ledger-cli.org/) fails any balance assertions +when the transactions aren't included in chronological order. + +An easy way around this is to name your input files so that March's +statement is listed before December's statement. + +Another option is to add `--permissive` to any +[ledger](https://www.ledger-cli.org/) command. + +So you should easily be able to use both `ledger` and `hledger` on these +journals if you take care to [avoid the few incompatibilities](https://hledger.org/faq.html#how-is-hledger-different-from-ledger-) which exists +(eg in your rules files or manual journals). + +## Project Goals + +My `hledger` files started to collect a bunch of supporting code that +weren't really specific to my financial situation. + +I want to extract and share as much as possible of that supporting code. + +[Adept's](https://github.com/adept/full-fledged-hledger/wiki) goals +also resonated with me: + +- Tracking expenses should take as little time, effort and manual work + as possible +- Eventual consistency should be achievable: even if I can't record + something precisely right now, maybe I would be able to do it later, + so I should be able to leave things half-done and pick them up later +- Ability to refactor is a must. I want to be able to go back and change + the way I am doing things, with as little effort as possible and + without fear of irrevocably breaking things. + +# Support + +hledger-flow is supported by [FernTrail B.V.](https://ferntrail.tech/) + +# Contributing to hledger-flow + +Have a look at the [contribution guidelines](CONTRIBUTING.md). + +# FAQ + +## How do you balance transfers between 2 accounts when you have statements for both accounts? + +### The Problem + +In your primary bank account you've happily been classifying transfers to a +secondary account as just `Expenses:OtherAccount`. + +But you've recently started processing the statements from the second account as +well so that you can classify those expenses more accurately. + +And now the balances of these two accounts are all wrong when the statements of +each account deals with money transferred between these two accounts. + +In `bank1.journal`, imported from `bank1.csv`: + + 2018/11/09 Transfer from primary account to secondary account + Assets:Bank1:Primary $-200 + Assets:Bank2:Secondary + +In `bank2.journal`, imported from `bank2.csv`: + + 2018/11/09 Transfer from primary account to secondary account + Assets:Bank2:Secondary $200 + Assets:Bank1:Primary + +### The Solution + +As soon as you start importing statements for both accounts you will have to +introduce an intermediate account for classification between these two accounts. + +I use `Assets:Transfers:*`. + +And we may have reports looking at these transfers accounts at some point, you +should consider using the same names. + +The above example then becomes as follows. + +In `bank1.journal`, imported from `bank1.csv`: + + 2019-05-18 Transfer from primary account to secondary account + Assets:Bank1:Primary $-200 + Assets:Transfers:Bank1Bank2 + +In `bank2.journal`, imported from `bank2.csv`: + + 2019-05-18 Transfer from primary account to secondary account + Assets:Bank2:Secondary $200 + Assets:Transfers:Bank1Bank2 + +Any posting to `Assets:Transfers:*` indicates an in "in-flight" amount. +You would expect the balance of `Assets:Transfers` to be zero most of the time. +Whenever it isn't zero it means that you either don't yet have the other side of +the transfer, or that something is wrong in your rules. + +You could theoretically just use `Assets:Transfers` without any subaccounts, but +I found it useful to use subaccounts. Because then the subaccounts can show me +where I should look for any missing transfer transaction. + +I typically use sorted names as the subaccount (Python code sample): + +``` python +"Assets:Transfers:" + "".join(sorted(["Bank2", "Bank1"])) +``` + +### External references + +This approach is based on what is described in Full-fledged hledger: + + +The question was first asked in [issue \#51](https://github.com/apauley/hledger-flow/issues/51). diff --git a/README.org b/README.org deleted file mode 100644 --- a/README.org +++ /dev/null @@ -1,263 +0,0 @@ -#+STARTUP: showall - -* hledger-flow - :PROPERTIES: - :CUSTOM_ID: hledger-flow - :END: - -** Project Status - -I haven't been able to spend much time on this project in the last few years, -and looking at my current responsibilities this is likely to remain the case. - -I do still try to respond to bug reports as they happen. - -** What is it? - :PROPERTIES: - :CUSTOM_ID: what-is-it - :END: - -=hledger-flow= is a command-line program that gives you a guided [[https://hledger.org/][Hledger]] -workflow. It is important to note that most of the heavy lifting is done by the -upstream =hledger= project. For example, =hledger-flow= cares about where you -put your files for long-term maintainability, but the actual conversion to -classified accounting journals is done by =hledger=. - -=hledger-flow= focuses on automated processing of electronic statements as much as possible, -as opposed to manually adding your own hledger journal entries. Manual entries -are still possible, it just saves time in the long run to automatically process -a statement whenever one is available. - -Within =hledger-flow= you will keep your original bank statements around -permanently as input, and generate (h)ledger journals each time -you run the program. The classification is done with [[https://hledger.org/csv.html][hledger's rules files]], -and/or your own script hooks. - -Keeping the original statements means that you never have to worry too -much about "am I doing this accounting thing right?" or "what happens if -I make a mistake?". If you want to change your mind about some -classification, or if you made a mistake, you just change your -classification rules, and run the program again. - -It started when I realized that the scripts I wrote while playing around with -[[https://github.com/adept/full-fledged-hledger/wiki][adept's Full-fledged Hledger]] aren't really specific to my own finances, and can -be shared. - -** Overview of the Basic Workflow - :PROPERTIES: - :CUSTOM_ID: overview-of-the-basic-workflow - :END: - -1. Save an input transaction file (typically CSV) to a [[#input-files][specific directory]]. -2. Add an hledger [[#rules-files][rules file]]. - Include some classification rules if you want. -3. Run =hledger-flow import= - -Add all your files to your favourite version control system. - -The generated journal that you most likely want to use as your -=LEDGER_FILE= is called =all-years.journal=. This has include directives -to all the automatically imported journals, as well as includes for your -own manually managed journal entries. - -In a typical software project we don't add generated files to version -control, but in this case I think it is a good idea to add all the -generated files to version control as well - when you inevitably change -something, e.g. how you classify transactions in your rules file, then -you can easily see if your change had the desired effect by looking at a -diff. - -** Who should use this? - :PROPERTIES: - :CUSTOM_ID: who-should-use-this - :END: - -=hledger-flow= is intended for you if: - -- You want a way to organise your finances into a structure that will be - maintainable over the long term. -- You like the idea of treating your source transactions (typically CSV files) - as input, and having your hledger journals (mostly) being generated as output. -- You want to automate as much as possible when dealing with your - financial life. -- You don't mind writing some scripts when needed, as long as it saves - you time over the long term. - -** How do I install it? - :PROPERTIES: - :CUSTOM_ID: how-do-i-install-it - :END: - -If you can compile it yourself, please do so by following the [[https://github.com/apauley/hledger-flow/blob/master/CONTRIBUTING.org#build-the-project][build instructions]]. - -Otherwise download [[https://github.com/apauley/hledger-flow/releases][the latest release]] for your OS (Linux or Mac OS X), and copy the =hledger-flow= executable to a directory in your PATH. - -On Linux you should just be able to run the executable. -On Mac you may see a warning. - -** Windows Support - -Currently =hledger-flow= does not work on Windows. - -This [[https://github.com/apauley/hledger-flow/issues?q=is%3Aissue+is%3Aopen+label%3Awindows][list of issues]] describes some of the details of what doesn't work. - -I believe it wouldn't take too much effort to fix those issues, but I'm going to leave Windows support -for other contributors. - -Please send me some pull requests if you would like =hledger-flow= to work on Windows. - -** Getting Started - :PROPERTIES: - :CUSTOM_ID: getting-started - :END: - -Have a look at the [[file:step-by-step/README.org][detailed step-by-step instructions]] and the [[file:docs/README.org][feature reference]]. - -You can see the example imported financial transactions as it was -generated by the step-by-step instructions here: - -[[https://github.com/apauley/hledger-flow-example][https://github.com/apauley/hledger-flow-example]] - -** Compatibility with hledger - -=hledger-flow= should work with any recent version of =hledger=. - -The most recent version that it was tested with is [[https://hledger.org/relnotes.html#2025-09-03-hledger-150][hledger-1.50]] (September 2025). - -Note to future readers: if you are using =hledger-flow= with a more recent version of =hledger= than mentioned above, -please submit a small pull request with the updated version of =hledger=. - -** Compatibility with ledger-cli - :PROPERTIES: - :CUSTOM_ID: compatibility-with-ledger - :END: - -=hledger-flow= uses =hledger= to produce journal's, so this page about [[https://hledger.org/ledger.html][hledger and Ledger]] should be relevant for all =hledger-flow= users. - -That said, here are some observations that are specifically relevant to =hledger-flow=: - -When writing out the journal include files, =hledger-flow= sorts the -include statements by filename. - -[[https://www.ledger-cli.org/][Ledger]] fails any balance assertions -when the transactions aren't included in chronological order. - -An easy way around this is to name your input files so that March's -statement is listed before December's statement. - -Another option is to add =--permissive= to any -[[https://www.ledger-cli.org/][ledger]] command. - -So you should easily be able to use both =ledger= and =hledger= on these -journals if you take care to [[https://hledger.org/faq.html#how-is-hledger-different-from-ledger-][avoid the few incompatibilities]] which exists -(eg in your rules files or manual journals). - -** Project Goals - :PROPERTIES: - :CUSTOM_ID: project-goals - :END: - -My =hledger= files started to collect a bunch of supporting code that -weren't really specific to my financial situation. - -I want to extract and share as much as possible of that supporting code. - -[[https://github.com/adept/full-fledged-hledger/wiki][Adept's]] goals -also resonated with me: - -- Tracking expenses should take as little time, effort and manual work - as possible -- Eventual consistency should be achievable: even if I can't record - something precisely right now, maybe I would be able to do it later, - so I should be able to leave things half-done and pick them up later -- Ability to refactor is a must. I want to be able to go back and change - the way I am doing things, with as little effort as possible and - without fear of irrevocably breaking things. - - -* Contributing to hledger-flow - -Have a look at the [[file:CONTRIBUTING.org][contribution guidelines]]. - -* FAQ - :PROPERTIES: - :CUSTOM_ID: faq - :END: - -** How do you balance transfers between 2 accounts when you have statements for both accounts? - :PROPERTIES: - :CUSTOM_ID: transfer-2-accounts - :END: - -*** The Problem - -In your primary bank account you've happily been classifying transfers to a -secondary account as just =Expenses:OtherAccount=. - -But you've recently started processing the statements from the second account as -well so that you can classify those expenses more accurately. - -And now the balances of these two accounts are all wrong when the statements of -each account deals with money transferred between these two accounts. - -In =bank1.journal=, imported from =bank1.csv=: -#+BEGIN_EXAMPLE -2018/11/09 Transfer from primary account to secondary account - Assets:Bank1:Primary $-200 - Assets:Bank2:Secondary -#+END_EXAMPLE - -In =bank2.journal=, imported from =bank2.csv=: -#+BEGIN_EXAMPLE -2018/11/09 Transfer from primary account to secondary account - Assets:Bank2:Secondary $200 - Assets:Bank1:Primary -#+END_EXAMPLE - -*** The Solution - -As soon as you start importing statements for both accounts you will have to -introduce an intermediate account for classification between these two accounts. - -I use =Assets:Transfers:*=. - -And we may have reports looking at these transfers accounts at some point, you -should consider using the same names. - -The above example then becomes as follows. - -In =bank1.journal=, imported from =bank1.csv=: -#+BEGIN_EXAMPLE -2019-05-18 Transfer from primary account to secondary account - Assets:Bank1:Primary $-200 - Assets:Transfers:Bank1Bank2 -#+END_EXAMPLE - -In =bank2.journal=, imported from =bank2.csv=: -#+BEGIN_EXAMPLE -2019-05-18 Transfer from primary account to secondary account - Assets:Bank2:Secondary $200 - Assets:Transfers:Bank1Bank2 -#+END_EXAMPLE - -Any posting to =Assets:Transfers:*= indicates an in "in-flight" amount. -You would expect the balance of =Assets:Transfers= to be zero most of the time. -Whenever it isn't zero it means that you either don't yet have the other side of -the transfer, or that something is wrong in your rules. - -You could theoretically just use =Assets:Transfers= without any subaccounts, but -I found it useful to use subaccounts. Because then the subaccounts can show me -where I should look for any missing transfer transaction. - -I typically use sorted names as the subaccount (Python code sample): - -#+BEGIN_SRC python - "Assets:Transfers:" + "".join(sorted(["Bank2", "Bank1"])) -#+END_SRC - -*** External references - - This approach is based on what is described in Full-fledged hledger: - [[https://github.com/adept/full-fledged-hledger/wiki/Adding-more-accounts#lets-make-sure-that-transfers-are-not-double-counted]] - - The question was first asked in [[https://github.com/apauley/hledger-flow/issues/51][issue #51]]. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,11 +6,21 @@ import Parsing ( parseStartYear ) import Path ( reldir ) -import qualified Turtle hiding (switch) import Prelude hiding (putStrLn) +import qualified Options.Applicative as Opts (command) import Options.Applicative ( auto, + argument, + customExecParser, + headerDoc, + helper, + hsubparser, + info, + prefs, + progDescDoc, + showHelpOnEmpty, + showHelpOnError, optional, Alternative(many, (<|>)), Parser, @@ -23,7 +33,6 @@ str, switch ) -import Hledger.Flow.PathHelpers (TurtlePath) import Hledger.Flow.Common ( hledgerInfoFromPath ) import Hledger.Flow.Internals (versionInfo, systemInfo) import Hledger.Flow.BaseDir ( determineBaseDir ) @@ -33,20 +42,20 @@ import qualified Data.Text.IO as T -data ImportParams = ImportParams { maybeImportBaseDir :: Maybe TurtlePath +data ImportParams = ImportParams { maybeImportBaseDir :: Maybe FilePath , importStartYear :: Maybe String , onlyNewFiles :: Bool } deriving (Show) -data ReportParams = ReportParams { maybeReportBaseDir :: Maybe TurtlePath +data ReportParams = ReportParams { maybeReportBaseDir :: Maybe FilePath , asciiReports :: Bool } deriving (Show) data Command = Import ImportParams | Report ReportParams deriving (Show) data MainParams = MainParams { verbosity :: Int - , hledgerPathOpt :: Maybe TurtlePath - , hledgerConfOpt :: Maybe TurtlePath + , hledgerPathOpt :: Maybe FilePath + , hledgerConfOpt :: Maybe FilePath , showOpts :: Bool , batchSize :: Maybe Int , sequential :: Bool @@ -55,7 +64,9 @@ main :: IO () main = do - cmd <- Turtle.options "An hledger workflow focusing on automated statement import and classification:\nhttps://github.com/apauley/hledger-flow#readme" baseCommandParser + let description = "An hledger workflow focusing on automated statement import and classification:\nhttps://github.com/apauley/hledger-flow#readme" + cmd <- customExecParser (prefs (showHelpOnError <> showHelpOnEmpty)) + (info (helper <*> baseCommandParser) (headerDoc (Just description))) case cmd of Version -> do sysInfo <- systemInfo @@ -75,7 +86,7 @@ toRuntimeOptionsImport :: MainParams -> ImportParams -> IO RT.RuntimeOptions toRuntimeOptionsImport mainParams' subParams' = do startYear <- parseStartYear $ importStartYear subParams' - let maybeBD = maybeImportBaseDir subParams' :: Maybe TurtlePath + let maybeBD = maybeImportBaseDir subParams' :: Maybe FilePath (bd, runDir) <- determineBaseDir maybeBD hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' size <- determineBatchSize mainParams' @@ -97,7 +108,7 @@ toRuntimeOptionsReport :: MainParams -> ReportParams -> IO RT.RuntimeOptions toRuntimeOptionsReport mainParams' subParams' = do - let maybeBD = maybeReportBaseDir subParams' :: Maybe TurtlePath + let maybeBD = maybeReportBaseDir subParams' :: Maybe FilePath (bd, _) <- determineBaseDir maybeBD hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' size <- determineBatchSize mainParams' @@ -122,25 +133,29 @@ <|> flag' Version (long "version" <> short 'V' <> help "Display version information") commandParser :: Parser Command -commandParser = fmap Import (Turtle.subcommand "import" "Uses hledger with your own rules and/or scripts to convert electronic statements into categorised journal files" subcommandParserImport) - <|> fmap Report (Turtle.subcommand "report" "Generate Reports" subcommandParserReport) +commandParser = fmap Import (subcommand "import" "Uses hledger with your own rules and/or scripts to convert electronic statements into categorised journal files" subcommandParserImport) + <|> fmap Report (subcommand "report" "Generate Reports" subcommandParserReport) + where + subcommand name desc parser = + hsubparser (Opts.command name (info parser (progDescDoc (Just desc))) <> metavar name) + verboseParser :: Parser MainParams verboseParser = MainParams <$> (length <$> many (flag' () (long "verbose" <> short 'v' <> help "Print more verbose output"))) - <*> optional (Turtle.optPath "hledger-path" 'H' "The full path to an hledger executable") + <*> optional (option str (long "hledger-path" <> short 'H' <> metavar "HLEDGER-PATH" <> help "The full path to an hledger executable")) <*> optional (option str (long "hledger-conf" <> metavar "PATH" <> help "The hledger config file to pass to hledger --conf")) <*> switch (long "show-options" <> help "Print the options this program will run with") - <*> optional (option auto (long "batch-size" <> metavar "SIZE" <> help ("Parallel processing of files are done in batches of the specified size. Default: " <> show defaultBatchSize <> ". Ignored during sequential processing."))) + <*> optional (option auto (long "batch-size" <> metavar "SIZE" <> help ("Number of files to process in parallel. Must be positive. Default: " <> show defaultBatchSize <> ". Ignored during sequential processing."))) <*> switch (long "sequential" <> help "Disable parallel processing") subcommandParserImport :: Parser ImportParams subcommandParserImport = ImportParams - <$> optional (Turtle.argPath "dir" "The directory to import. Use the base directory for a full import or a sub-directory for a partial import. Defaults to the current directory.") + <$> optional (argument str (metavar "DIR" <> help "The directory to import. Use the base directory for a full import or a sub-directory for a partial import. Defaults to the current directory.")) <*> optional (option str (long "start-year" <> metavar "YEAR" <> help "Import only from the specified year and onwards, ignoring previous years. By default all available years are imported. Valid values include a 4-digit year or 'current' for the current year")) <*> switch (long "new-files-only" <> help "Skip regenerating output files that are at least as new as their source. This applies to preprocessed files and hledger journal files.") subcommandParserReport :: Parser ReportParams subcommandParserReport = ReportParams - <$> optional (Turtle.argPath "basedir" "The hledger-flow base directory") + <$> optional (argument str (metavar "BASEDIR" <> help "The hledger-flow base directory")) <*> switch (long "ascii-reports" <> help "If to avoid using hledger --pretty-tables flag when generating reports.") diff --git a/hledger-flow.cabal b/hledger-flow.cabal --- a/hledger-flow.cabal +++ b/hledger-flow.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hledger-flow -version: 0.16.4 +version: 0.17.0 synopsis: An hledger workflow focusing on automated statement import and classification. description: Please see the README on GitHub at category: Finance, Console @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple extra-source-files: - README.org + README.md ChangeLog.md source-repository head @@ -47,18 +47,19 @@ src ghc-options: -Wall build-depends: - base >=4.7 && <5 + async >=2.2.5 && <2.3 + , base >=4.20 && <4.22 , containers ==0.7.* + , directory >=1.3.8.5 && <1.4 , exceptions >=0.10.9 && <0.11 , filepath >=1.5.4.0 && <1.6 - , foldl >=1.4.18 && <1.5 , gitrev >=1.3.1 && <1.4 , path >=0.9.6 && <0.10 , path-io >=1.8.2 && <1.9 + , process >=1.6.26.1 && <1.7 , stm >=2.5.3.1 && <2.6 , text >=2.1.3 && <2.2 - , time >=1.12.2 && <1.13 - , turtle >=1.6.2 && <1.7 + , time >=1.12.2 && <1.13 || >=1.14 && <1.15 default-language: Haskell2010 executable hledger-flow @@ -71,12 +72,11 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fPIC ld-options: -dynamic build-depends: - base >=4.7 && <5 + base >=4.20 && <4.22 , hledger-flow - , optparse-applicative >=0.18.1.0 && <0.19 + , optparse-applicative >=0.18.1.0 && <0.20 , path >=0.9.6 && <0.10 , text >=2.1.3 && <2.2 - , turtle >=1.6.2 && <1.7 default-language: Haskell2010 test-suite hledger-flow-test @@ -99,16 +99,15 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - HUnit - , base >=4.7 && <5 + HUnit >=1.6.2.0 && <1.7 + , base >=4.20 && <4.22 , containers ==0.7.* - , directory - , foldl >=1.4.18 && <1.5 + , directory >=1.3.8.5 && <1.4 + , filepath >=1.5.4.0 && <1.6 , hledger-flow , path >=0.9.6 && <0.10 , path-io >=1.8.2 && <1.9 , stm >=2.5.3.1 && <2.6 , text >=2.1.3 && <2.2 - , time >=1.12.2 && <1.13 - , turtle >=1.6.2 && <1.7 + , time >=1.12.2 && <1.13 || >=1.14 && <1.15 default-language: Haskell2010 diff --git a/src/Hledger/Flow/BaseDir.hs b/src/Hledger/Flow/BaseDir.hs --- a/src/Hledger/Flow/BaseDir.hs +++ b/src/Hledger/Flow/BaseDir.hs @@ -12,22 +12,22 @@ import Control.Monad (when) import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.IO.Class (MonadIO) -import Data.Maybe +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.List (stripPrefix) import qualified Data.Text as T import qualified Data.Text.IO as T import Hledger.Flow.PathHelpers import Hledger.Flow.Types (BaseDir, HasBaseDir, RunDir, baseDir) import Path import Path.IO -import qualified Turtle (liftIO, repr, stripPrefix) +import qualified System.FilePath as FilePath -determineBaseDir :: Maybe TurtlePath -> IO (BaseDir, RunDir) +determineBaseDir :: Maybe FilePath -> IO (BaseDir, RunDir) determineBaseDir suppliedDir = do pwd <- getCurrentDir determineBaseDir' pwd suppliedDir -determineBaseDir' :: AbsDir -> Maybe TurtlePath -> IO (BaseDir, RunDir) +determineBaseDir' :: AbsDir -> Maybe FilePath -> IO (BaseDir, RunDir) determineBaseDir' pwd (Just suppliedDir) = do absDir <- turtleToAbsDir pwd suppliedDir determineBaseDirFromStartDir absDir @@ -57,8 +57,8 @@ let fun = composeN (runDirDepth - 4) parent let newRunDir = fun rel when (runDirDepth > 4) $ do - let msg = T.pack $ "Changing runDir from " ++ Turtle.repr rel ++ " to " ++ Turtle.repr newRunDir :: T.Text - Turtle.liftIO $ T.putStrLn msg + let msg = T.pack $ "Changing runDir from " ++ show rel ++ " to " ++ show newRunDir :: T.Text + liftIO $ T.putStrLn msg return newRunDir composeN :: Int -> (a -> a) -> (a -> a) @@ -67,17 +67,20 @@ | n == 1 = f | otherwise = composeN (n - 1) (f . f) -relativeToBase :: (HasBaseDir o) => o -> TurtlePath -> TurtlePath +relativeToBase :: (HasBaseDir o) => o -> FilePath -> FilePath relativeToBase opts = relativeToBase' $ pathToTurtle (baseDir opts) -relativeToBase' :: TurtlePath -> TurtlePath -> TurtlePath -relativeToBase' bd p = - if forceTrailingSlash bd == forceTrailingSlash p - then "./" - else - fromMaybe p $ Turtle.stripPrefix (forceTrailingSlash bd) p +relativeToBase' :: FilePath -> FilePath -> FilePath +relativeToBase' bd p + | forceTrailingSlash bd == forceTrailingSlash p = "./" + | otherwise = + case stripPrefix (FilePath.splitPath (forceTrailingSlash bd)) (FilePath.splitPath (FilePath.normalise p)) of + Nothing -> p + Just parts -> + let suffix = concat parts + in if FilePath.takeFileName suffix == ".." then suffix ++ "/" else suffix -turtleBaseDir :: (HasBaseDir o) => o -> TurtlePath +turtleBaseDir :: (HasBaseDir o) => o -> FilePath turtleBaseDir opts = pathToTurtle $ baseDir opts effectiveRunDir :: BaseDir -> RunDir -> AbsDir diff --git a/src/Hledger/Flow/Common.hs b/src/Hledger/Flow/Common.hs --- a/src/Hledger/Flow/Common.hs +++ b/src/Hledger/Flow/Common.hs @@ -1,35 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Hledger.Flow.Common where +import Control.Concurrent (threadDelay) +import Control.Monad (filterM, forM_, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.Async (concurrently, wait, withAsync) import Control.Concurrent.STM -import Control.Exception (IOException, try) -import qualified Control.Foldl as Fold import Data.Char (isDigit) import Data.Either import Data.Function (on) -import qualified Data.List as List (groupBy, null, sortBy) +import qualified Data.List as List (groupBy, isPrefixOf, isSuffixOf, null, sortBy) import Data.Maybe (mapMaybe) import qualified Data.Map.Strict as Map import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Read as T +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Foreign.Marshal.Utils (withMany) import qualified GHC.IO.Handle.FD as H -import Hledger.Flow.BaseDir (relativeToBase, turtleBaseDir) +import Hledger.Flow.DateTime (timeAction) +import Hledger.Flow.BaseDir (relativeToBase) import Hledger.Flow.Logging -import Hledger.Flow.PathHelpers (AbsFile, TurtlePath, fromTurtleAbsFile, pathToTurtle) +import Hledger.Flow.PathHelpers (AbsFile, RelDir, fromTurtleAbsFile) import qualified Hledger.Flow.RuntimeOptions as RT import Hledger.Flow.Types -import Path (absfile, relfile) +import Path (reldir, relfile, toFilePath) +import qualified Path import qualified Path.IO as Path -import Turtle ((%), (<.>), ()) -import qualified Turtle +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import System.Exit (ExitCode (..), exitWith) +import System.IO (hClose) +import qualified System.Process as Process +import System.IO.Error (tryIOError) +import System.FilePath ((<.>)) import Prelude hiding (putStrLn, readFile, writeFile) -hledgerPathFromOption :: Maybe TurtlePath -> IO AbsFile +hledgerPathFromOption :: Maybe FilePath -> IO AbsFile hledgerPathFromOption pathOption = do case pathOption of Just h -> do @@ -38,7 +48,7 @@ if isOnDisk then return hlAbs else do - let msg = Turtle.format ("Unable to find hledger at " % Turtle.fp) h + let msg = "Unable to find hledger at " <> T.pack h errExit' 1 (T.hPutStrLn H.stderr) msg hlAbs Nothing -> do maybeH <- Path.findExecutable [relfile|hledger|] @@ -49,22 +59,32 @@ "Unable to find hledger in your path.\n" <> "You need to either install hledger, or add it to your PATH, or provide the path to an hledger executable.\n\n" <> "There are a number of installation options on the hledger website: https://hledger.org/download.html" - errExit' 1 (T.hPutStrLn H.stderr) msg [absfile|/hledger|] + ioError (userError msg) -hledgerVersionFromPath :: TurtlePath -> IO T.Text -hledgerVersionFromPath hlp = fmap (T.strip . Turtle.linesToText) (Turtle.single $ shellToList $ Turtle.inproc (Turtle.format Turtle.fp hlp) ["--version"] Turtle.empty) +hledgerVersionFromPath :: AbsFile -> IO T.Text +hledgerVersionFromPath hlp = do + let command = (Process.proc (toFilePath hlp) ["--version"]) + { Process.std_in = Process.CreatePipe, Process.std_out = Process.CreatePipe } + Process.withCreateProcess command $ \input output _ handle -> do + mapM_ hClose input + Just stdoutPipe <- return output + version <- T.hGetContents stdoutPipe + status <- Process.waitForProcess handle + case status of + ExitSuccess -> return (T.strip version) + ExitFailure _ -> exitWith status -hledgerInfoFromPath :: Maybe TurtlePath -> IO HledgerInfo +hledgerInfoFromPath :: Maybe FilePath -> IO HledgerInfo hledgerInfoFromPath pathOption = do hlp <- hledgerPathFromOption pathOption - hlv <- hledgerVersionFromPath $ pathToTurtle hlp + hlv <- hledgerVersionFromPath hlp return $ HledgerInfo hlp hlv hledgerConfArgs :: RT.RuntimeOptions -> [T.Text] hledgerConfArgs opts = case RT.hledgerConf opts of Nothing -> [] - Just conf -> ["--conf", Turtle.format Turtle.fp conf] + Just conf -> ["--conf", T.pack conf] showCmdArgs :: [T.Text] -> T.Text showCmdArgs args = T.intercalate " " (map escapeArg args) @@ -76,16 +96,15 @@ errExit exitStatus ch = errExit' exitStatus (channelErrLn ch) errExit' :: Int -> (T.Text -> IO ()) -> T.Text -> a -> IO a -errExit' exitStatus logFun errorMessage dummyReturnValue = do +errExit' exitStatus logFun errorMessage _ = do logFun errorMessage - Turtle.sleep 0.1 - _ <- Turtle.exit $ Turtle.ExitFailure exitStatus - return dummyReturnValue + threadDelay 100000 + exitWith (ExitFailure exitStatus) descriptiveOutput :: T.Text -> T.Text -> T.Text descriptiveOutput outputLabel outTxt = do if not (T.null outTxt) - then Turtle.format (Turtle.s % ":\n" % Turtle.s % "\n") outputLabel outTxt + then outputLabel <> ":\n" <> outTxt <> "\n" else "" logTimedAction :: @@ -101,125 +120,105 @@ IO FullOutput -> IO FullTimedOutput logTimedAction opts ch cmdLabel extraCmdLabels cmd args stdoutLogger stderrLogger action = do - logVerbose opts ch $ Turtle.format ("Begin: " % Turtle.s) cmdLabel - logVerbose opts ch $ Turtle.format (Turtle.s % " " % Turtle.s) cmd (T.intercalate " " args) + logVerbose opts ch $ "Begin: " <> cmdLabel + logVerbose opts ch $ cmd <> " " <> T.intercalate " " args if (List.null extraCmdLabels) then return () else logVerbose opts ch $ T.intercalate "\n" extraCmdLabels - timed@((ec, stdOut, stdErr), diff) <- Turtle.time action + timed@((ec, stdOut, stdErr), diff) <- timeAction action stdoutLogger ch stdOut stderrLogger ch stdErr - logVerbose opts ch $ Turtle.format ("End: " % Turtle.s % " " % Turtle.s % " (" % Turtle.s % ")") cmdLabel (Turtle.repr ec) (Turtle.repr diff) + logVerbose opts ch $ "End: " <> cmdLabel <> " " <> T.pack (show ec) <> " (" <> T.pack (show diff) <> ")" return timed +-- Drain both output pipes concurrently so a full stderr pipe cannot stall stdout. +runProcessCaptured :: ProcInput -> IO FullOutput +runProcessCaptured (cmd, args, input) = do + let process = (Process.proc (T.unpack cmd) (map T.unpack args)) + { Process.std_in = maybe Process.CreatePipe Process.UseHandle input, + Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe + } + Process.withCreateProcess process $ \stdinPipe output errors handle -> do + mapM_ hClose stdinPipe + Just stdoutPipe <- return output + Just stderrPipe <- return errors + (stdoutText, stderrText) <- concurrently (T.hGetContents stdoutPipe) (T.hGetContents stderrPipe) + status <- Process.waitForProcess handle + return (status, stdoutText, stderrText) + timeAndExitOnErr :: - (HasSequential o, HasVerbosity o) => + (HasVerbosity o) => o -> TChan LogMessage -> T.Text -> (TChan LogMessage -> T.Text -> IO ()) -> (TChan LogMessage -> T.Text -> IO ()) -> - ProcFun -> ProcInput -> IO FullTimedOutput timeAndExitOnErr opts ch cmdLabel = timeAndExitOnErr' opts ch cmdLabel [] timeAndExitOnErr' :: - (HasSequential o, HasVerbosity o) => + (HasVerbosity o) => o -> TChan LogMessage -> T.Text -> [T.Text] -> (TChan LogMessage -> T.Text -> IO ()) -> (TChan LogMessage -> T.Text -> IO ()) -> - ProcFun -> ProcInput -> IO FullTimedOutput -timeAndExitOnErr' opts ch cmdLabel extraCmdLabels stdoutLogger stderrLogger procFun (cmd, args, stdInput) = do - let action = procFun cmd args stdInput +timeAndExitOnErr' opts ch cmdLabel extraCmdLabels stdoutLogger stderrLogger input@(cmd, args, _) = do + let action = runProcessCaptured input timed@((ec, stdOut, stdErr), _) <- logTimedAction opts ch cmdLabel extraCmdLabels cmd args stdoutLogger stderrLogger action case ec of - Turtle.ExitFailure i -> do - let cmdText = Turtle.format (Turtle.s % " " % Turtle.s) cmd $ showCmdArgs args + ExitFailure i -> do + let cmdText = cmd <> " " <> showCmdArgs args let msgOut = descriptiveOutput "Standard output" stdOut let msgErr = descriptiveOutput "Error output" stdErr let exitMsg = - Turtle.format - ( "\n=== Begin Error: " - % Turtle.s - % " ===\nExternal command:\n" - % Turtle.s - % "\nExit code " - % Turtle.d - % "\n" - % Turtle.s - % Turtle.s - % "=== End Error: " - % Turtle.s - % " ===\n" - ) - cmdLabel - cmdText - i - msgOut - msgErr - cmdLabel + "\n=== Begin Error: " <> cmdLabel <> " ===\nExternal command:\n" + <> cmdText <> "\nExit code " <> T.pack (show i) <> "\n" <> msgOut <> msgErr + <> "=== End Error: " <> cmdLabel <> " ===\n" errExit i ch exitMsg timed - Turtle.ExitSuccess -> return timed - -procWithEmptyOutput :: ProcFun -procWithEmptyOutput cmd args stdinput = do - ec <- Turtle.proc cmd args stdinput - return (ec, T.empty, T.empty) - -parAwareProc :: (HasSequential o) => o -> ProcFun -parAwareProc opts = if (sequential opts) then procWithEmptyOutput else Turtle.procStrictWithErr + ExitSuccess -> return timed parAwareActions :: (HasSequential o, HasBatchSize o) => o -> [IO a] -> IO [a] parAwareActions opts = if (sequential opts) then sequence else parBatchedActions (batchSize opts) [] parBatchedActions :: Int -> [a] -> [IO a] -> IO [a] -parBatchedActions _ done [] = return done -parBatchedActions batch done todo = do - let doNow = take batch todo - let remaining = drop batch todo - doneNow <- (Turtle.single . shellToList . Turtle.parallel) doNow - parBatchedActions batch (done ++ doneNow) remaining - -inprocWithErrFun :: (T.Text -> IO ()) -> ProcInput -> Turtle.Shell Turtle.Line -inprocWithErrFun errFun (cmd, args, standardInput) = do - result <- Turtle.inprocWithErr cmd args standardInput - case result of - Right ln -> return ln - Left ln -> do - (Turtle.liftIO . errFun . Turtle.lineToText) ln - Turtle.empty +parBatchedActions batch done todo + | batch < 1 = ioError (userError "--batch-size must be positive") + | otherwise = (done ++) <$> runBatches todo + where + runBatches [] = return [] + runBatches actions = do + let (current, remaining) = splitAt batch actions + -- Start the whole batch, then collect results and exceptions in input order. + results <- withMany withAsync current (mapM wait) + (results ++) <$> runBatches remaining -verboseTestFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> TurtlePath -> IO Bool +verboseTestFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> AbsFile -> IO Bool verboseTestFile opts ch p = do - fileExists <- Turtle.testfile p - let rel = relativeToBase opts p + fileExists <- Path.doesFileExist p + let rel = T.pack (relativeToBase opts (toFilePath p)) if fileExists - then logVerbose opts ch $ Turtle.format ("Found '" % Turtle.fp % "'") rel - else logVerbose opts ch $ Turtle.format ("Looked for but did not find '" % Turtle.fp % "'") rel + then logVerbose opts ch ("Found '" <> rel <> "'") + else logVerbose opts ch ("Looked for but did not find '" <> rel <> "'") return fileExists -needsRegeneration :: TurtlePath -> TurtlePath -> IO Bool +needsRegeneration :: AbsFile -> AbsFile -> IO Bool needsRegeneration src target = do - targetExists <- Turtle.testfile target - if not targetExists - then return True - else do - -- Use try to handle race conditions where files may be modified/deleted - -- between existence check and stat. Treat any IO error as "needs regeneration". - result <- try $ do - srcStat <- Turtle.stat src - targetStat <- Turtle.stat target - let srcMtime = Turtle.modificationTime srcStat - let targetMtime = Turtle.modificationTime targetStat - return (srcMtime > targetMtime) - case result of - Right needsRegen -> return needsRegen - Left (_ :: IOException) -> return True + targetExists <- Path.doesFileExist target + if targetExists + then do + -- Either file can disappear after the existence check. + newer <- tryIOError $ (>) <$> modificationSecond src <*> modificationSecond target + return (either (const True) id newer) + else return True + where + -- Preserve the whole-second comparison used by --new-files-only. + modificationSecond :: AbsFile -> IO Integer + modificationSecond file = floor . utcTimeToPOSIXSeconds <$> Path.getModificationTime file groupPairs' :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])] groupPairs' = @@ -240,106 +239,76 @@ groupValuesBy :: (Ord k, Ord v) => (v -> k) -> [v] -> Map.Map k [v] groupValuesBy keyFun = groupPairs . pairBy keyFun -allYearsFileName :: TurtlePath +allYearsFileName :: FilePath allYearsFileName = "all-years" <.> "journal" -directivesFile :: (HasBaseDir o) => o -> TurtlePath -directivesFile opts = turtleBaseDir opts "directives" <.> "journal" - -lsDirs :: TurtlePath -> Turtle.Shell TurtlePath -lsDirs = onlyDirs . Turtle.ls - -onlyDirs :: Turtle.Shell TurtlePath -> Turtle.Shell TurtlePath -onlyDirs = excludeHiddenFiles . excludeWeirdPaths . filterPathsByFileStatus Turtle.isDirectory - -onlyFiles :: Turtle.Shell TurtlePath -> Turtle.Shell TurtlePath -onlyFiles = excludeHiddenFiles . filterPathsByFileStatus Turtle.isRegularFile - -filterPathsByFileStatus :: (Turtle.FileStatus -> Bool) -> Turtle.Shell TurtlePath -> Turtle.Shell TurtlePath -filterPathsByFileStatus filepred files = do - files' <- shellToList files - filtered <- filterPathsByFileStatus' filepred [] files' - Turtle.select filtered - -filterPathsByFileStatus' :: (Turtle.FileStatus -> Bool) -> [TurtlePath] -> [TurtlePath] -> Turtle.Shell [TurtlePath] -filterPathsByFileStatus' _ acc [] = return acc -filterPathsByFileStatus' filepred acc (file : files) = do - filestat <- Turtle.stat file - let filtered = if (filepred filestat) then file : acc else acc - filterPathsByFileStatus' filepred filtered files +directivesFile :: (HasBaseDir o) => o -> AbsFile +directivesFile opts = baseDir opts Path. [relfile|directives.journal|] -filterPaths :: (TurtlePath -> IO Bool) -> [TurtlePath] -> Turtle.Shell [TurtlePath] +filterPaths :: MonadIO m => (FilePath -> IO Bool) -> [FilePath] -> m [FilePath] filterPaths = filterPaths' [] -filterPaths' :: [TurtlePath] -> (TurtlePath -> IO Bool) -> [TurtlePath] -> Turtle.Shell [TurtlePath] -filterPaths' acc _ [] = return acc -filterPaths' acc filepred (file : files) = do - shouldInclude <- Turtle.liftIO $ filepred file - let filtered = if shouldInclude then file : acc else acc - filterPaths' filtered filepred files - -excludeHiddenFiles :: Turtle.Shell TurtlePath -> Turtle.Shell TurtlePath -excludeHiddenFiles paths = do - p <- paths - case (Turtle.match (Turtle.prefix ".") $ Turtle.format Turtle.fp $ Turtle.filename p) of - [] -> Turtle.select [p] - _ -> Turtle.select [] - -excludeWeirdPaths :: Turtle.Shell TurtlePath -> Turtle.Shell TurtlePath -excludeWeirdPaths = Turtle.findtree (Turtle.suffix $ Turtle.noneOf "_") - -firstExistingFile :: [TurtlePath] -> IO (Maybe TurtlePath) -firstExistingFile files = do - case files of - [] -> return Nothing - file : fs -> do - exists <- Turtle.testfile file - if exists then return (Just file) else firstExistingFile fs - -basenameLine :: TurtlePath -> Turtle.Shell Turtle.Line -basenameLine path = case (Turtle.textToLine $ Turtle.format Turtle.fp $ Turtle.basename path) of - Nothing -> Turtle.die $ Turtle.format ("Unable to determine basename from path: " % Turtle.fp % "\n") path - Just bn -> return bn - -buildFilename :: [Turtle.Line] -> T.Text -> TurtlePath -buildFilename identifiers ext = T.unpack (T.intercalate "-" (map Turtle.lineToText identifiers)) Turtle.<.> (T.unpack ext) +filterPaths' :: MonadIO m => [FilePath] -> (FilePath -> IO Bool) -> [FilePath] -> m [FilePath] +filterPaths' acc predicate files = do + found <- liftIO $ filterM predicate files + return (reverse found ++ acc) -shellToList :: Turtle.Shell a -> Turtle.Shell [a] -shellToList files = Turtle.fold files Fold.list +firstExistingFile :: [AbsFile] -> IO (Maybe AbsFile) +firstExistingFile [] = return Nothing +firstExistingFile (file : rest) = do + exists <- Path.doesFileExist file + if exists then return (Just file) else firstExistingFile rest -writeFiles :: IO (Map.Map TurtlePath T.Text) -> IO [TurtlePath] +writeFiles :: IO (Map.Map FilePath T.Text) -> IO [FilePath] writeFiles fileMap = do m <- fileMap writeFiles' m -writeFiles' :: Map.Map TurtlePath T.Text -> IO [TurtlePath] +writeFiles' :: Map.Map FilePath T.Text -> IO [FilePath] writeFiles' fileMap = do writeTextMap fileMap return $ Map.keys fileMap -writeTextMap :: Map.Map TurtlePath T.Text -> IO () -writeTextMap = Map.foldlWithKey (\a k v -> a <> T.writeFile k v) (return ()) +writeTextMap :: Map.Map FilePath T.Text -> IO () +writeTextMap files = forM_ (Map.toList files) $ \(path, contents) -> do + current <- tryIOError (T.readFile path) + when (either (const True) (/= contents) current) $ T.writeFile path contents -changeExtension :: T.Text -> TurtlePath -> TurtlePath -changeExtension ext path = (Turtle.dropExtension path) Turtle.<.> (T.unpack ext) +changeExtension :: T.Text -> FilePath -> FilePath +changeExtension ext path = (FilePath.dropExtension path) <.> (T.unpack ext) -changePathAndExtension :: TurtlePath -> T.Text -> TurtlePath -> TurtlePath +changePathAndExtension :: FilePath -> T.Text -> FilePath -> FilePath changePathAndExtension newOutputLocation newExt = (changeOutputPath newOutputLocation) . (changeExtension newExt) -changeOutputPath :: TurtlePath -> TurtlePath -> TurtlePath -changeOutputPath newOutputLocation srcFile = mconcat $ map changeSrcDir $ Turtle.splitDirectories srcFile +changeOutputPath :: FilePath -> FilePath -> FilePath +changeOutputPath newOutputLocation = concatMap changeSrcDir . FilePath.splitPath where - changeSrcDir file = if file == "1-in/" || file == "2-preprocessed/" then newOutputLocation else file + changeSrcDir "." = "./" + changeSrcDir ".." = "../" + changeSrcDir part + | FilePath.dropTrailingPathSeparator part `elem` ["1-in", "2-preprocessed"] = newOutputLocation + | otherwise = part -listOwners :: (HasBaseDir o) => o -> Turtle.Shell TurtlePath -listOwners opts = fmap Turtle.basename $ lsDirs $ (turtleBaseDir opts) "import" +listOwners :: HasBaseDir o => o -> IO [RelDir] +listOwners opts = do + let root = baseDir opts Path. [reldir|import|] + perms <- Directory.getPermissions (toFilePath root) + if Directory.readable perms + then do + (dirs, _) <- Path.listDirRel root + return (reverse (filter visible dirs)) + else return [] + where + visible dir = + let name = FilePath.dropTrailingPathSeparator (toFilePath dir) + in not ("." `List.isPrefixOf` name || "_" `List.isSuffixOf` name) -intPath :: Integer -> TurtlePath -intPath = T.unpack . (Turtle.format Turtle.d) +intPath :: Integer -> FilePath +intPath = show -includeYears :: TChan LogMessage -> TurtlePath -> IO [Integer] +includeYears :: TChan LogMessage -> AbsFile -> IO [Integer] includeYears ch includeFile = do - txt <- T.readFile includeFile + txt <- T.readFile (toFilePath includeFile) case includeYears' txt of Left msg -> do channelErrLn ch msg @@ -349,7 +318,7 @@ includeYears' :: T.Text -> Either T.Text [Integer] includeYears' txt = case partitionEithers (includeYears'' txt) of (errors, []) -> do - let msg = Turtle.format ("Unable to extract years from the following text:\n" % Turtle.s % "\nErrors:\n" % Turtle.s) txt (T.intercalate "\n" $ map T.pack errors) + let msg = "Unable to extract years from the following text:\n" <> txt <> "\nErrors:\n" <> T.intercalate "\n" (map T.pack errors) Left msg (_, years) -> Right years diff --git a/src/Hledger/Flow/DateTime.hs b/src/Hledger/Flow/DateTime.hs --- a/src/Hledger/Flow/DateTime.hs +++ b/src/Hledger/Flow/DateTime.hs @@ -2,6 +2,7 @@ import Data.Time.Calendar import Data.Time.Clock +import GHC.Clock (getMonotonicTimeNSec) currentDate :: IO (Integer, Int, Int) -- :: (year,month,day) currentDate = toGregorian . utctDay <$> getCurrentTime @@ -10,3 +11,10 @@ currentYear = do (y, _, _) <- currentDate return y + +timeAction :: IO a -> IO (a, NominalDiffTime) +timeAction action = do + start <- getMonotonicTimeNSec + result <- action + end <- getMonotonicTimeNSec + return (result, fromIntegral (end - start) / 1000000000) diff --git a/src/Hledger/Flow/DocHelpers.hs b/src/Hledger/Flow/DocHelpers.hs --- a/src/Hledger/Flow/DocHelpers.hs +++ b/src/Hledger/Flow/DocHelpers.hs @@ -2,9 +2,7 @@ module Hledger.Flow.DocHelpers where -import qualified Data.Text as T (Text) -import Turtle ((%)) -import qualified Turtle as Turtle (Line, format, l) +import Data.Text (Text) -docURL :: Turtle.Line -> T.Text -docURL = Turtle.format ("https://github.com/apauley/hledger-flow/tree/master/docs#" % Turtle.l) +docURL :: Text -> Text +docURL section = "https://github.com/apauley/hledger-flow/tree/master/docs#" <> section diff --git a/src/Hledger/Flow/Import/CSVImport.hs b/src/Hledger/Flow/Import/CSVImport.hs --- a/src/Hledger/Flow/Import/CSVImport.hs +++ b/src/Hledger/Flow/Import/CSVImport.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Hledger.Flow.Import.CSVImport ( importCSVs, @@ -7,114 +8,102 @@ import Control.Concurrent.STM import Control.Monad -import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, isNothing) import qualified Data.Text as T import qualified Data.Text.IO as T +import Hledger.Flow.DateTime (timeAction) import Hledger.Flow.BaseDir (effectiveRunDir, relativeToBase) import Hledger.Flow.Common import Hledger.Flow.DocHelpers (docURL) import Hledger.Flow.Import.ImportHelpers -import Hledger.Flow.Import.ImportHelpersTurtle (extractImportDirs, writeIncludesUpTo, writeToplevelAllYearsInclude) +import Hledger.Flow.Import.ImportHelpersTurtle (writeIncludesUpTo, writeToplevelAllYearsInclude) import Hledger.Flow.Import.Types import Hledger.Flow.Logging -import Hledger.Flow.PathHelpers (TurtlePath, pathToTurtle) +import Hledger.Flow.PathHelpers (AbsFile, RelDir) import Hledger.Flow.RuntimeOptions import qualified Hledger.Flow.Types as FlowTypes -import Turtle ((%), (<.>), ()) -import qualified Turtle hiding (proc, procStrictWithErr, stderr, stdout) +import qualified Path +import qualified Path.IO as PathIO +import System.Exit (ExitCode (..), exitWith) +import System.IO (hClose) +import qualified System.Process as Process +import System.FilePath (dropExtensions, dropTrailingPathSeparator, replaceExtension, (<.>)) import Prelude hiding (putStrLn, take, writeFile) type FileWasGenerated = Bool importCSVs :: RuntimeOptions -> IO () -importCSVs opts = - Turtle.sh - ( do - ch <- Turtle.liftIO newTChanIO - logHandle <- Turtle.fork $ consoleChannelLoop ch - Turtle.liftIO $ when (showOptions opts) (channelOutLn ch (Turtle.repr opts)) - Turtle.liftIO $ logVerbose opts ch "Starting import" - (journals, diff) <- Turtle.time $ Turtle.liftIO $ importCSVs' opts ch - let generatedJournals = filter snd journals - Turtle.liftIO $ channelOutLn ch $ Turtle.format ("Imported " % Turtle.d % "/" % Turtle.d % " journals in " % Turtle.s) (length generatedJournals) (length journals) $ Turtle.repr diff - Turtle.liftIO $ terminateChannelLoop ch - Turtle.wait logHandle - ) +importCSVs opts = withConsoleLogging $ \ch -> do + when (showOptions opts) (channelOutLn ch (T.pack (show opts))) + logVerbose opts ch "Starting import" + (journals, diff) <- timeAction $ importCSVs' opts ch + let generatedJournals = filter snd journals + channelOutLn ch $ "Imported " <> T.pack (show (length generatedJournals)) <> "/" <> T.pack (show (length journals)) <> " journals in " <> T.pack (show diff) -importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [(TurtlePath, FileWasGenerated)] +importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [(AbsFile, FileWasGenerated)] importCSVs' opts ch = do let effectiveDir = effectiveRunDir (baseDir opts) (importRunDir opts) - let startYearMsg = maybe " " (Turtle.format (" (for the year " % Turtle.d % " and onwards) ")) (importStartYear opts) - channelOutLn ch $ Turtle.format ("Collecting input files" % Turtle.s % "from " % Turtle.fp) startYearMsg (pathToTurtle effectiveDir) - (inputFiles, diff) <- Turtle.time $ findInputFiles (fromMaybe 0 $ importStartYear opts) effectiveDir + let startYearMsg = maybe " " (\y -> " (for the year " <> T.pack (show y) <> " and onwards) ") (importStartYear opts) + let dirText = T.pack (Path.toFilePath effectiveDir) + channelOutLn ch $ "Collecting input files" <> startYearMsg <> "from " <> dirText + (inputFiles, diff) <- timeAction $ findInputFiles (fromMaybe 0 $ importStartYear opts) effectiveDir let fileCount = length inputFiles if fileCount == 0 && isNothing (importStartYear opts) then do let msg = - Turtle.format - ( "I couldn't find any input files underneath " - % Turtle.fp - % "\n\nhledger-flow expects to find its input files in specifically\nnamed directories.\n\n" - % "Have a look at the documentation for a detailed explanation:\n" - % Turtle.s - ) - (pathToTurtle effectiveDir) - (docURL "input-files") + "I couldn't find any input files underneath " <> dirText + <> "\n\nhledger-flow expects to find its input files in specifically\nnamed directories.\n\n" + <> "Have a look at the documentation for a detailed explanation:\n" + <> docURL "input-files" errExit 1 ch msg [] else do - channelOutLn ch $ Turtle.format ("Found " % Turtle.d % " input files" % Turtle.s % "in " % Turtle.s % ". Proceeding with import...") fileCount startYearMsg (Turtle.repr diff) - let actions = map (extractAndImport opts ch . pathToTurtle) inputFiles :: [IO (TurtlePath, FileWasGenerated)] + channelOutLn ch $ "Found " <> T.pack (show fileCount) <> " input files" <> startYearMsg <> "in " <> T.pack (show diff) <> ". Proceeding with import..." + let actions = map (extractAndImport opts ch) inputFiles importedJournals <- parAwareActions opts actions - (journalsOnDisk, journalFindTime) <- Turtle.time $ findJournalFiles effectiveDir - (_, writeIncludeTime1) <- Turtle.time $ writeIncludesUpTo opts ch (pathToTurtle effectiveDir) $ fmap pathToTurtle journalsOnDisk - (_, writeIncludeTime2) <- Turtle.time $ writeToplevelAllYearsInclude opts + let importRoot = baseDir opts Path. [Path.reldir|import|] + (journalsOnDisk, journalFindTime) <- timeAction $ findJournalFiles importRoot + (_, writeIncludeTime1) <- timeAction $ writeIncludesUpTo opts ch importRoot journalsOnDisk + (_, writeIncludeTime2) <- timeAction $ writeToplevelAllYearsInclude opts let includeGenTime = journalFindTime + writeIncludeTime1 + writeIncludeTime2 - channelOutLn ch $ Turtle.format ("Wrote include files for " % Turtle.d % " journals in " % Turtle.s) (length journalsOnDisk) (Turtle.repr includeGenTime) + channelOutLn ch $ "Wrote include files for " <> T.pack (show (length journalsOnDisk)) <> " journals in " <> T.pack (show includeGenTime) return importedJournals -extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> IO (TurtlePath, FileWasGenerated) +extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> AbsFile -> IO (AbsFile, FileWasGenerated) extractAndImport opts ch inputFile = do case extractImportDirs inputFile of Right importDirs -> importCSV opts ch importDirs inputFile Left errorMessage -> do errExit 1 ch errorMessage (inputFile, False) -importCSV :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> IO (TurtlePath, FileWasGenerated) +importCSV :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs Path.Abs -> AbsFile -> IO (AbsFile, FileWasGenerated) importCSV opts ch importDirs srcFile = do - let preprocessScript = accountDir importDirs "preprocess" - let constructScript = accountDir importDirs "construct" - let bankName = importDirLine bankDir importDirs - let accountName = importDirLine accountDir importDirs - let ownerName = importDirLine ownerDir importDirs - (csvFile, preprocessHappened) <- preprocessIfNeeded opts ch preprocessScript bankName accountName ownerName srcFile - let journalOut = changePathAndExtension "3-journal/" "journal" csvFile + csvOut <- outputFile importDirs [Path.reldir|2-preprocessed|] ".csv" srcFile + (csvFile, preprocessHappened) <- preprocessIfNeeded opts ch importDirs srcFile csvOut + journalOut <- outputFile importDirs [Path.reldir|3-journal|] ".journal" csvFile shouldImport <- if onlyNewFiles opts && not preprocessHappened then needsRegeneration csvFile journalOut else return True - - importFun <- - if shouldImport - then constructOrImport opts ch constructScript bankName accountName ownerName - else do - _ <- logNewFileSkip opts ch "import" journalOut - return $ \_p1 _p2 -> return journalOut - Turtle.mktree $ Turtle.directory journalOut - out <- importFun csvFile journalOut - return (out, shouldImport) + PathIO.createDirIfMissing True (Path.parent journalOut) + if shouldImport + then do + let script = accountDir importDirs Path. [Path.relfile|construct|] + hasConstruct <- verboseTestFile opts ch script + if hasConstruct + then withStagedOutput journalOut (customConstruct opts ch script importDirs csvFile) + else hledgerImport opts ch importDirs csvFile journalOut + else logNewFileSkip opts ch "import" journalOut + return (journalOut, shouldImport) -constructOrImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> IO (TurtlePath -> TurtlePath -> IO TurtlePath) -constructOrImport opts ch constructScript bankName accountName ownerName = do - constructScriptExists <- verboseTestFile opts ch constructScript - if constructScriptExists - then return $ customConstruct opts ch constructScript bankName accountName ownerName - else return $ hledgerImport opts ch +outputFile :: ImportDirs Path.Abs -> RelDir -> String -> AbsFile -> IO AbsFile +outputFile dirs stage ext source = do + name <- Path.parseRelFile (replaceExtension (Path.toFilePath (Path.filename source)) ext) + return (accountDir dirs Path. stage Path. Path.dirname (yearDir dirs) Path. name) -preprocessIfNeeded :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> IO (TurtlePath, Bool) -preprocessIfNeeded opts ch script bank account owner src = do - let csvOut = changePathAndExtension "2-preprocessed/" "csv" src +preprocessIfNeeded :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs Path.Abs -> AbsFile -> AbsFile -> IO (AbsFile, Bool) +preprocessIfNeeded opts ch dirs src csvOut = do + let script = accountDir dirs Path. [Path.relfile|preprocess|] scriptExists <- verboseTestFile opts ch script targetExists <- verboseTestFile opts ch csvOut shouldProceed <- @@ -126,120 +115,91 @@ else return scriptExists if shouldProceed then do - out <- preprocess opts ch script bank account owner src csvOut - return (out, True) + withStagedOutput csvOut (preprocess opts ch script dirs src) + return (csvOut, True) else do if targetExists then return (csvOut, False) else return (src, False) -logNewFileSkip :: RuntimeOptions -> TChan FlowTypes.LogMessage -> T.Text -> TurtlePath -> IO () +logNewFileSkip :: RuntimeOptions -> TChan FlowTypes.LogMessage -> T.Text -> AbsFile -> IO () logNewFileSkip opts ch logIdentifier absTarget = Control.Monad.when (onlyNewFiles opts) $ do - let relativeTarget = relativeToBase opts absTarget + let relativeTarget = relativeToBase opts (Path.toFilePath absTarget) logVerbose opts ch $ - Turtle.format - ( "Skipping " - % Turtle.s - % " - output file is at least as new as source: '" - % Turtle.fp - % "'" - ) - logIdentifier - relativeTarget - -preprocess :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath -preprocess opts ch script bank account owner src csvOut = do - Turtle.mktree $ Turtle.directory csvOut - let args = [Turtle.format Turtle.fp src, Turtle.format Turtle.fp csvOut, Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner] - let relScript = relativeToBase opts script - let relSrc = relativeToBase opts src - let cmdLabel = Turtle.format ("executing '" % Turtle.fp % "' on '" % Turtle.fp % "'") relScript relSrc - _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (Turtle.format Turtle.fp script, args, Turtle.empty) - return csvOut + "Skipping " <> logIdentifier <> " - output file is at least as new as source: '" <> T.pack relativeTarget <> "'" -hledgerImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> TurtlePath -> IO TurtlePath -hledgerImport opts ch csvSrc journalOut = do - case extractImportDirs csvSrc of - Right importDirs -> hledgerImport' opts ch importDirs csvSrc journalOut - Left errorMessage -> do - errExit 1 ch errorMessage csvSrc +preprocess :: RuntimeOptions -> TChan FlowTypes.LogMessage -> AbsFile -> ImportDirs Path.Abs -> AbsFile -> AbsFile -> IO () +preprocess opts ch script dirs src csvOut = do + let args = map (T.pack . Path.toFilePath) [src, csvOut] ++ hookDirArgs dirs + let relScript = relativeToBase opts (Path.toFilePath script) + let relSrc = relativeToBase opts (Path.toFilePath src) + let cmdLabel = "executing '" <> T.pack relScript <> "' on '" <> T.pack relSrc <> "'" + _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (T.pack (Path.toFilePath script), args, Nothing) + return () -hledgerImport' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> TurtlePath -> IO TurtlePath -hledgerImport' opts ch importDirs csvSrc journalOut = do - let candidates = rulesFileCandidates csvSrc importDirs +hledgerImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs Path.Abs -> AbsFile -> AbsFile -> IO () +hledgerImport opts ch importDirs csvFile journalOut = do + let csvSrc = Path.toFilePath csvFile + candidates <- rulesFileCandidates csvFile importDirs maybeRulesFile <- firstExistingFile candidates let relCSV = relativeToBase opts csvSrc case maybeRulesFile of Just rf -> do - let relRules = relativeToBase opts rf - let hledger = Turtle.format Turtle.fp $ pathToTurtle . FlowTypes.hlPath . hledgerInfo $ opts :: T.Text - directivesExist <- Turtle.testfile $ directivesFile opts - let directivesArgs = if directivesExist then ["--file", Turtle.format Turtle.fp (directivesFile opts)] else [] - let csvArgs = ["--file", Turtle.format Turtle.fp csvSrc, "--rules-file", Turtle.format Turtle.fp rf] + let relRules = relativeToBase opts (Path.toFilePath rf) + let hledger = T.pack (Path.toFilePath (FlowTypes.hlPath (hledgerInfo opts))) + let directives = directivesFile opts + directivesExist <- PathIO.doesFileExist directives + let directivesArgs = if directivesExist then ["--file", T.pack (Path.toFilePath directives)] else [] + let csvArgs = ["--file", T.pack csvSrc, "--rules-file", T.pack (Path.toFilePath rf)] let args = hledgerConfArgs opts ++ ["print", "--explicit"] ++ directivesArgs ++ csvArgs - let cmdLabel = Turtle.format ("importing '" % Turtle.fp % "' using rules file '" % Turtle.fp % "'") relCSV relRules - ((_, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr (parAwareProc opts) (hledger, args, Turtle.empty) - _ <- T.writeFile journalOut stdOut - return journalOut + let cmdLabel = "importing '" <> T.pack relCSV <> "' using rules file '" <> T.pack relRules <> "'" + ((_, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr (hledger, args, Nothing) + T.writeFile (Path.toFilePath journalOut) stdOut Nothing -> do - let relativeCandidates = map (relativeToBase opts) candidates - let candidatesTxt = T.intercalate "\n" $ map (Turtle.format Turtle.fp) relativeCandidates + let candidatesTxt = T.intercalate "\n" $ map (T.pack . relativeToBase opts . Path.toFilePath) candidates let msg = - Turtle.format - ( "I couldn't find an hledger rules file while trying to import\n" - % Turtle.fp - % "\n\nI will happily use the first rules file I can find from any one of these " - % Turtle.d - % " files:\n" - % Turtle.s - % "\n\nHere is a bit of documentation about rules files that you may find helpful:\n" - % Turtle.s - ) - relCSV - (length candidates) - candidatesTxt - (docURL "rules-files") - errExit 1 ch msg csvSrc - -rulesFileCandidates :: TurtlePath -> ImportDirs -> [TurtlePath] -rulesFileCandidates csvSrc importDirs = statementSpecificRulesFiles csvSrc importDirs ++ generalRulesFiles importDirs - -importDirLines :: (ImportDirs -> TurtlePath) -> ImportDirs -> [Turtle.Line] -importDirLines dirFun importDirs = NonEmpty.toList $ Turtle.textToLines $ Turtle.format Turtle.fp $ Turtle.dirname $ dirFun importDirs - -importDirLine :: (ImportDirs -> TurtlePath) -> ImportDirs -> Turtle.Line -importDirLine dirFun importDirs = foldl (<>) "" $ importDirLines dirFun importDirs - -generalRulesFiles :: ImportDirs -> [TurtlePath] -generalRulesFiles importDirs = do - let bank = importDirLines bankDir importDirs - let account = importDirLines accountDir importDirs - let accountRulesFile = accountDir importDirs buildFilename (bank ++ account) "rules" + "I couldn't find an hledger rules file while trying to import\n" <> T.pack relCSV + <> "\n\nI will happily use the first rules file I can find from any one of these " + <> T.pack (show (length candidates)) <> " files:\n" <> candidatesTxt + <> "\n\nHere is a bit of documentation about rules files that you may find helpful:\n" + <> docURL "rules-files" + errExit 1 ch msg () - let bankRulesFile = importDir importDirs buildFilename bank "rules" - [accountRulesFile, bankRulesFile] +rulesFileCandidates :: AbsFile -> ImportDirs Path.Abs -> IO [AbsFile] +rulesFileCandidates csv dirs = do + let bank = importDirLines (bankDir dirs) + account = importDirLines (accountDir dirs) + accountRule <- rulesName (bank ++ account) + bankRule <- rulesName bank + overrides <- if "rfo" `T.isPrefixOf` suffix + then do + name <- rulesName [suffix] + return [dir Path. name | dir <- [accountDir dirs, bankDir dirs, importDir dirs]] + else return [] + return (overrides ++ [accountDir dirs Path. accountRule, importDir dirs Path. bankRule]) + where + stem = dropExtensions (Path.toFilePath (Path.filename csv)) + suffix = snd (T.breakOnEnd "_" (T.pack stem)) + rulesName parts = Path.parseRelFile (T.unpack (T.intercalate "-" parts) <.> "rules") -statementSpecificRulesFiles :: TurtlePath -> ImportDirs -> [TurtlePath] -statementSpecificRulesFiles csvSrc importDirs = do - let srcSuffix = snd $ T.breakOnEnd "_" (Turtle.format Turtle.fp (Turtle.basename csvSrc)) +importDirLines :: Path.Path b Path.Dir -> [T.Text] +importDirLines = T.splitOn "\n" . T.pack . dropTrailingPathSeparator . Path.toFilePath . Path.dirname - if ((T.take 3 srcSuffix) == "rfo") - then do - let srcSpecificFilename = T.unpack srcSuffix <.> "rules" - map ( srcSpecificFilename) [accountDir importDirs, bankDir importDirs, importDir importDirs] - else [] +hookDirArgs :: ImportDirs b -> [T.Text] +hookDirArgs dirs = map (T.concat . importDirLines) [bankDir dirs, accountDir dirs, ownerDir dirs] -customConstruct :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath -customConstruct opts ch constructScript bank account owner csvSrc journalOut = do - let script = Turtle.format Turtle.fp constructScript :: T.Text - let relScript = relativeToBase opts constructScript - let constructArgs = [Turtle.format Turtle.fp csvSrc, "-", Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner] - let constructCmdText = Turtle.format ("Running: " % Turtle.fp % " " % Turtle.s) relScript (showCmdArgs constructArgs) - let stdLines = inprocWithErrFun (channelErrLn ch) (script, constructArgs, Turtle.empty) - let hledger = Turtle.format Turtle.fp $ pathToTurtle . FlowTypes.hlPath . hledgerInfo $ opts :: T.Text +customConstruct :: RuntimeOptions -> TChan FlowTypes.LogMessage -> AbsFile -> ImportDirs Path.Abs -> AbsFile -> AbsFile -> IO () +customConstruct opts ch constructScript dirs csvFile journalOut = do + let csvSrc = Path.toFilePath csvFile + let relScript = relativeToBase opts (Path.toFilePath constructScript) + let constructArgs = [T.pack csvSrc, "-"] ++ hookDirArgs dirs + let constructCmdText = "Running: " <> T.pack relScript <> " " <> showCmdArgs constructArgs + let hook = (Process.proc (Path.toFilePath constructScript) (map T.unpack constructArgs)) + { Process.std_in = Process.CreatePipe, Process.std_out = Process.CreatePipe } + let hledger = T.pack (Path.toFilePath (FlowTypes.hlPath (hledgerInfo opts))) let args = hledgerConfArgs opts ++ [ "print", @@ -247,10 +207,19 @@ "--file", "-", "--output-file", - Turtle.format Turtle.fp journalOut + T.pack (Path.toFilePath journalOut) ] let relSrc = relativeToBase opts csvSrc - let cmdLabel = Turtle.format ("executing '" % Turtle.fp % "' on '" % Turtle.fp % "'") relScript relSrc - _ <- timeAndExitOnErr' opts ch cmdLabel [constructCmdText] channelOut channelErr (parAwareProc opts) (hledger, args, stdLines) - return journalOut + let cmdLabel = "executing '" <> T.pack relScript <> "' on '" <> T.pack relSrc <> "'" + Process.withCreateProcess hook $ \input output _ handle -> do + Just stdinPipe <- return input + Just stdoutPipe <- return output + hClose stdinPipe + _ <- timeAndExitOnErr' opts ch cmdLabel [constructCmdText] channelOut channelErr + (hledger, args, Just stdoutPipe) + hClose stdoutPipe + status <- Process.waitForProcess handle + case status of + ExitSuccess -> return () + ExitFailure _ -> exitWith status diff --git a/src/Hledger/Flow/Import/ImportHelpers.hs b/src/Hledger/Flow/Import/ImportHelpers.hs --- a/src/Hledger/Flow/Import/ImportHelpers.hs +++ b/src/Hledger/Flow/Import/ImportHelpers.hs @@ -1,25 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Hledger.Flow.Import.ImportHelpers (findInputFiles, findJournalFiles, groupIncludesUpTo, includeFileName) where +module Hledger.Flow.Import.ImportHelpers (withStagedOutput, extractImportDirs, findInputFiles, findJournalFiles, groupIncludesUpTo, includeFileName) where import Data.Char (isDigit) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) +import qualified Data.Text as T import Hledger.Flow.Common (groupValuesBy) -import Hledger.Flow.Import.Types (InputFileBundle) -import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelDir, RelFile, findFilesIn, pathSize) +import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.Import.Types (ImportDirs (..), InputFileBundle) +import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelDir, RelFile, findFilesInWith, pathSize) import Path +import qualified Path.IO as PathIO import System.FilePath (dropTrailingPathSeparator) +-- Keep hook output on the destination filesystem and publish it only on success. +withStagedOutput :: AbsFile -> (AbsFile -> IO ()) -> IO () +withStagedOutput target writeOutput = do + let dir = parent target + PathIO.createDirIfMissing True dir + PathIO.withTempDir dir ".hledger-flow-" $ \tmp -> do + let staged = tmp filename target + writeOutput staged + PathIO.renameFile staged target + +extractImportDirs :: Path b File -> Either T.Text (ImportDirs b) +extractImportDirs inputFile = walk (parent inputFile) [] + where + walk dir children + | dirname dir == [reldir|import|] = case children of + [owner, bank, account, state, year] -> Right (ImportDirs dir owner bank account state year) + _ -> malformed + | parent dir == dir = malformed + | otherwise = walk (parent dir) (dir : children) + + malformed = Left $ + "I couldn't find the right number of directories between \"import\" and the input file:\n" + <> T.pack (toFilePath inputFile) + <> "\n\nhledger-flow expects to find input files in this structure:\n" + <> "import/owner/bank/account/filestate/year/trxfile\n\n" + <> "Have a look at the documentation for a detailed explanation:\n" + <> docURL "input-files" + findInputFiles :: Integer -> AbsDir -> IO [AbsFile] findInputFiles startYear = do - let excludeDirs = [[reldir|2-preprocessed|], [reldir|3-journal|]] ++ commonExcludeDirs - findFilesIn (includeYearFilesForParent [reldir|1-in|] startYear) excludeDirs + let excludeDirs = excludeStageDirs [[reldir|2-preprocessed|], [reldir|3-journal|]] + findFilesInWith (includeYearFilesForParent [reldir|1-in|] startYear) excludeDirs findJournalFiles :: AbsDir -> IO [AbsFile] findJournalFiles = do - let excludeDirs = [[reldir|1-in|], [reldir|2-preprocessed|]] ++ commonExcludeDirs - findFilesIn (includeYearFilesForParent [reldir|3-journal|] 0) excludeDirs + let excludeDirs = excludeStageDirs [[reldir|1-in|], [reldir|2-preprocessed|]] + findFilesInWith (includeYearFilesForParent [reldir|3-journal|] 0) excludeDirs -- | Include only files directly underneath parentDir/yearDir, e.g. 1-in/2020/* or 3-journal/2020/* includeYearFilesForParent :: RelDir -> Integer -> AbsDir -> Bool @@ -34,29 +66,28 @@ dirToStringNoSlash :: AbsDir -> String dirToStringNoSlash = init . Path.toFilePath . Path.dirname -commonExcludeDirs :: [RelDir] -commonExcludeDirs = [[reldir|_manual_|], [reldir|__pycache__|]] +-- Stage names are reserved only directly below an account. +excludeStageDirs :: [RelDir] -> AbsDir -> [RelDir] +excludeStageDirs stages dir + | dirname (parent (parent (parent dir))) == [reldir|import|] = stages ++ common + | otherwise = common + where + common = [[reldir|_manual_|], [reldir|__pycache__|]] groupIncludesUpTo :: RelDir -> [RelFile] -> InputFileBundle -groupIncludesUpTo = groupIncludesUpTo' Map.empty - -groupIncludesUpTo' :: InputFileBundle -> RelDir -> [RelFile] -> InputFileBundle -groupIncludesUpTo' acc _ [] = acc -groupIncludesUpTo' acc stopAt journals = do - let dirs = map parent journals :: [RelDir] - let shouldStop = stopAt `elem` dirs - if shouldStop - then acc - else do - let grouped = groupIncludeFilesPerYear journals - groupIncludesUpTo' (acc <> grouped) stopAt (Map.keys grouped) +groupIncludesUpTo stopAt = collect Map.empty + where + collect acc files = + let belowStop f = isProperPrefixOf stopAt f && parent f /= stopAt + groups = Map.filterWithKey (\f _ -> isProperPrefixOf stopAt f) $ + groupValuesBy includePath (filter belowStop files) + in if Map.null groups + then acc + else collect (Map.unionWith (++) acc groups) (Map.keys groups) -groupIncludeFilesPerYear :: [RelFile] -> InputFileBundle -groupIncludeFilesPerYear [] = Map.empty -groupIncludeFilesPerYear ps@(p : _) = - if pathSize (parent p) == 6 - then groupValuesBy initialIncludeFilePath ps - else groupValuesBy parentIncludeFilePath ps + includePath file + | pathSize (parent file) == 6 = initialIncludeFilePath file + | otherwise = parentIncludeFilePath file initialIncludeFilePath :: RelFile -> RelFile initialIncludeFilePath p = (parent . parent . parent) p includeFileName p diff --git a/src/Hledger/Flow/Import/ImportHelpersTurtle.hs b/src/Hledger/Flow/Import/ImportHelpersTurtle.hs --- a/src/Hledger/Flow/Import/ImportHelpersTurtle.hs +++ b/src/Hledger/Flow/Import/ImportHelpersTurtle.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | Functions which currently uses TurtlePath and will be replaced with Path eventually +-- | Generate journal include files and their relative include directives. module Hledger.Flow.Import.ImportHelpersTurtle ( allYearIncludeFiles, extractImportDirs, @@ -17,159 +17,157 @@ where import Control.Concurrent.STM (TChan) -import qualified Data.List as List (nub, sort) +import Control.Monad (unless) +import Data.Either (isRight) +import qualified Data.List as List (isPrefixOf, nub, sort) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Text as T import Hledger.Flow.BaseDir (relativeToBase, relativeToBase', turtleBaseDir) import Hledger.Flow.Common (allYearsFileName, directivesFile, filterPaths, groupValuesBy, writeFiles, writeFiles') -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.Import.ImportHelpers (extractImportDirs, groupIncludesUpTo) import Hledger.Flow.Import.Types import Hledger.Flow.Logging (logVerbose) -import Hledger.Flow.PathHelpers (TurtlePath) +import Hledger.Flow.PathHelpers (AbsDir, AbsFile) import Hledger.Flow.Types -import Turtle ((%), (<.>), ()) -import qualified Turtle - -extractImportDirs :: TurtlePath -> Either T.Text ImportDirs -extractImportDirs inputFile = do - case importDirBreakdown inputFile of - [bd, owner, bank, account, filestate, year] -> Right $ ImportDirs bd owner bank account filestate year - _ -> do - Left $ - Turtle.format - ( "I couldn't find the right number of directories between \"import\" and the input file:\n" - % Turtle.fp - % "\n\nhledger-flow expects to find input files in this structure:\n" - % "import/owner/bank/account/filestate/year/trxfile\n\n" - % "Have a look at the documentation for a detailed explanation:\n" - % Turtle.s - ) - inputFile - (docURL "input-files") - -importDirBreakdown :: TurtlePath -> [TurtlePath] -importDirBreakdown = importDirBreakdown' [] - -importDirBreakdown' :: [TurtlePath] -> TurtlePath -> [TurtlePath] -importDirBreakdown' acc path = do - let dir = Turtle.directory path - if Turtle.dirname dir == "import" || (Turtle.dirname dir == "") - then dir : acc - else importDirBreakdown' (dir : acc) $ Turtle.parent dir +import qualified Path +import qualified Path.IO as PathIO +import System.Directory (doesFileExist) +import qualified System.FilePath as FilePath +import System.FilePath (()) -groupIncludeFiles :: [TurtlePath] -> (TurtleFileBundle, TurtleFileBundle) +groupIncludeFiles :: [FilePath] -> (TurtleFileBundle, TurtleFileBundle) groupIncludeFiles = allYearIncludeFiles . groupIncludeFilesPerYear . filter isJournalFile -isJournalFile :: TurtlePath -> Bool -isJournalFile f = Turtle.extension f == Just "journal" +isJournalFile :: FilePath -> Bool +isJournalFile f = FilePath.takeExtension f == ".journal" allYearIncludeFiles :: TurtleFileBundle -> (TurtleFileBundle, TurtleFileBundle) allYearIncludeFiles m = (m, yearsIncludeMap $ Map.keys m) -yearsIncludeMap :: [TurtlePath] -> TurtleFileBundle +yearsIncludeMap :: [FilePath] -> TurtleFileBundle yearsIncludeMap = groupValuesBy allYearsPath -allYearsPath :: TurtlePath -> TurtlePath -allYearsPath = allYearsPath' Turtle.directory - -allYearsPath' :: (TurtlePath -> TurtlePath) -> TurtlePath -> TurtlePath -allYearsPath' dir p = dir p allYearsFileName +allYearsPath :: FilePath -> FilePath +allYearsPath journal = fst (FilePath.splitFileName journal) allYearsFileName -includeFileName :: TurtlePath -> TurtlePath -includeFileName = (<.> "journal") . T.unpack . (Turtle.format (Turtle.fp % "-include")) . Turtle.dirname +includeFileName :: FilePath -> FilePath +includeFileName journal = FilePath.takeFileName (FilePath.takeDirectory journal) ++ "-include.journal" -groupIncludeFilesPerYear :: [TurtlePath] -> TurtleFileBundle +groupIncludeFilesPerYear :: [FilePath] -> TurtleFileBundle groupIncludeFilesPerYear [] = Map.empty -groupIncludeFilesPerYear ps@(p : _) = case extractImportDirs p of - Right _ -> groupValuesBy initialIncludeFilePath ps - Left _ -> groupValuesBy parentIncludeFilePath ps +groupIncludeFilesPerYear ps@(p : _) + | maybe False (Path.prjSomeBase (isRight . extractImportDirs)) (Path.parseSomeFile p) = + groupValuesBy initialIncludeFilePath ps + | otherwise = groupValuesBy parentIncludeFilePath ps -initialIncludeFilePath :: TurtlePath -> TurtlePath -initialIncludeFilePath p = (Turtle.parent . Turtle.parent . Turtle.parent) p includeFileName p +initialIncludeFilePath :: FilePath -> FilePath +initialIncludeFilePath p = ancestorDir 3 p includeFileName p -parentIncludeFilePath :: TurtlePath -> TurtlePath -parentIncludeFilePath p = (Turtle.parent . Turtle.parent) p Turtle.filename p +parentIncludeFilePath :: FilePath -> FilePath +parentIncludeFilePath p = ancestorDir 2 p FilePath.takeFileName p -toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> IO (Map.Map TurtlePath T.Text) +-- Keep the original path components (including separators) when constructing +-- include-map keys. Relative keys have historically been rooted at "./". +ancestorDir :: Int -> FilePath -> FilePath +ancestorDir levels file = prefix FilePath.joinPath parents + where + (drive, rest) = FilePath.splitDrive file + parts = FilePath.splitPath rest + parents = take (length parts - levels) parts + prefix = case parents of + first : _ | first == "./" || first == "../" -> drive + _ | null drive -> "./" + _ -> drive + +toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> IO (Map.Map FilePath T.Text) toIncludeFiles opts ch m = do preMap <- extraIncludes opts ch (Map.keys m) ["opening.journal"] ["pre-import.journal"] [] postMap <- extraIncludes opts ch (Map.keys m) ["closing.journal"] ["post-import.journal"] ["prices.journal"] return $ (addPreamble . toIncludeFiles' preMap postMap) m -toIncludeFiles' :: TurtleFileBundle -> TurtleFileBundle -> TurtleFileBundle -> Map.Map TurtlePath T.Text +toIncludeFiles' :: TurtleFileBundle -> TurtleFileBundle -> TurtleFileBundle -> Map.Map FilePath T.Text toIncludeFiles' preMap postMap = Map.mapWithKey $ generatedIncludeText preMap postMap -addPreamble :: Map.Map TurtlePath T.Text -> Map.Map TurtlePath T.Text +addPreamble :: Map.Map FilePath T.Text -> Map.Map FilePath T.Text addPreamble = Map.map (\txt -> includePreamble <> "\n" <> txt) -toIncludeLine :: TurtlePath -> TurtlePath -> T.Text -toIncludeLine base file = Turtle.format ("include " % Turtle.fp) $ relativeToBase' base file +toIncludeLine :: FilePath -> FilePath -> T.Text +toIncludeLine base file = "include " <> T.pack (map forwardSlash (relativeToBase' base file)) + where + forwardSlash c = if FilePath.isPathSeparator c then '/' else c -generatedIncludeText :: TurtleFileBundle -> TurtleFileBundle -> TurtlePath -> [TurtlePath] -> T.Text +generatedIncludeText :: TurtleFileBundle -> TurtleFileBundle -> FilePath -> [FilePath] -> T.Text generatedIncludeText preMap postMap outputFile fs = do let preFiles = fromMaybe [] $ Map.lookup outputFile preMap let files = List.nub . List.sort $ fs let postFiles = fromMaybe [] $ Map.lookup outputFile postMap - let lns = map (toIncludeLine $ Turtle.directory outputFile) $ preFiles ++ files ++ postFiles + let lns = map (toIncludeLine $ FilePath.takeDirectory outputFile) $ preFiles ++ files ++ postFiles T.intercalate "\n" $ lns ++ [""] includePreamble :: T.Text includePreamble = "### Generated by hledger-flow - DO NOT EDIT ###\n" -groupAndWriteIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [TurtlePath] -> IO [TurtlePath] +groupAndWriteIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> IO [FilePath] groupAndWriteIncludeFiles opts ch = writeFileMap opts ch . groupIncludeFiles -writeFileMap :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> (TurtleFileBundle, TurtleFileBundle) -> IO [TurtlePath] +writeFileMap :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> (TurtleFileBundle, TurtleFileBundle) -> IO [FilePath] writeFileMap opts ch (m, allYears) = do _ <- writeFiles' $ (addPreamble . toIncludeFiles' Map.empty Map.empty) allYears writeFiles . (toIncludeFiles opts ch) $ m -writeIncludesUpTo :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtlePath -> [TurtlePath] -> IO [TurtlePath] -writeIncludesUpTo _ _ _ [] = return [] -writeIncludesUpTo opts ch stopAt journalFiles = do - let shouldStop = any (\dir -> dir == stopAt) $ map Turtle.parent journalFiles - if shouldStop - then return journalFiles - else do - newJournalFiles <- groupAndWriteIncludeFiles opts ch journalFiles - writeIncludesUpTo opts ch stopAt newJournalFiles +writeIncludesUpTo :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> AbsDir -> [AbsFile] -> IO [AbsFile] +writeIncludesUpTo opts ch stopAt journals = do + let base = baseDir opts + journalFiles = filter (isJournalFile . Path.toFilePath) journals + boundary <- Path.stripProperPrefix base stopAt + unless (all (Path.isProperPrefixOf stopAt) journalFiles) $ + ioError (userError "Journal file outside the requested include directory") + inputs <- mapM (Path.stripProperPrefix base) journalFiles + let groups = groupIncludesUpTo boundary inputs + absolute file = Path.toFilePath (base Path. file) + includes = Map.mapKeys absolute (Map.map (map absolute) groups) + years = yearsIncludeMap (Map.keys includes) + allAtStop = Path.toFilePath stopAt allYearsFileName + _ <- writeFileMap opts ch (includes, Map.insertWith (++) allAtStop [] years) + return [base Path. f | f <- Map.keys groups, Path.parent f == boundary] -writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [TurtlePath] +writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath] writeToplevelAllYearsInclude opts = do - directivesExists <- Turtle.testfile (directivesFile opts) - let preMap = if directivesExists then Map.singleton (turtleBaseDir opts allYearsFileName) [directivesFile opts] else Map.empty + let directives = directivesFile opts + directivesExists <- PathIO.doesFileExist directives + let preMap = if directivesExists then Map.singleton (turtleBaseDir opts allYearsFileName) [Path.toFilePath directives] else Map.empty let allTop = Map.singleton (turtleBaseDir opts allYearsFileName) ["import" allYearsFileName] writeFiles' $ (addPreamble . toIncludeFiles' preMap Map.empty) allTop -extraIncludes :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [TurtlePath] -> [T.Text] -> [TurtlePath] -> [TurtlePath] -> IO TurtleFileBundle +extraIncludes :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle extraIncludes opts ch = extraIncludes' opts ch Map.empty -extraIncludes' :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> [TurtlePath] -> [T.Text] -> [TurtlePath] -> [TurtlePath] -> IO TurtleFileBundle +extraIncludes' :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> [FilePath] -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle extraIncludes' _ _ acc [] _ _ _ = return acc extraIncludes' opts ch acc (file : files) extraSuffixes manualFiles prices = do extra <- extraIncludesForFile opts ch file extraSuffixes manualFiles prices extraIncludes' opts ch (Map.unionWith (++) acc extra) files extraSuffixes manualFiles prices -extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> TurtlePath -> [T.Text] -> [TurtlePath] -> [TurtlePath] -> IO TurtleFileBundle +extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle extraIncludesForFile opts ch file extraSuffixes manualFiles prices = do - let dirprefix = T.unpack $ fst $ T.breakOn "-" $ Turtle.format Turtle.fp $ Turtle.basename file - let fileNames = map (T.unpack . Turtle.format (Turtle.fp % "-" % Turtle.s) dirprefix) extraSuffixes - let suffixFiles = map (Turtle.directory file ) fileNames - let suffixDirFiles = map (((Turtle.directory file "_manual_") dirprefix) ) manualFiles - let priceFiles = map ((((Turtle.directory file "..") "prices") dirprefix) ) prices + let name = FilePath.takeFileName file + stem = if "." `List.isPrefixOf` name then name else FilePath.dropExtensions name + dirprefix = takeWhile (/= '-') stem + fileNames = [dirprefix ++ "-" ++ T.unpack suffix | suffix <- extraSuffixes] + let suffixFiles = map (FilePath.takeDirectory file ) fileNames + let suffixDirFiles = map (((FilePath.takeDirectory file "_manual_") dirprefix) ) manualFiles + let priceFiles = map ((((FilePath.takeDirectory file "..") "prices") dirprefix) ) prices let extraFiles = suffixFiles ++ suffixDirFiles ++ priceFiles - filtered <- Turtle.single $ filterPaths Turtle.testfile extraFiles + filtered <- filterPaths doesFileExist extraFiles let logMsg = - Turtle.format - ("Looking for possible extra include files for '" % Turtle.fp % "' among these " % Turtle.d % " options: " % Turtle.s % ". Found " % Turtle.d % ": " % Turtle.s) - (relativeToBase opts file) - (length extraFiles) - (Turtle.repr $ relativeFilesAsText opts extraFiles) - (length filtered) - (Turtle.repr $ relativeFilesAsText opts filtered) + "Looking for possible extra include files for '" <> T.pack (relativeToBase opts file) + <> "' among these " <> T.pack (show (length extraFiles)) <> " options: " + <> T.pack (show (relativeFilesAsText opts extraFiles)) + <> ". Found " <> T.pack (show (length filtered)) <> ": " + <> T.pack (show (relativeFilesAsText opts filtered)) logVerbose opts ch logMsg return $ Map.fromList [(file, filtered)] -relativeFilesAsText :: (HasBaseDir o) => o -> [TurtlePath] -> [T.Text] -relativeFilesAsText opts = map (Turtle.format Turtle.fp . relativeToBase opts) +relativeFilesAsText :: (HasBaseDir o) => o -> [FilePath] -> [T.Text] +relativeFilesAsText opts = map (T.pack . relativeToBase opts) diff --git a/src/Hledger/Flow/Import/Types.hs b/src/Hledger/Flow/Import/Types.hs --- a/src/Hledger/Flow/Import/Types.hs +++ b/src/Hledger/Flow/Import/Types.hs @@ -1,18 +1,19 @@ module Hledger.Flow.Import.Types where import qualified Data.Map.Strict as Map -import Hledger.Flow.PathHelpers (RelFile, TurtlePath) +import Hledger.Flow.PathHelpers (RelFile) +import Path (Dir, Path) -type TurtleFileBundle = Map.Map TurtlePath [TurtlePath] +type TurtleFileBundle = Map.Map FilePath [FilePath] type InputFileBundle = Map.Map RelFile [RelFile] -data ImportDirs = ImportDirs - { importDir :: TurtlePath, - ownerDir :: TurtlePath, - bankDir :: TurtlePath, - accountDir :: TurtlePath, - stateDir :: TurtlePath, - yearDir :: TurtlePath +data ImportDirs b = ImportDirs + { importDir :: Path b Dir, + ownerDir :: Path b Dir, + bankDir :: Path b Dir, + accountDir :: Path b Dir, + stateDir :: Path b Dir, + yearDir :: Path b Dir } - deriving (Show) + deriving (Eq, Show) diff --git a/src/Hledger/Flow/Logging.hs b/src/Hledger/Flow/Logging.hs --- a/src/Hledger/Flow/Logging.hs +++ b/src/Hledger/Flow/Logging.hs @@ -2,6 +2,7 @@ module Hledger.Flow.Logging where +import Control.Concurrent.Async (wait, withAsync) import Control.Concurrent.STM import Control.Monad (when) import qualified Data.Text as T @@ -9,8 +10,6 @@ import Data.Time.LocalTime (getZonedTime) import qualified GHC.IO.Handle.FD as H import Hledger.Flow.Types -import Turtle ((%)) -import qualified Turtle dummyLogger :: TChan LogMessage -> T.Text -> IO () dummyLogger _ _ = return () @@ -35,7 +34,16 @@ timestampPrefix :: T.Text -> IO T.Text timestampPrefix txt = do t <- getZonedTime - return $ Turtle.format (Turtle.s % "\thledger-flow " % Turtle.s) (Turtle.repr t) txt + return $ T.pack (show t) <> "\thledger-flow " <> txt + +withConsoleLogging :: (TChan LogMessage -> IO a) -> IO a +withConsoleLogging action = do + ch <- newTChanIO + withAsync (consoleChannelLoop ch) $ \logger -> do + result <- action ch + terminateChannelLoop ch + wait logger + return result consoleChannelLoop :: TChan LogMessage -> IO () consoleChannelLoop ch = do diff --git a/src/Hledger/Flow/PathHelpers.hs b/src/Hledger/Flow/PathHelpers.hs --- a/src/Hledger/Flow/PathHelpers.hs +++ b/src/Hledger/Flow/PathHelpers.hs @@ -3,15 +3,14 @@ module Hledger.Flow.PathHelpers where import Control.Monad.Catch (Exception, MonadThrow, throwM) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Text as T import Hledger.Flow.DocHelpers (docURL) import Path (()) import qualified Path import qualified Path.IO as Path -import qualified Turtle - -type TurtlePath = Turtle.FilePath +import System.Directory (doesDirectoryExist) +import qualified System.FilePath as FilePath type AbsFile = Path.Path Path.Abs Path.File @@ -21,7 +20,7 @@ type RelDir = Path.Path Path.Rel Path.Dir -data PathException = MissingBaseDir AbsDir | InvalidTurtleDir TurtlePath +data PathException = MissingBaseDir AbsDir | InvalidTurtleDir FilePath deriving (Eq) instance Show PathException where @@ -35,30 +34,30 @@ instance Exception PathException -fromTurtleAbsFile :: (MonadThrow m) => TurtlePath -> m AbsFile +fromTurtleAbsFile :: (MonadThrow m) => FilePath -> m AbsFile fromTurtleAbsFile turtlePath = Path.parseAbsFile turtlePath -fromTurtleRelFile :: (MonadThrow m) => TurtlePath -> m RelFile +fromTurtleRelFile :: (MonadThrow m) => FilePath -> m RelFile fromTurtleRelFile turtlePath = Path.parseRelFile turtlePath -fromTurtleAbsDir :: (MonadThrow m) => TurtlePath -> m AbsDir +fromTurtleAbsDir :: (MonadThrow m) => FilePath -> m AbsDir fromTurtleAbsDir turtlePath = Path.parseAbsDir turtlePath -fromTurtleRelDir :: (MonadThrow m) => TurtlePath -> m RelDir +fromTurtleRelDir :: (MonadThrow m) => FilePath -> m RelDir fromTurtleRelDir turtlePath = Path.parseRelDir turtlePath -turtleToAbsDir :: (MonadIO m, MonadThrow m) => AbsDir -> TurtlePath -> m AbsDir +turtleToAbsDir :: (MonadIO m, MonadThrow m) => AbsDir -> FilePath -> m AbsDir turtleToAbsDir baseDir p = do - isDir <- Turtle.testdir p + isDir <- liftIO (doesDirectoryExist p) if isDir then Path.resolveDir baseDir p else throwM $ InvalidTurtleDir p -pathToTurtle :: Path.Path b t -> TurtlePath +pathToTurtle :: Path.Path b t -> FilePath pathToTurtle = Path.toFilePath -forceTrailingSlash :: TurtlePath -> TurtlePath -forceTrailingSlash p = Turtle.directory (p Turtle. "temp") +forceTrailingSlash :: FilePath -> FilePath +forceTrailingSlash = FilePath.addTrailingPathSeparator . FilePath.normalise pathSize :: Path.Path b Path.Dir -> Int pathSize p = pathSize' p 0 @@ -78,9 +77,12 @@ AbsDir -> -- | Absolute paths to all files in the directories which match the predicate m [AbsFile] -findFilesIn includePred excludeDirs = Path.walkDirAccum (Just excludeHandler) accumulator +findFilesIn includePred excludeDirs = findFilesInWith includePred (const excludeDirs) + +findFilesInWith :: MonadIO m => (AbsDir -> Bool) -> (AbsDir -> [RelDir]) -> AbsDir -> m [AbsFile] +findFilesInWith includePred excludeDirs = Path.walkDirAccum (Just excludeHandler) accumulator where - excludeHandler currentDir _ _ = return $ Path.WalkExclude (map (currentDir ) excludeDirs) + excludeHandler currentDir _ _ = return $ Path.WalkExclude (map (currentDir ) (excludeDirs currentDir)) accumulator currentDir _ files = if includePred currentDir then return $ excludeHiddenFiles files diff --git a/src/Hledger/Flow/Reports.hs b/src/Hledger/Flow/Reports.hs --- a/src/Hledger/Flow/Reports.hs +++ b/src/Hledger/Flow/Reports.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Hledger.Flow.Reports ( generateReports, @@ -6,58 +7,59 @@ where import Control.Concurrent.STM +import Control.Monad (unless, when) +import Data.Char (toLower) import Data.Either import qualified Data.List as List import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T -import Hledger.Flow.BaseDir (relativeToBase, turtleBaseDir) +import Hledger.Flow.DateTime (timeAction) +import Hledger.Flow.BaseDir (relativeToBase) import Hledger.Flow.Common import Hledger.Flow.Logging -import Hledger.Flow.PathHelpers (TurtlePath, pathToTurtle) +import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelDir, RelFile) import Hledger.Flow.RuntimeOptions import qualified Hledger.Flow.Types as FlowTypes -import Turtle ((%), (<.>), ()) -import qualified Turtle as Turtle hiding (proc, stderr, stdout) +import Path ((), parent, reldir, relfile, parseRelDir, toFilePath) +import qualified Path.IO as PathIO +import qualified System.Directory as Directory +import System.Environment (lookupEnv) import Prelude hiding (putStrLn, readFile, writeFile) data ReportParams = ReportParams - { ledgerFile :: TurtlePath, + { ledgerFile :: FilePath, reportYears :: [Integer], - outputDir :: TurtlePath + outputDir :: AbsDir } deriving (Show) -type ReportGenerator = RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> TurtlePath -> Integer -> IO (Either TurtlePath TurtlePath) +type ReportGenerator = RuntimeOptions -> TChan FlowTypes.LogMessage -> FilePath -> AbsDir -> Integer -> IO (Either AbsFile AbsFile) generateReports :: RuntimeOptions -> IO () -generateReports opts = - Turtle.sh - ( do - ch <- Turtle.liftIO newTChanIO - logHandle <- Turtle.fork $ consoleChannelLoop ch - Turtle.liftIO $ if (showOptions opts) then channelOutLn ch (Turtle.repr opts) else return () - (reports, diff) <- Turtle.time $ Turtle.liftIO $ generateReports' opts ch - let failedAttempts = lefts reports - let failedText = if List.null failedAttempts then "" else Turtle.format ("(and attempted to write " % Turtle.d % " more) ") $ length failedAttempts - Turtle.liftIO $ channelOutLn ch $ Turtle.format ("Generated " % Turtle.d % " reports " % Turtle.s % "in " % Turtle.s) (length (rights reports)) failedText $ Turtle.repr diff - Turtle.liftIO $ terminateChannelLoop ch - Turtle.wait logHandle - ) +generateReports opts = withConsoleLogging $ \ch -> do + when (showOptions opts) $ channelOutLn ch (T.pack (show opts)) + (reports, diff) <- timeAction $ generateReports' opts ch + let failedAttempts = lefts reports + let failedText = if List.null failedAttempts then "" else "(and attempted to write " <> T.pack (show (length failedAttempts)) <> " more) " + channelOutLn ch $ "Generated " <> T.pack (show (length (rights reports))) <> " reports " <> failedText <> "in " <> T.pack (show diff) -generateReports' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [Either TurtlePath TurtlePath] +generateReports' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [Either AbsFile AbsFile] generateReports' opts ch = do let wipMsg = "These reports can be used as a starting point for more tailored reports.\n" <> "The first line of each report contains the command used - change the parameters and use it in your own reports.\n" channelOutLn ch wipMsg - owners <- Turtle.single $ shellToList $ listOwners opts - ledgerEnvValue <- Turtle.need "LEDGER_FILE" :: IO (Maybe T.Text) - let hledgerJournal = fromMaybe (turtleBaseDir opts allYearsFileName) $ fmap T.unpack ledgerEnvValue - hledgerJournalExists <- Turtle.testfile hledgerJournal - _ <- if not hledgerJournalExists then Turtle.die $ Turtle.format ("Unable to find journal file: " % Turtle.fp % "\nIs your LEDGER_FILE environment variable set correctly?") hledgerJournal else return () - let journalWithYears = journalFile opts [] - let aggregateReportDir = outputReportDir opts ["all"] + owners <- listOwners opts + ledgerEnvValue <- lookupEnv "LEDGER_FILE" + let hledgerJournal = fromMaybe (toFilePath (baseDir opts [relfile|all-years.journal|])) ledgerEnvValue + hledgerJournalExists <- Directory.doesFileExist hledgerJournal + unless hledgerJournalExists $ ioError $ userError $ + "Unable to find journal file: " ++ hledgerJournal ++ "\nIs your LEDGER_FILE environment variable set correctly?" + let journalWithYears = baseDir opts [relfile|import/all-years.journal|] + let aggregateReportDir + | any ((== toFilePath [reldir|all|]) . map toLower . toFilePath) owners = baseDir opts [reldir|reports/_all_|] + | otherwise = baseDir opts [reldir|reports/all|] aggregateYears <- includeYears ch journalWithYears let aggregateParams = ReportParams @@ -73,7 +75,7 @@ let ownerOnlyReports = List.concat $ fmap (reportActions opts ch [accountList, unknownTransactions]) ownerParams parAwareActions opts (aggregateOnlyReports ++ ownerWithAggregateReports ++ ownerOnlyReports) -reportActions :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [ReportGenerator] -> ReportParams -> [IO (Either TurtlePath TurtlePath)] +reportActions :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [ReportGenerator] -> ReportParams -> [IO (Either AbsFile AbsFile)] reportActions opts ch reports (ReportParams journal years reportsDir) = do y <- years map (\r -> r opts ch journal reportsDir y) reports @@ -81,69 +83,65 @@ accountList :: ReportGenerator accountList opts ch journal baseOutDir year = do let reportArgs = ["accounts"] - generateReport opts ch journal year (baseOutDir intPath year) ("accounts" <.> "txt") reportArgs (not . T.null) + generateReport opts ch journal year baseOutDir [relfile|accounts.txt|] reportArgs (not . T.null) unknownTransactions :: ReportGenerator unknownTransactions opts ch journal baseOutDir year = do let reportArgs = ["print", "unknown"] - generateReport opts ch journal year (baseOutDir intPath year) ("unknown-transactions" <.> "txt") reportArgs (not . T.null) + generateReport opts ch journal year baseOutDir [relfile|unknown-transactions.txt|] reportArgs (not . T.null) incomeStatement :: [T.Text] -> ReportGenerator incomeStatement sharedOptions opts ch journal baseOutDir year = do let reportArgs = ["incomestatement"] ++ sharedOptions - generateReport opts ch journal year (baseOutDir intPath year) ("income-expenses" <.> "txt") reportArgs (not . T.null) + generateReport opts ch journal year baseOutDir [relfile|income-expenses.txt|] reportArgs (not . T.null) incomeMonthlyStatement :: [T.Text] -> ReportGenerator incomeMonthlyStatement sharedOptions opts ch journal baseOutDir year = do let reportArgs = ["incomestatement"] ++ sharedOptions ++ ["--monthly"] - generateReport opts ch journal year (baseOutDir intPath year "monthly") ("income-expenses" <.> "txt") reportArgs (not . T.null) + generateReport opts ch journal year baseOutDir [relfile|monthly/income-expenses.txt|] reportArgs (not . T.null) balanceSheet :: [T.Text] -> ReportGenerator balanceSheet sharedOptions opts ch journal baseOutDir year = do let reportArgs = ["balancesheet"] ++ sharedOptions ++ ["--flat"] - generateReport opts ch journal year (baseOutDir intPath year) ("balance-sheet" <.> "txt") reportArgs (not . T.null) + generateReport opts ch journal year baseOutDir [relfile|balance-sheet.txt|] reportArgs (not . T.null) transferBalance :: ReportGenerator transferBalance opts ch journal baseOutDir year = do let reportArgs = ["balance"] ++ (if prettyReports opts then ["--pretty-tables"] else []) ++ ["--quarterly", "--flat", "--no-total", "transfer"] - generateReport opts ch journal year (baseOutDir intPath year) ("transfer-balance" <.> "txt") reportArgs (\txt -> (length $ T.lines txt) > 4) + generateReport opts ch journal year baseOutDir [relfile|transfer-balance.txt|] reportArgs (\txt -> (length $ T.lines txt) > 4) -generateReport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Integer -> TurtlePath -> TurtlePath -> [T.Text] -> (T.Text -> Bool) -> IO (Either TurtlePath TurtlePath) +generateReport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> FilePath -> Integer -> AbsDir -> RelFile -> [T.Text] -> (T.Text -> Bool) -> IO (Either AbsFile AbsFile) generateReport opts ch journal year reportsDir fileName args successCheck = do - Turtle.mktree reportsDir - let outputFile = reportsDir fileName + yearDir <- parseRelDir (show year) + let outputFile = reportsDir yearDir fileName + PathIO.createDirIfMissing True (parent outputFile) let relativeJournal = relativeToBase opts journal - let relativeOutputFile = relativeToBase opts outputFile + let relativeOutputFile = relativeToBase opts (toFilePath outputFile) let confArgs = hledgerConfArgs opts - let reportArgs = confArgs ++ ["--file", Turtle.format Turtle.fp journal, "--period", Turtle.repr year] ++ args - let reportDisplayArgs = confArgs ++ ["--file", Turtle.format Turtle.fp relativeJournal, "--period", Turtle.repr year] ++ args - let hledger = Turtle.format Turtle.fp $ pathToTurtle . FlowTypes.hlPath . hledgerInfo $ opts :: T.Text - let cmdLabel = Turtle.format ("hledger " % Turtle.s) $ showCmdArgs reportDisplayArgs - ((exitCode, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr Turtle.procStrictWithErr (hledger, reportArgs, mempty) + let reportArgs = confArgs ++ ["--file", T.pack journal, "--period", T.pack (show year)] ++ args + let reportDisplayArgs = confArgs ++ ["--file", T.pack relativeJournal, "--period", T.pack (show year)] ++ args + let hledger = T.pack (toFilePath (FlowTypes.hlPath (hledgerInfo opts))) + let cmdLabel = "hledger " <> showCmdArgs reportDisplayArgs + ((exitCode, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr (hledger, reportArgs, Nothing) if (successCheck stdOut) then do - T.writeFile outputFile (cmdLabel <> "\n\n" <> stdOut) - logVerbose opts ch $ Turtle.format ("Wrote " % Turtle.fp) $ relativeOutputFile + T.writeFile (toFilePath outputFile) (cmdLabel <> "\n\n" <> stdOut) + logVerbose opts ch $ "Wrote " <> T.pack relativeOutputFile return $ Right outputFile else do - channelErrLn ch $ Turtle.format ("Did not write '" % Turtle.fp % "' (" % Turtle.s % ") " % Turtle.s) relativeOutputFile cmdLabel (Turtle.repr exitCode) - exists <- Turtle.testfile outputFile - if exists then Turtle.rm outputFile else return () + channelErrLn ch $ "Did not write '" <> T.pack relativeOutputFile <> "' (" <> cmdLabel <> ") " <> T.pack (show exitCode) + exists <- PathIO.doesFileExist outputFile + when exists (PathIO.removeFile outputFile) return $ Left outputFile -journalFile :: RuntimeOptions -> [TurtlePath] -> TurtlePath -journalFile opts dirs = (foldl () (turtleBaseDir opts) ("import" : dirs)) allYearsFileName - -outputReportDir :: RuntimeOptions -> [TurtlePath] -> TurtlePath -outputReportDir opts dirs = foldl () (turtleBaseDir opts) ("reports" : dirs) - -ownerParameters :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [TurtlePath] -> IO [ReportParams] +ownerParameters :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [RelDir] -> IO [ReportParams] ownerParameters opts ch owners = do let actions = map (ownerParameters' opts ch) owners parAwareActions opts actions -ownerParameters' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> IO ReportParams +ownerParameters' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> RelDir -> IO ReportParams ownerParameters' opts ch owner = do - let ownerJournal = journalFile opts [owner] + let ownerJournal = baseDir opts [reldir|import|] owner [relfile|all-years.journal|] + reportsDir = baseDir opts [reldir|reports|] owner years <- includeYears ch ownerJournal - return $ ReportParams ownerJournal years (outputReportDir opts [owner]) + return $ ReportParams (toFilePath ownerJournal) years reportsDir diff --git a/src/Hledger/Flow/RuntimeOptions.hs b/src/Hledger/Flow/RuntimeOptions.hs --- a/src/Hledger/Flow/RuntimeOptions.hs +++ b/src/Hledger/Flow/RuntimeOptions.hs @@ -2,7 +2,6 @@ import qualified Data.Text as T import Hledger.Flow.Internals (SystemInfo) -import Hledger.Flow.PathHelpers (TurtlePath) import Hledger.Flow.Types import Prelude hiding (putStrLn) @@ -13,7 +12,7 @@ onlyNewFiles :: Bool, hfVersion :: T.Text, hledgerInfo :: HledgerInfo, - hledgerConf :: Maybe TurtlePath, + hledgerConf :: Maybe FilePath, sysInfo :: SystemInfo, verbose :: Bool, showOptions :: Bool, diff --git a/src/Hledger/Flow/Types.hs b/src/Hledger/Flow/Types.hs --- a/src/Hledger/Flow/Types.hs +++ b/src/Hledger/Flow/Types.hs @@ -4,7 +4,9 @@ import qualified Data.Text as T import Hledger.Flow.PathHelpers -import qualified Turtle (ExitCode, Line, NominalDiffTime, Shell) +import Data.Time.Clock (NominalDiffTime) +import System.Exit (ExitCode) +import System.IO (Handle) type BaseDir = AbsDir @@ -12,13 +14,11 @@ data LogMessage = StdOut T.Text | StdErr T.Text | Terminate deriving (Show) -type FullOutput = (Turtle.ExitCode, T.Text, T.Text) - -type FullTimedOutput = (FullOutput, Turtle.NominalDiffTime) +type FullOutput = (ExitCode, T.Text, T.Text) -type ProcFun = T.Text -> [T.Text] -> Turtle.Shell Turtle.Line -> IO FullOutput +type FullTimedOutput = (FullOutput, NominalDiffTime) -type ProcInput = (T.Text, [T.Text], Turtle.Shell Turtle.Line) +type ProcInput = (T.Text, [T.Text], Maybe Handle) data HledgerInfo = HledgerInfo { hlPath :: AbsFile, diff --git a/test/BaseDir/Integration.hs b/test/BaseDir/Integration.hs --- a/test/BaseDir/Integration.hs +++ b/test/BaseDir/Integration.hs @@ -8,13 +8,12 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Hledger.Flow.BaseDir (determineBaseDir, effectiveRunDir) -import Hledger.Flow.Common import Hledger.Flow.PathHelpers import Hledger.Flow.Types (BaseDir, RunDir) import Path import Path.IO import Test.HUnit -import qualified Turtle +import TestHelpers (testRoot) import Prelude hiding (readFile, writeFile) assertSubDirsForDetermineBaseDir :: AbsDir -> BaseDir -> [Path.Path b Dir] -> IO () @@ -44,10 +43,10 @@ assertFindTestFileUsingRundir :: BaseDir -> RunDir -> IO () assertFindTestFileUsingRundir baseDir runDir = do let absRunDir = baseDir runDir - foundFiles <- Turtle.single $ shellToList $ Turtle.find (Turtle.has "test-file.txt") $ pathToTurtle absRunDir - case foundFiles of + foundFiles <- findFilesIn (const True) [] absRunDir + case filter ((== [relfile|test-file.txt|]) . filename) foundFiles of (found : _) -> do - fileContents <- T.readFile found + fileContents <- T.readFile (toFilePath found) assertEqual "We should find our test file by searching from the returned runDir" (T.pack $ "The expected base dir is " ++ show baseDir) fileContents [] -> assertFailure "Expected to find test-file.txt but search returned no results" @@ -98,7 +97,10 @@ let absoluteBaseDir = absoluteTempDir baseDir - T.writeFile (pathToTurtle $ absoluteTempDir yearDir [relfile|test-file.txt|]) (T.pack $ "The expected base dir is " ++ show absoluteBaseDir) + let file = toFilePath (absoluteTempDir yearDir [relfile|test-file.txt|]) + T.writeFile file (T.pack $ "The expected base dir is " ++ show absoluteBaseDir) + fileResult <- try $ determineBaseDir (Just file) + assertEqual "An existing file cannot be used as the base directory" (Left (InvalidTurtleDir file)) fileResult assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir subDirs assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir absoluteSubDirs @@ -153,7 +155,7 @@ testEffectiveRunDir = TestCase ( do - let base = [absdir|/tmp/hlflow-base|] + let base = testRoot [reldir|tmp/hlflow-base|] let expectedBaseImport = base [reldir|import|] assertEqual "A runDir of '.' should map to base/import" expectedBaseImport (effectiveRunDir base [reldir|.|]) diff --git a/test/CSVImport/ImportHelperTests.hs b/test/CSVImport/ImportHelperTests.hs --- a/test/CSVImport/ImportHelperTests.hs +++ b/test/CSVImport/ImportHelperTests.hs @@ -4,12 +4,46 @@ module CSVImport.ImportHelperTests where -import Hledger.Flow.Import.ImportHelpers (groupIncludesUpTo, includeFileName) -import Hledger.Flow.Import.Types (InputFileBundle) +import qualified Data.Text as T +import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.Import.ImportHelpers (extractImportDirs, groupIncludesUpTo, includeFileName) +import Hledger.Flow.Import.Types (ImportDirs (..), InputFileBundle) import Path -import Test.HUnit +import Test.HUnit hiding (Path) import TestHelpers +testExtractImportDirs :: Test +testExtractImportDirs = TestList + [ TestCase $ check [reldir|.|], + TestCase $ check (testRoot [reldir|finance|]) + ] + where + check :: Path b Dir -> Assertion + check base = do + let root = base [reldir|import|] + owner = root [reldir|john|] + bank = owner [reldir|mybank|] + account = bank [reldir|checking|] + state = account [reldir|1-in|] + year = state [reldir|2019|] + statement = year [relfile|2019-01-01.csv|] + assertEqual "statement directories" + (Right (ImportDirs root owner bank account state year)) (extractImportDirs statement) + checkMalformed (account [relfile|2019-01-01.csv|]) + checkMalformed (year [relfile|extra/2019-01-01.csv|]) + checkMalformed (base [relfile|outside/john/mybank/checking/1-in/2019/statement.csv|]) + + checkMalformed file = + case extractImportDirs file of + Right _ -> assertFailure "expected malformed import layout to be rejected" + Left err -> assertEqual "malformed layout diagnostic" + ("I couldn't find the right number of directories between \"import\" and the input file:\n" + <> T.pack (toFilePath file) + <> "\n\nhledger-flow expects to find input files in this structure:\n" + <> "import/owner/bank/account/filestate/year/trxfile\n\n" + <> "Have a look at the documentation for a detailed explanation:\n" + <> docURL "input-files") err + testToJournal :: Test testToJournal = TestCase @@ -112,4 +146,4 @@ ) tests :: Test -tests = TestList [testToJournal, testIncludeFileName, testGroupIncludesUpToTinySet, testGroupIncludesUpToSmallSet, testGroupIncludesUpTo] +tests = TestList [testExtractImportDirs, testToJournal, testIncludeFileName, testGroupIncludesUpToTinySet, testGroupIncludesUpToSmallSet, testGroupIncludesUpTo] diff --git a/test/CSVImport/ImportHelperTurtleTests.hs b/test/CSVImport/ImportHelperTurtleTests.hs --- a/test/CSVImport/ImportHelperTurtleTests.hs +++ b/test/CSVImport/ImportHelperTurtleTests.hs @@ -9,14 +9,11 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import Hledger.Flow.Common -import Hledger.Flow.Import.ImportHelpersTurtle (allYearIncludeFiles, extractImportDirs, groupIncludeFiles, toIncludeFiles, toIncludeLine, yearsIncludeMap) -import Hledger.Flow.Import.Types (ImportDirs (..), TurtleFileBundle) -import Hledger.Flow.PathHelpers (TurtlePath) -import Path +import Hledger.Flow.Import.ImportHelpersTurtle (allYearIncludeFiles, groupIncludeFiles, toIncludeFiles, toIncludeLine, yearsIncludeMap) +import Hledger.Flow.Import.Types (TurtleFileBundle) import Test.HUnit -import TestHelpers (defaultOpts) +import TestHelpers (defaultOpts, testRoot) import TestHelpersTurtle -import Turtle groupedJaneBogart :: TurtleFileBundle groupedJaneBogart = @@ -566,67 +563,32 @@ let expected = [ ( "./import/john/bogartbank/checking/2018-include.journal", "### Generated by hledger-flow - DO NOT EDIT ###\n\n" - <> "include import/john/bogartbank/checking/3-journal/2018/2018-10-30.journal\n" - <> "include import/john/bogartbank/checking/3-journal/2018/2018-11-30.journal\n" - <> "include import/john/bogartbank/checking/3-journal/2018/2018-12-30.journal\n" + <> "include 3-journal/2018/2018-10-30.journal\n" + <> "include 3-journal/2018/2018-11-30.journal\n" + <> "include 3-journal/2018/2018-12-30.journal\n" ), ( "./import/john/bogartbank/checking/2019-include.journal", "### Generated by hledger-flow - DO NOT EDIT ###\n\n" - <> "include import/john/bogartbank/checking/3-journal/2019/2019-01-30.journal\n" - <> "include import/john/bogartbank/checking/3-journal/2019/2019-02-30.journal\n" + <> "include 3-journal/2019/2019-01-30.journal\n" + <> "include 3-journal/2019/2019-02-30.journal\n" ), ( "./import/john/bogartbank/savings/2017-include.journal", "### Generated by hledger-flow - DO NOT EDIT ###\n\n" - <> "include import/john/bogartbank/savings/3-journal/2017/2017-11-30.journal\n" - <> "include import/john/bogartbank/savings/3-journal/2017/2017-12-30.journal\n" + <> "include 3-journal/2017/2017-11-30.journal\n" + <> "include 3-journal/2017/2017-12-30.journal\n" ), ( "./import/john/bogartbank/savings/2018-include.journal", "### Generated by hledger-flow - DO NOT EDIT ###\n\n" - <> "include import/john/bogartbank/savings/3-journal/2018/2018-01-30.journal\n" - <> "include import/john/bogartbank/savings/3-journal/2018/2018-02-30.journal\n" + <> "include 3-journal/2018/2018-01-30.journal\n" + <> "include 3-journal/2018/2018-02-30.journal\n" ) ] ch <- newTChanIO - txt <- toIncludeFiles (defaultOpts [absdir|/|]) ch groupedJohnBogart + txt <- toIncludeFiles (defaultOpts testRoot) ch groupedJohnBogart assertEqual "Convert a grouped map of paths, to a map with text contents for each file" expected txt ) -testExtractImportDirsSuccess :: Test -testExtractImportDirsSuccess = - TestCase - ( do - let file = "import/john/mybank/checking/1-in/2019/2019-01-01.csv" - case extractImportDirs file of - Left err -> assertFailure (T.unpack err) - Right dirs -> do - let expectedYear = Turtle.directory file - let expectedState = Turtle.parent expectedYear - let expectedAccount = Turtle.parent expectedState - let expectedBank = Turtle.parent expectedAccount - let expectedOwner = Turtle.parent expectedBank - let expectedImport = Turtle.parent expectedOwner - assertEqual "importDir" expectedImport (importDir dirs) - assertEqual "ownerDir" expectedOwner (ownerDir dirs) - assertEqual "bankDir" expectedBank (bankDir dirs) - assertEqual "accountDir" expectedAccount (accountDir dirs) - assertEqual "stateDir" expectedState (stateDir dirs) - assertEqual "yearDir" expectedYear (yearDir dirs) - ) - -testExtractImportDirsFailure :: Test -testExtractImportDirsFailure = - TestCase - ( do - let badFile = "import/john/mybank/checking/2019-01-01.csv" - case extractImportDirs badFile of - Left err -> - assertBool - "Error should explain expected structure" - ("expects to find input files in this structure" `T.isInfixOf` err) - Right _ -> assertFailure "Expected failure for malformed import path" - ) - testGroupIncludeFilesFiltersNonJournal :: Test testGroupIncludeFilesFiltersNonJournal = TestCase @@ -650,7 +612,5 @@ testIncludeYears, testToIncludeLine, testToIncludeFiles, - testExtractImportDirsSuccess, - testExtractImportDirsFailure, testGroupIncludeFilesFiltersNonJournal ] diff --git a/test/CSVImport/Integration.hs b/test/CSVImport/Integration.hs --- a/test/CSVImport/Integration.hs +++ b/test/CSVImport/Integration.hs @@ -7,356 +7,318 @@ import qualified Data.List as List (sort) import qualified Data.Map.Strict as Map import qualified Data.Text.IO as T -import Hledger.Flow.Common import Hledger.Flow.Import.ImportHelpersTurtle (extraIncludesForFile, groupAndWriteIncludeFiles, includePreamble, toIncludeFiles, writeIncludesUpTo, writeToplevelAllYearsInclude) import Hledger.Flow.PathHelpers +import qualified Path +import qualified Path.IO as PathIO +import Data.Either (isLeft) +import System.IO.Error (tryIOError) +import System.FilePath (()) +import qualified System.FilePath as FilePath import Test.HUnit -import TestHelpers (defaultOpts) +import TestHelpers (defaultOpts, withTestDir) import TestHelpersTurtle (extraFiles, hiddenFiles, journalFiles, touchAll) -import Turtle import Prelude hiding (readFile, writeFile) testExtraIncludesForFile :: Test testExtraIncludesForFile = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let importedJournals = map (tmpdir ) journalFiles :: [TurtlePath] - let accountDir = "import/john/bogartbank/savings" - let opening = tmpdir accountDir "2017-opening.journal" - let closing = tmpdir accountDir "2017-closing.journal" - let hidden = map (tmpdir ) hiddenFiles :: [TurtlePath] - touchAll $ importedJournals ++ hidden + let importedJournals = map (tmpdir ) journalFiles :: [FilePath] + let accountDir = "import/john/bogartbank/savings" + let opening = tmpdir accountDir "2017-opening.journal" + let closing = tmpdir accountDir "2017-closing.journal" + let hidden = map (tmpdir ) hiddenFiles :: [FilePath] + touchAll $ importedJournals ++ hidden - let accountInclude = tmpdir accountDir "2017-include.journal" - let expectedEmpty = [(accountInclude, [])] + let accountInclude = tmpdir accountDir "2017-include.journal" + let expectedEmpty = [(accountInclude, [])] - ch <- liftIO newTChanIO + ch <- newTChanIO - extraOpening1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["opening.journal"] [] [] - liftIO $ assertEqual "The opening journal should not be included when it is not on disk" expectedEmpty extraOpening1 + extraOpening1 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["opening.journal"] [] [] + assertEqual "The opening journal should not be included when it is not on disk" expectedEmpty extraOpening1 - extraClosing1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["closing.journal"] [] [] - liftIO $ assertEqual "The closing journal should not be included when it is not on disk" expectedEmpty extraClosing1 + extraClosing1 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["closing.journal"] [] [] + assertEqual "The closing journal should not be included when it is not on disk" expectedEmpty extraClosing1 - touchAll [opening, closing] + touchAll [opening, closing] - extraOpening2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["opening.journal"] [] [] - liftIO $ assertEqual "The opening journal should be included when it is on disk" [(accountInclude, [opening])] extraOpening2 + extraOpening2 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["opening.journal"] [] [] + assertEqual "The opening journal should be included when it is on disk" [(accountInclude, [FilePath.normalise opening])] (Map.map (map FilePath.normalise) extraOpening2) - extraClosing2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["closing.journal"] [] [] - liftIO $ assertEqual "The closing journal should be included when it is on disk" [(accountInclude, [closing])] extraClosing2 - ) - ) + extraClosing2 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch accountInclude ["closing.journal"] [] [] + assertEqual "The closing journal should be included when it is on disk" [(accountInclude, [FilePath.normalise closing])] (Map.map (map FilePath.normalise) extraClosing2) testExtraIncludesPrices :: Test testExtraIncludesPrices = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let importedJournals = map (tmpdir ) journalFiles :: [TurtlePath] - touchAll $ importedJournals + let importedJournals = map (tmpdir ) journalFiles :: [FilePath] + touchAll $ importedJournals - let priceFile = "prices" "2020" "prices.journal" + let priceFile = "prices" "2020" "prices.journal" - let includeFile = tmpdir "import" "2020-include.journal" - let expectedEmpty = [(includeFile, [])] + let includeFile = tmpdir "import" "2020-include.journal" + let expectedEmpty = [(includeFile, [])] - ch <- liftIO newTChanIO + ch <- newTChanIO - price1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch includeFile [] [] ["prices.journal"] - liftIO $ assertEqual "The price file should not be included when it is not on disk" expectedEmpty price1 + price1 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch includeFile [] [] ["prices.journal"] + assertEqual "The price file should not be included when it is not on disk" expectedEmpty price1 - touchAll [tmpdir priceFile] - let expectedPricePath = tmpdir "import" ".." priceFile + touchAll [tmpdir priceFile] + let expectedPricePath = tmpdir "import" ".." priceFile - price2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdirAbsPath) ch includeFile [] [] ["prices.journal"] - liftIO $ assertEqual "The price file should be included when it is on disk" [(includeFile, [expectedPricePath])] price2 - ) - ) + price2 <- extraIncludesForFile (defaultOpts tmpdirAbsPath) ch includeFile [] [] ["prices.journal"] + assertEqual "The price file should be included when it is on disk" [(includeFile, [FilePath.normalise expectedPricePath])] (Map.map (map FilePath.normalise) price2) testIncludesPrePost :: Test testIncludesPrePost = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let ownerDir = tmpdir "import" "john" - let includeFile = ownerDir "2019-include.journal" - let pre = ownerDir "_manual_" "2019" "pre-import.journal" - let post = ownerDir "_manual_" "2019" "post-import.journal" - touchAll [pre, post] + let ownerDir = tmpdir "import" "john" + let includeFile = ownerDir "2019-include.journal" + let pre = ownerDir "_manual_" "2019" "pre-import.journal" + let post = ownerDir "_manual_" "2019" "post-import.journal" + touchAll [pre, post] - let includeMap = - Map.singleton - includeFile - [ ownerDir "bank1" "2019-include.journal", - ownerDir "bank2" "2019-include.journal" - ] + let includeMap = + Map.singleton + includeFile + [ ownerDir "bank1" "2019-include.journal", + ownerDir "bank2" "2019-include.journal" + ] - ch <- liftIO newTChanIO - fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap - let expectedText = - includePreamble - <> "\n" - <> "include _manual_/2019/pre-import.journal\n" - <> "include bank1/2019-include.journal\n" - <> "include bank2/2019-include.journal\n" - <> "include _manual_/2019/post-import.journal\n" - let expectedMap = Map.singleton includeFile expectedText - liftIO $ assertEqual "All pre/post files on disk should be included" expectedMap fileMap - ) - ) + ch <- newTChanIO + fileMap <- toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap + let expectedText = + includePreamble + <> "\n" + <> "include _manual_/2019/pre-import.journal\n" + <> "include bank1/2019-include.journal\n" + <> "include bank2/2019-include.journal\n" + <> "include _manual_/2019/post-import.journal\n" + let expectedMap = Map.singleton includeFile expectedText + assertEqual "All pre/post files on disk should be included" expectedMap fileMap testIncludesOpeningClosing :: Test testIncludesOpeningClosing = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let ownerDir = tmpdir "import/john" - let accountDir = ownerDir "bank1" "savings" - let includeFile = accountDir "2019-include.journal" - let opening = accountDir "2019-opening.journal" - let closing = accountDir "2019-closing.journal" - touchAll [opening, closing] + let ownerDir = tmpdir "import/john" + let accountDir = ownerDir "bank1" "savings" + let includeFile = accountDir "2019-include.journal" + let opening = accountDir "2019-opening.journal" + let closing = accountDir "2019-closing.journal" + touchAll [opening, closing] - let includeMap = Map.singleton includeFile [accountDir "3-journal" "2019" "2019-01-30.journal"] + let includeMap = Map.singleton includeFile [accountDir "3-journal" "2019" "2019-01-30.journal"] - ch <- liftIO newTChanIO - fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap - let expectedText = - includePreamble - <> "\n" - <> "include 2019-opening.journal\n" - <> "include 3-journal/2019/2019-01-30.journal\n" - <> "include 2019-closing.journal\n" - let expectedMap = Map.singleton includeFile expectedText - liftIO $ assertEqual "All opening/closing files on disk should be included" expectedMap fileMap - ) - ) + ch <- newTChanIO + fileMap <- toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap + let expectedText = + includePreamble + <> "\n" + <> "include 2019-opening.journal\n" + <> "include 3-journal/2019/2019-01-30.journal\n" + <> "include 2019-closing.journal\n" + let expectedMap = Map.singleton includeFile expectedText + assertEqual "All opening/closing files on disk should be included" expectedMap fileMap testIncludesPrices :: Test testIncludesPrices = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let importDir = tmpdir "import" - let includeFile = importDir "2020-include.journal" - let prices = tmpdir "prices" "2020" "prices.journal" - let pre = importDir "_manual_" "2020" "pre-import.journal" - let post = importDir "_manual_" "2020" "post-import.journal" - touchAll [prices, pre, post] + let importDir = tmpdir "import" + let includeFile = importDir "2020-include.journal" + let prices = tmpdir "prices" "2020" "prices.journal" + let pre = importDir "_manual_" "2020" "pre-import.journal" + let post = importDir "_manual_" "2020" "post-import.journal" + touchAll [prices, pre, post] - let includeMap = Map.singleton includeFile [importDir "john" "2020-include.journal"] + let includeMap = Map.singleton includeFile [importDir "john" "2020-include.journal"] - ch <- liftIO newTChanIO - fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap - let expectedText = - includePreamble - <> "\n" - <> "include _manual_/2020/pre-import.journal\n" - <> "include john/2020-include.journal\n" - <> "include ../prices/2020/prices.journal\n" - <> "include _manual_/2020/post-import.journal\n" - let expectedMap = Map.singleton includeFile expectedText - liftIO $ assertEqual "The price file should be included together with any pre/post files" expectedMap fileMap - ) - ) + ch <- newTChanIO + fileMap <- toIncludeFiles (defaultOpts tmpdirAbsPath) ch includeMap + let expectedText = + includePreamble + <> "\n" + <> "include _manual_/2020/pre-import.journal\n" + <> "include john/2020-include.journal\n" + <> "include ../prices/2020/prices.journal\n" + <> "include _manual_/2020/post-import.journal\n" + let expectedMap = Map.singleton includeFile expectedText + assertEqual "The price file should be included together with any pre/post files" expectedMap fileMap testWriteIncludeFiles :: Test testWriteIncludeFiles = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let importedJournals = map (tmpdir ) journalFiles :: [TurtlePath] - let extras = map (tmpdir ) extraFiles :: [TurtlePath] - let hidden = map (tmpdir ) hiddenFiles :: [TurtlePath] - touchAll $ importedJournals ++ extras ++ hidden + let importedJournals = map (tmpdir ) journalFiles :: [FilePath] + let extras = map (tmpdir ) extraFiles :: [FilePath] + let hidden = map (tmpdir ) hiddenFiles :: [FilePath] + touchAll $ importedJournals ++ extras ++ hidden - let jane1 = tmpdir "import/jane/bogartbank/checking/2018-include.journal" - let jane2 = tmpdir "import/jane/bogartbank/checking/2019-include.journal" - let jane3 = tmpdir "import/jane/bogartbank/savings/2017-include.journal" - let jane4 = tmpdir "import/jane/bogartbank/savings/2018-include.journal" - let jane5 = tmpdir "import/jane/otherbank/creditcard/2017-include.journal" - let jane6 = tmpdir "import/jane/otherbank/creditcard/2018-include.journal" - let jane7 = tmpdir "import/jane/otherbank/investments/2018-include.journal" - let jane8 = tmpdir "import/jane/otherbank/investments/2019-include.journal" + let jane1 = tmpdir "import/jane/bogartbank/checking/2018-include.journal" + let jane2 = tmpdir "import/jane/bogartbank/checking/2019-include.journal" + let jane3 = tmpdir "import/jane/bogartbank/savings/2017-include.journal" + let jane4 = tmpdir "import/jane/bogartbank/savings/2018-include.journal" + let jane5 = tmpdir "import/jane/otherbank/creditcard/2017-include.journal" + let jane6 = tmpdir "import/jane/otherbank/creditcard/2018-include.journal" + let jane7 = tmpdir "import/jane/otherbank/investments/2018-include.journal" + let jane8 = tmpdir "import/jane/otherbank/investments/2019-include.journal" - let john1 = tmpdir "import/john/bogartbank/checking/2018-include.journal" - let john2 = tmpdir "import/john/bogartbank/checking/2019-include.journal" - let john3 = tmpdir "import/john/bogartbank/savings/2017-include.journal" - let john4 = tmpdir "import/john/bogartbank/savings/2018-include.journal" - let john5 = tmpdir "import/john/otherbank/creditcard/2017-include.journal" - let john6 = tmpdir "import/john/otherbank/creditcard/2018-include.journal" - let john7 = tmpdir "import/john/otherbank/investments/2018-include.journal" - let john8 = tmpdir "import/john/otherbank/investments/2019-include.journal" - let expectedIncludes = - [ jane1, - jane2, - jane3, - jane4, - jane5, - jane6, - jane7, - jane8, - john1, - john2, - john3, - john4, - john5, - john6, - john7, - john8 - ] + let john1 = tmpdir "import/john/bogartbank/checking/2018-include.journal" + let john2 = tmpdir "import/john/bogartbank/checking/2019-include.journal" + let john3 = tmpdir "import/john/bogartbank/savings/2017-include.journal" + let john4 = tmpdir "import/john/bogartbank/savings/2018-include.journal" + let john5 = tmpdir "import/john/otherbank/creditcard/2017-include.journal" + let john6 = tmpdir "import/john/otherbank/creditcard/2018-include.journal" + let john7 = tmpdir "import/john/otherbank/investments/2018-include.journal" + let john8 = tmpdir "import/john/otherbank/investments/2019-include.journal" + let expectedIncludes = + [ jane1, + jane2, + jane3, + jane4, + jane5, + jane6, + jane7, + jane8, + john1, + john2, + john3, + john4, + john5, + john6, + john7, + john8 + ] - ch <- liftIO newTChanIO - reportedAsWritten <- liftIO $ groupAndWriteIncludeFiles (defaultOpts tmpdirAbsPath) ch importedJournals - liftIO $ assertEqual "groupAndWriteIncludeFiles should return which files it wrote" expectedIncludes reportedAsWritten + ch <- newTChanIO + reportedAsWritten <- groupAndWriteIncludeFiles (defaultOpts tmpdirAbsPath) ch importedJournals + assertEqual "groupAndWriteIncludeFiles should return which files it wrote" expectedIncludes reportedAsWritten - let allYears = - [ tmpdir "import/jane/bogartbank/checking/all-years.journal", - tmpdir "import/jane/bogartbank/savings/all-years.journal", - tmpdir "import/jane/otherbank/creditcard/all-years.journal", - tmpdir "import/jane/otherbank/investments/all-years.journal", - tmpdir "import/john/bogartbank/checking/all-years.journal", - tmpdir "import/john/bogartbank/savings/all-years.journal", - tmpdir "import/john/otherbank/creditcard/all-years.journal", - tmpdir "import/john/otherbank/investments/all-years.journal" - ] - let expectedOnDisk = List.sort $ reportedAsWritten ++ extras ++ importedJournals ++ allYears - allFilesOnDisk <- single $ sort $ onlyFiles $ lstree tmpdir - liftIO $ assertEqual "The actual files on disk should match what groupAndWriteIncludeFiles reported" expectedOnDisk allFilesOnDisk + let allYears = + [ tmpdir "import/jane/bogartbank/checking/all-years.journal", + tmpdir "import/jane/bogartbank/savings/all-years.journal", + tmpdir "import/jane/otherbank/creditcard/all-years.journal", + tmpdir "import/jane/otherbank/investments/all-years.journal", + tmpdir "import/john/bogartbank/checking/all-years.journal", + tmpdir "import/john/bogartbank/savings/all-years.journal", + tmpdir "import/john/otherbank/creditcard/all-years.journal", + tmpdir "import/john/otherbank/investments/all-years.journal" + ] + let expectedOnDisk = List.sort $ reportedAsWritten ++ extras ++ importedJournals ++ allYears + (_, allFiles) <- PathIO.listDirRecur tmpdirAbsPath + let allFilesOnDisk = map Path.toFilePath (excludeHiddenFiles allFiles) + assertEqual "The actual files on disk should match what groupAndWriteIncludeFiles reported" (List.sort $ map FilePath.normalise expectedOnDisk) (List.sort $ map FilePath.normalise allFilesOnDisk) - let expectedJohn1Contents = - includePreamble - <> "\n" - <> "include 3-journal/2018/2018-10-30.journal\n" - <> "include 3-journal/2018/2018-11-30.journal\n" - <> "include 3-journal/2018/2018-12-30.journal\n" - actualJohn1Contents <- liftIO $ T.readFile john1 - liftIO $ assertEqual "John1: The include file contents should be the journal files" expectedJohn1Contents actualJohn1Contents + let expectedJohn1Contents = + includePreamble + <> "\n" + <> "include 3-journal/2018/2018-10-30.journal\n" + <> "include 3-journal/2018/2018-11-30.journal\n" + <> "include 3-journal/2018/2018-12-30.journal\n" + actualJohn1Contents <- T.readFile john1 + assertEqual "John1: The include file contents should be the journal files" expectedJohn1Contents actualJohn1Contents - let expectedJohn2Contents = - includePreamble - <> "\n" - <> "include 3-journal/2019/2019-01-30.journal\n" - <> "include 3-journal/2019/2019-02-30.journal\n" - actualJohn2Contents <- liftIO $ T.readFile john2 - liftIO $ assertEqual "John2: The include file contents should be the journal files" expectedJohn2Contents actualJohn2Contents + let expectedJohn2Contents = + includePreamble + <> "\n" + <> "include 3-journal/2019/2019-01-30.journal\n" + <> "include 3-journal/2019/2019-02-30.journal\n" + actualJohn2Contents <- T.readFile john2 + assertEqual "John2: The include file contents should be the journal files" expectedJohn2Contents actualJohn2Contents - let expectedJohn3Contents = - includePreamble - <> "\n" - <> "include 2017-opening.journal\n" - <> "include 3-journal/2017/2017-11-30.journal\n" - <> "include 3-journal/2017/2017-12-30.journal\n" - actualJohn3Contents <- liftIO $ T.readFile john3 - liftIO $ assertEqual "John3: The include file contents should be the journal files" expectedJohn3Contents actualJohn3Contents + let expectedJohn3Contents = + includePreamble + <> "\n" + <> "include 2017-opening.journal\n" + <> "include 3-journal/2017/2017-11-30.journal\n" + <> "include 3-journal/2017/2017-12-30.journal\n" + actualJohn3Contents <- T.readFile john3 + assertEqual "John3: The include file contents should be the journal files" expectedJohn3Contents actualJohn3Contents - let expectedJohn4Contents = - includePreamble - <> "\n" - <> "include 3-journal/2018/2018-01-30.journal\n" - <> "include 3-journal/2018/2018-02-30.journal\n" - actualJohn4Contents <- liftIO $ T.readFile john4 - liftIO $ assertEqual "John4: The include file contents should be the journal files" expectedJohn4Contents actualJohn4Contents + let expectedJohn4Contents = + includePreamble + <> "\n" + <> "include 3-journal/2018/2018-01-30.journal\n" + <> "include 3-journal/2018/2018-02-30.journal\n" + actualJohn4Contents <- T.readFile john4 + assertEqual "John4: The include file contents should be the journal files" expectedJohn4Contents actualJohn4Contents - let expectedJane7Contents = - includePreamble - <> "\n" - <> "include 3-journal/2018/2018-12-30.journal\n" - actualJane7Contents <- liftIO $ T.readFile jane7 - liftIO $ assertEqual "Jane7: The include file contents should be the journal files" expectedJane7Contents actualJane7Contents - ) - ) + let expectedJane7Contents = + includePreamble + <> "\n" + <> "include 3-journal/2018/2018-12-30.journal\n" + actualJane7Contents <- T.readFile jane7 + assertEqual "Jane7: The include file contents should be the journal files" expectedJane7Contents actualJane7Contents testWriteToplevelAllYearsInclude :: Test testWriteToplevelAllYearsInclude = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - written1 <- liftIO $ writeToplevelAllYearsInclude (defaultOpts tmpdirAbsPath) - let expectedFile = tmpdir "all-years.journal" - liftIO $ assertEqual "Should write the top-level all-years include file" [expectedFile] written1 - let expectedNoDirectives = - includePreamble - <> "\n" - <> "include import/all-years.journal\n" - actualNoDirectives <- liftIO $ T.readFile expectedFile - liftIO $ assertEqual "Top-level include should not reference directives when missing" expectedNoDirectives actualNoDirectives + written1 <- writeToplevelAllYearsInclude (defaultOpts tmpdirAbsPath) + let expectedFile = tmpdir "all-years.journal" + assertEqual "Should write the top-level all-years include file" [expectedFile] written1 + let expectedNoDirectives = + includePreamble + <> "\n" + <> "include import/all-years.journal\n" + actualNoDirectives <- T.readFile expectedFile + assertEqual "Top-level include should not reference directives when missing" expectedNoDirectives actualNoDirectives - let directives = tmpdir "directives.journal" - touch directives - written2 <- liftIO $ writeToplevelAllYearsInclude (defaultOpts tmpdirAbsPath) - liftIO $ assertEqual "Should overwrite the top-level all-years include file" [expectedFile] written2 - let expectedWithDirectives = - includePreamble - <> "\n" - <> "include directives.journal\n" - <> "include import/all-years.journal\n" - actualWithDirectives <- liftIO $ T.readFile expectedFile - liftIO $ assertEqual "Top-level include should reference directives when present" expectedWithDirectives actualWithDirectives - ) - ) + let directives = tmpdir "directives.journal" + touchAll [directives] + written2 <- writeToplevelAllYearsInclude (defaultOpts tmpdirAbsPath) + assertEqual "Should overwrite the top-level all-years include file" [expectedFile] written2 + let expectedWithDirectives = + includePreamble + <> "\n" + <> "include directives.journal\n" + <> "include import/all-years.journal\n" + actualWithDirectives <- T.readFile expectedFile + assertEqual "Top-level include should reference directives when present" expectedWithDirectives actualWithDirectives testWriteIncludesUpTo :: Test testWriteIncludesUpTo = - TestCase - ( sh - ( do - currentDir <- pwd - tmpdir <- using (mktempdir currentDir "hlflow") - tmpdirAbsPath <- fromTurtleAbsDir tmpdir + TestCase $ withTestDir $ \tmpdirAbsPath -> do + let tmpdir = Path.toFilePath tmpdirAbsPath - let journal = tmpdir "import/john/mybank/checking/3-journal/2019/2019-01-01.journal" - touchAll [journal] + let journal = tmpdir "import/john/mybank/checking/3-journal/2019/2019-01-01.journal" + touchAll [journal] - ch <- liftIO newTChanIO - let yearDir = Turtle.directory journal - let stateDir = Turtle.parent yearDir - let accountDir = Turtle.parent stateDir - let bankDir = Turtle.parent accountDir - let ownerDir = Turtle.parent bankDir - let stopAt = Turtle.parent ownerDir - written <- liftIO $ writeIncludesUpTo (defaultOpts tmpdirAbsPath) ch stopAt [journal] - let expectedFinal = tmpdir "import/2019-include.journal" - liftIO $ assertEqual "writeIncludesUpTo should stop at the requested directory" [expectedFinal] written + ch <- newTChanIO + stopAt <- Path.parseAbsDir (tmpdir "import") + input <- Path.parseAbsFile journal + expectedFinal <- Path.parseAbsFile (tmpdir "import/2019-include.journal") + narrower <- Path.parseAbsDir (tmpdir "import" "other") + rejected <- tryIOError (writeIncludesUpTo (defaultOpts tmpdirAbsPath) ch narrower [input]) + assertBool "Reject a journal outside the boundary before writing" (isLeft rejected) + PathIO.doesFileExist expectedFinal >>= assertBool "No ancestor include written on rejection" . not - finalContents <- liftIO $ T.readFile expectedFinal - let expectedContents = - includePreamble - <> "\n" - <> "include john/2019-include.journal\n" - liftIO $ assertEqual "Top-level year include should reference the owner include" expectedContents finalContents - ) - ) + written <- writeIncludesUpTo (defaultOpts tmpdirAbsPath) ch stopAt [input] + assertEqual "writeIncludesUpTo should stop at the requested directory" [expectedFinal] written + + finalContents <- T.readFile (Path.toFilePath expectedFinal) + let expectedContents = + includePreamble + <> "\n" + <> "include john/2019-include.journal\n" + assertEqual "Top-level year include should reference the owner include" expectedContents finalContents + + _ <- writeIncludesUpTo (defaultOpts tmpdirAbsPath) ch stopAt [] + emptyIndex <- T.readFile (tmpdir "import" "all-years.journal") + assertEqual "An empty import has a readable index" (includePreamble <> "\n") emptyIndex tests :: Test tests = diff --git a/test/Common/Integration.hs b/test/Common/Integration.hs --- a/test/Common/Integration.hs +++ b/test/Common/Integration.hs @@ -1,127 +1,122 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Common.Integration (tests) where +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryTakeMVar) +import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan) import qualified Data.List as List (sort) -import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Clock (UTCTime(..), addUTCTime, secondsToDiffTime) import Data.Time.Calendar (fromGregorian) import Hledger.Flow.Common -import Hledger.Flow.PathHelpers (TurtlePath) -import qualified System.Directory as Dir +import qualified Hledger.Flow.PathHelpers as Paths +import qualified Hledger.Flow.RuntimeOptions as RT +import Hledger.Flow.Types (LogMessage (StdErr)) +import qualified Path +import qualified Path.IO as PathIO +import System.Directory (doesFileExist) +import System.Timeout (timeout) import Test.HUnit +import TestHelpers (defaultOpts, withTestDir) import TestHelpersTurtle -import Turtle +import System.FilePath ((), normalise) testHiddenFiles :: Test -testHiddenFiles = - TestCase - ( sh - ( do - let tmpbase = "." "test" "tmp" - mktree tmpbase - tmpdir <- using (mktempdir tmpbase "hlflowtest") - let tmpJournals = map (tmpdir ) journalFiles :: [TurtlePath] - let tmpExtras = map (tmpdir ) extraFiles :: [TurtlePath] - let tmpHidden = map (tmpdir ) hiddenFiles :: [TurtlePath] - let onDisk = List.sort $ tmpJournals ++ tmpExtras ++ tmpHidden - touchAll onDisk - filtered <- fmap List.sort $ shellToList $ onlyFiles $ select onDisk - let expected = List.sort $ tmpExtras ++ tmpJournals - liftIO $ assertEqual "Hidden files should be excluded" expected filtered - ) - ) +testHiddenFiles = TestCase $ withTestDir $ \base -> do + let paths = map (Path.toFilePath base ) (journalFiles ++ extraFiles ++ hiddenFiles) + touchAll paths + found <- Paths.findFilesIn (const True) [] base + let expected = map (Path.toFilePath base ) (journalFiles ++ extraFiles) + assertEqual "Hidden files should be excluded" + (List.sort (map normalise expected)) (List.sort (map Path.toFilePath found)) testFilterPaths :: Test -testFilterPaths = - TestCase - ( sh - ( do - let tmpbase = "." "test" "tmp" - mktree tmpbase - tmpdir <- using (mktempdir tmpbase "hlflowtest") - let tmpJournals = map (tmpdir ) journalFiles :: [TurtlePath] - let tmpExtras = map (tmpdir ) extraFiles :: [TurtlePath] - let tmpHidden = map (tmpdir ) hiddenFiles :: [TurtlePath] - let onDisk = List.sort $ tmpJournals ++ tmpExtras ++ tmpHidden - touchAll onDisk - - let nonExistant = map (tmpdir ) ["where", "is", "my", "mind"] - let toFilter = nonExistant ++ onDisk - filtered <- single $ filterPaths testfile toFilter - let actual = List.sort filtered - liftIO $ assertEqual "The filtered paths should exclude files not actually on disk" onDisk actual - ) - ) +testFilterPaths = TestCase $ withTestDir $ \base -> do + let onDisk = map (Path.toFilePath base ) (journalFiles ++ extraFiles ++ hiddenFiles) + missing = map (Path.toFilePath base ) ["where", "is", "my", "mind"] + touchAll onDisk + filtered <- filterPaths doesFileExist (missing ++ onDisk) + assertEqual "Keep existing include files in reverse candidate order" (reverse onDisk) filtered testFirstExistingFile :: Test -testFirstExistingFile = - TestCase - ( sh - ( do - let tmpbase = "." "test" "tmp" - mktree tmpbase - tmpdir <- using (mktempdir tmpbase "hlflowtest") - let missing = tmpdir "does-not-exist.txt" - let existing1 = tmpdir "first.txt" - let existing2 = tmpdir "second.txt" - touchAll [existing1, existing2] - - found1 <- liftIO $ firstExistingFile [missing, existing1, existing2] - liftIO $ assertEqual "Should return the first existing file in the list" (Just existing1) found1 - - found2 <- liftIO $ firstExistingFile [missing] - liftIO $ assertEqual "Should return Nothing if no files exist" Nothing found2 - ) - ) +testFirstExistingFile = TestCase $ withTestDir $ \base -> do + let missing = base Path. [Path.relfile|missing.rules|] + first = base Path. [Path.relfile|first.rules|] + second = base Path. [Path.relfile|second.rules|] + T.writeFile (Path.toFilePath first) "" + T.writeFile (Path.toFilePath second) "" + found <- firstExistingFile [missing, first, second] + assertEqual "first existing file in candidate order" (Just first) found + absent <- firstExistingFile [missing] + assertEqual "no existing files" Nothing absent --- Helper to set mtime on a Turtle path -setMtime :: TurtlePath -> UTCTime -> IO () -setMtime path time = Dir.setModificationTime path time +testVerboseTestFile :: Test +testVerboseTestFile = TestCase $ withTestDir $ \base -> do + let opts = (defaultOpts base) {RT.verbose = True} + file = base Path. [Path.relfile|statement.csv|] + ch <- newTChanIO + let check expected message = do + exists <- verboseTestFile opts ch file + assertEqual "file existence" expected exists + entry <- atomically (tryReadTChan ch) + case entry of + Just (StdErr txt) -> do + let (timestamp, body) = T.breakOn "\t" txt + assertBool "verbose log starts with a timestamp" (not (T.null timestamp)) + assertEqual "verbose log uses the relative path" ("\thledger-flow " <> message) body + _ -> assertFailure "expected a verbose message on stderr" + check False "Looked for but did not find 'statement.csv'\n" + T.writeFile (Path.toFilePath file) "" + check True "Found 'statement.csv'\n" + _ <- verboseTestFile (defaultOpts base) ch file + quietEntry <- atomically (tryReadTChan ch) + case quietEntry of + Nothing -> return () + Just msg -> assertFailure ("unexpected log with verbosity off: " ++ show msg) --- Fixed timestamps for deterministic tests -olderTime :: UTCTime -olderTime = UTCTime (fromGregorian 2020 1 1) (secondsToDiffTime 0) +testNeedsRegeneration :: Test +testNeedsRegeneration = TestCase $ withTestDir $ \base -> do + let source = base Path. [Path.relfile|source.txt|] + target = base Path. [Path.relfile|target.txt|] + older = UTCTime (fromGregorian 2020 1 1) (secondsToDiffTime 0) + newer = addUTCTime 1 older + check message expected = needsRegeneration source target >>= assertEqual message expected -newerTime :: UTCTime -newerTime = UTCTime (fromGregorian 2025 1 1) (secondsToDiffTime 0) + T.writeFile (Path.toFilePath source) "" + check "missing target" True -testNeedsRegeneration :: Test -testNeedsRegeneration = - TestCase - ( sh - ( do - let tmpbase = "." "test" "tmp" - mktree tmpbase - tmpdir <- using (mktempdir tmpbase "hlflowtest") - let source = tmpdir "source.txt" - let target = tmpdir "target.txt" + T.writeFile (Path.toFilePath target) "" + PathIO.setModificationTime target older + PathIO.setModificationTime source newer + check "newer source" True - -- Test case 1: target doesn't exist -> returns True - touch source - result1 <- liftIO $ needsRegeneration source target - liftIO $ assertEqual "Should return True when target doesn't exist" True result1 + PathIO.setModificationTime source older + PathIO.setModificationTime target newer + check "newer target" False - -- Test case 2: target exists, source is newer -> returns True - touch target - liftIO $ setMtime target olderTime - liftIO $ setMtime source newerTime - result2 <- liftIO $ needsRegeneration source target - liftIO $ assertEqual "Should return True when source is newer than target" True result2 + PathIO.setModificationTime target older + check "equal timestamps" False + PathIO.setModificationTime source (addUTCTime 0.75 older) + check "subsecond differences alone do not trigger regeneration" False - -- Test case 3: target exists, target is newer -> returns False - liftIO $ setMtime source olderTime - liftIO $ setMtime target newerTime - result3 <- liftIO $ needsRegeneration source target - liftIO $ assertEqual "Should return False when target is newer than source" False result3 + PathIO.removeFile source + check "source timestamp no longer available" True - -- Test case 4: equal mtimes -> returns False (boundary condition) - liftIO $ setMtime source olderTime - liftIO $ setMtime target olderTime - result4 <- liftIO $ needsRegeneration source target - liftIO $ assertEqual "Should return False when mtimes are equal" False result4 - ) - ) +testBatchOrder :: Test +testBatchOrder = TestCase $ do + secondStarted <- newEmptyMVar + firstFinished <- newEmptyMVar + let first = takeMVar secondStarted >> putMVar firstFinished () >> return (1 :: Int) + second = putMVar secondStarted () >> return 2 + third = do + finished <- tryTakeMVar firstFinished + assertEqual "finish the current batch before starting the next" (Just ()) finished + return 3 + result <- timeout 10000000 (parBatchedActions 2 [0] [first, second, third]) + assertEqual "preserve input order across parallel batches" (Just [0, 1, 2, 3]) result tests :: Test -tests = TestList [testHiddenFiles, testFilterPaths, testFirstExistingFile, testNeedsRegeneration] +tests = TestList [testHiddenFiles, testFilterPaths, testFirstExistingFile, testVerboseTestFile, testNeedsRegeneration, testBatchOrder] diff --git a/test/Common/Unit.hs b/test/Common/Unit.hs --- a/test/Common/Unit.hs +++ b/test/Common/Unit.hs @@ -6,13 +6,21 @@ import Hledger.Flow.BaseDir (relativeToBase') import Hledger.Flow.Common +import Hledger.Flow.DocHelpers (docURL) import Hledger.Flow.RuntimeOptions (RuntimeOptions (hledgerConf)) import qualified Data.List as List import qualified Data.Map.Strict as Map -import Path (absdir) +import Path ((), reldir) import Test.HUnit -import TestHelpers (defaultOpts) +import TestHelpers (defaultOpts, testRoot) +import qualified System.FilePath as FilePath +testDocURL :: Test +testDocURL = TestCase $ + assertEqual "Input files documentation URL" + "https://github.com/apauley/hledger-flow/tree/master/docs#input-files" + (docURL "input-files") + testShowCmdArgs :: Test testShowCmdArgs = TestCase @@ -27,7 +35,7 @@ testHledgerConfArgs = TestCase ( do - let optsWithoutConf = defaultOpts [absdir|/base/|] + let optsWithoutConf = defaultOpts (testRoot [reldir|base|]) assertEqual "No hledger config should produce no hledger config args" [] (hledgerConfArgs optsWithoutConf) let optsWithConf = optsWithoutConf {hledgerConf = Just "/tmp/hledger.conf"} @@ -62,6 +70,15 @@ let mismatch = relativeToBase' "/base/dir" "/unrelated/dir/file1.journal" assertEqual "A basedir with no shared prefix should return the supplied file unchanged" "/unrelated/dir/file1.journal" mismatch + + assertEqual "Do not strip part of a sibling directory name" "base.other/file" + (relativeToBase' "base" "base.other/file") + assertEqual "Retain the trailing separator for a parent directory" "../" + (relativeToBase' "base" "base/..") + if FilePath.pathSeparator == '\\' + then assertEqual "A UNC share is not relative to the current drive root" "//server/share/file" + (relativeToBase' "/" "//server/share/file") + else return () ) testExtractDigits :: Test @@ -99,6 +116,11 @@ let expected3 = "import/john/bank/acc/3-journal/2018/2018-06-30.journal" let actual3 = changePathAndExtension "3-journal/" "journal" src3 assertEqual "Leave other directories intact, only change extension" expected3 actual3 + + let nativeInput = FilePath.joinPath ["import", "john", "bank", "acc", "1-in", "2018", "statement.csv"] + let nativeExpected = FilePath.joinPath ["import", "john", "bank", "acc", "3-journal", "2018", "statement.journal"] + assertEqual "Change the input directory with native path separators" nativeExpected + (FilePath.normalise $ changePathAndExtension "3-journal/" "journal" nativeInput) ) testGroupValuesBy :: Test @@ -113,4 +135,4 @@ ) tests :: Test -tests = TestList [testShowCmdArgs, testHledgerConfArgs, testRelativeToBase, testExtractDigits, testChangePathAndExtension, testGroupValuesBy] +tests = TestList [testDocURL, testShowCmdArgs, testHledgerConfArgs, testRelativeToBase, testExtractDigits, testChangePathAndExtension, testGroupValuesBy] diff --git a/test/ImportHelpers/Integration.hs b/test/ImportHelpers/Integration.hs --- a/test/ImportHelpers/Integration.hs +++ b/test/ImportHelpers/Integration.hs @@ -4,11 +4,13 @@ module ImportHelpers.Integration (tests) where import qualified Data.List as List +import Data.Either (isLeft) import qualified Data.Text.IO as T -import Hledger.Flow.Import.ImportHelpers (findInputFiles, findJournalFiles) +import Hledger.Flow.Import.ImportHelpers (findInputFiles, findJournalFiles, withStagedOutput) import Hledger.Flow.PathHelpers (AbsFile) import Path import Path.IO +import System.IO.Error (tryIOError) import Test.HUnit touchFile :: AbsFile -> IO () @@ -64,5 +66,26 @@ assertEqual "findJournalFiles should return only journal directory files, excluding hidden and excluded dirs" expected (List.sort actual) ) +testStagedOutput :: Test +testStagedOutput = TestCase $ withSystemTempDir "hlflow-output" $ \dir -> do + let target = dir [relfile|march.bank.csv|] + failAfterWriting staged = do + assertEqual "hook output keeps its filename" (filename target) (filename staged) + assertBool "hook output has a temporary parent" (parent staged /= dir) + T.writeFile (toFilePath staged) "partial" + ioError (userError "failed hook") + checkFailure = do + result <- tryIOError (withStagedOutput target failAfterWriting) + assertBool "propagate hook failure" (isLeft result) + (dirs, _) <- listDir dir + assertEqual "clean up staging directories" [] dirs + checkFailure + doesFileExist target >>= assertEqual "failed first run publishes no file" False + T.writeFile (toFilePath target) "previous" + checkFailure + T.readFile (toFilePath target) >>= assertEqual "preserve previous output" "previous" + withStagedOutput target $ \staged -> T.writeFile (toFilePath staged) "complete" + T.readFile (toFilePath target) >>= assertEqual "publish successful retry" "complete" + tests :: Test -tests = TestList [testFindInputFiles, testFindJournalFiles] +tests = TestList [testFindInputFiles, testFindJournalFiles, testStagedOutput] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,7 +11,7 @@ import qualified ImportHelpers.Integration import qualified PathHelpers.Unit import Test.HUnit -import Turtle +import System.Exit (exitFailure) tests :: Test tests = @@ -29,5 +29,5 @@ main = do errCounts <- runTestTT tests if (errors errCounts > 0 || failures errCounts > 0) - then exit $ ExitFailure 1 + then exitFailure else return errCounts diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs --- a/test/TestHelpers.hs +++ b/test/TestHelpers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -5,14 +6,30 @@ import Data.Maybe (fromMaybe) import Hledger.Flow.Internals (SystemInfo (..), versionInfo) -import Hledger.Flow.PathHelpers (RelFile) +import Hledger.Flow.PathHelpers (AbsDir, RelFile) import Hledger.Flow.RuntimeOptions import qualified Hledger.Flow.Types as FlowTypes import Path +import qualified Path.IO as PathIO import qualified System.Info as Sys +withTestDir :: (AbsDir -> IO ()) -> IO () +withTestDir action = do + cwd <- PathIO.getCurrentDir + let tmpbase = cwd [reldir|test/tmp|] + PathIO.createDirIfMissing True tmpbase + PathIO.withTempDir tmpbase "hlflowtest" action + defaultHlInfo :: FlowTypes.HledgerInfo -defaultHlInfo = FlowTypes.HledgerInfo [absfile|/path/to/hledger|] "1.2.3" +defaultHlInfo = FlowTypes.HledgerInfo (testRoot [relfile|path/to/hledger|]) "1.2.3" + +-- A fictional absolute root for fixtures; no files are created here. +testRoot :: Path Abs Dir +#ifdef mingw32_HOST_OS +testRoot = [absdir|C:/|] +#else +testRoot = [absdir|/|] +#endif testSystemInfo :: SystemInfo testSystemInfo = diff --git a/test/TestHelpersTurtle.hs b/test/TestHelpersTurtle.hs --- a/test/TestHelpersTurtle.hs +++ b/test/TestHelpersTurtle.hs @@ -3,10 +3,10 @@ module TestHelpersTurtle where import Hledger.Flow.Common (changePathAndExtension) -import Hledger.Flow.PathHelpers (TurtlePath) -import Turtle +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) -inputJohnBogart :: [TurtlePath] +inputJohnBogart :: [FilePath] inputJohnBogart = [ "import/john/bogartbank/savings/1-in/2017/2017-11-30.csv", "import/john/bogartbank/savings/1-in/2017/2017-12-30.csv", @@ -19,7 +19,7 @@ "import/john/bogartbank/checking/1-in/2019/2019-02-30.csv" ] -inputJohnOther :: [TurtlePath] +inputJohnOther :: [FilePath] inputJohnOther = [ "import/john/otherbank/creditcard/1-in/2017/2017-12-30.csv", "import/john/otherbank/creditcard/1-in/2018/2018-01-30.csv", @@ -27,7 +27,7 @@ "import/john/otherbank/investments/1-in/2019/2019-01-30.csv" ] -inputJaneBogart :: [TurtlePath] +inputJaneBogart :: [FilePath] inputJaneBogart = [ "import/jane/bogartbank/savings/1-in/2017/2017-12-30.csv", "import/jane/bogartbank/savings/1-in/2018/2018-01-30.csv", @@ -35,7 +35,7 @@ "import/jane/bogartbank/checking/1-in/2019/2019-01-30.csv" ] -inputJaneOther :: [TurtlePath] +inputJaneOther :: [FilePath] inputJaneOther = [ "import/jane/otherbank/creditcard/1-in/2017/2017-12-30.csv", "import/jane/otherbank/creditcard/1-in/2018/2018-01-30.csv", @@ -43,19 +43,19 @@ "import/jane/otherbank/investments/1-in/2019/2019-01-30.csv" ] -inputFiles :: [TurtlePath] +inputFiles :: [FilePath] inputFiles = inputJohnBogart <> inputJohnOther <> inputJaneBogart <> inputJaneOther -journalFiles :: [TurtlePath] +journalFiles :: [FilePath] journalFiles = toJournals inputFiles ++ ignoredJournalFiles -ignoredJournalFiles :: [TurtlePath] +ignoredJournalFiles :: [FilePath] ignoredJournalFiles = ["import/john/bogartbank/checking/3-journal/2018/not-a-journal.pdf"] -extraFiles :: [TurtlePath] +extraFiles :: [FilePath] extraFiles = ["import/john/bogartbank/savings/2017-opening.journal"] -hiddenFiles :: [TurtlePath] +hiddenFiles :: [FilePath] hiddenFiles = [ ".hiddenfile", "checking/.DS_Store", @@ -64,13 +64,13 @@ "import/john/bogartbank/checking/3-journal/2018/.hidden" ] -toJournals :: [TurtlePath] -> [TurtlePath] +toJournals :: [FilePath] -> [FilePath] toJournals = map (changePathAndExtension "3-journal/" "journal") -touchAll :: [TurtlePath] -> Shell () -touchAll = foldl (\acc file -> acc <> superTouch file) (return ()) +touchAll :: [FilePath] -> IO () +touchAll = mapM_ superTouch -superTouch :: TurtlePath -> Shell () +superTouch :: FilePath -> IO () superTouch file = do - mktree $ directory file - touch file + createDirectoryIfMissing True (takeDirectory file) + appendFile file ""