packages feed

hledger-flow 0.16.4 → 0.17.0

raw patch · 28 files changed

+1372/−1338 lines, 28 filesdep +asyncdep +processdep −foldldep −turtledep ~HUnitdep ~basedep ~directory

Dependencies added: async, process

Dependencies removed: foldl, turtle

Dependency ranges changed: HUnit, base, directory, optparse-applicative, time

Files

ChangeLog.md view
@@ -1,5 +1,65 @@ # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow) +<!--+How to keep this ChangeLog. The first section is always "## Unreleased".++- Add or update an entry in the same commit as any change a user could notice:+  behaviour, options, output, generated files, platforms, installation or+  build requirements, and the Hackage library API.+- Write from the user's point of view: what changes for them, and how it+  affects or benefits them. Use the names they see (commands, options, files,+  output), not how it was implemented.+- Order entries by impact on users, highest first:+  1. Changes users must act on, saying what they need to do.+  2. New features and capabilities.+  3. Behaviour changes and fixes, the most noticeable first.+  4. Build, packaging and dependency changes.+- Keep one entry per change. Update an existing entry rather than adding+  another, and merge entries that describe the same change.+- Leave out changes users can't notice, such as refactoring, tests and CI.+-->++## 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)
+ README.md view
@@ -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:++<https://github.com/apauley/hledger-flow-example>++## 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:+<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 [issue \#51](https://github.com/apauley/hledger-flow/issues/51).
− README.org 
@@ -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]].
app/Main.hs view
@@ -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.")
hledger-flow.cabal view
@@ -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 <https://github.com/apauley/hledger-flow#readme> 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
src/Hledger/Flow/BaseDir.hs view
@@ -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
src/Hledger/Flow/Common.hs view
@@ -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
src/Hledger/Flow/DateTime.hs view
@@ -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)
src/Hledger/Flow/DocHelpers.hs view
@@ -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
src/Hledger/Flow/Import/CSVImport.hs view
@@ -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
src/Hledger/Flow/Import/ImportHelpers.hs view
@@ -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
src/Hledger/Flow/Import/ImportHelpersTurtle.hs view
@@ -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)
src/Hledger/Flow/Import/Types.hs view
@@ -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)
src/Hledger/Flow/Logging.hs view
@@ -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
src/Hledger/Flow/PathHelpers.hs view
@@ -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
src/Hledger/Flow/Reports.hs view
@@ -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
src/Hledger/Flow/RuntimeOptions.hs view
@@ -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,
src/Hledger/Flow/Types.hs view
@@ -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,
test/BaseDir/Integration.hs view
@@ -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|.|])
test/CSVImport/ImportHelperTests.hs view
@@ -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]
test/CSVImport/ImportHelperTurtleTests.hs view
@@ -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     ]
test/CSVImport/Integration.hs view
@@ -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 =
test/Common/Integration.hs view
@@ -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]
test/Common/Unit.hs view
@@ -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]
test/ImportHelpers/Integration.hs view
@@ -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]
test/Spec.hs view
@@ -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
test/TestHelpers.hs view
@@ -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 =
test/TestHelpersTurtle.hs view
@@ -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 ""