diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,6 +10,9 @@ - Say what users can now do, what behaves differently or what action they need to take. Name the affected platform, command, option, file or output when it helps readers recognise the change. +- When a change affects multiple platforms, list Linux first, then macOS, + then Windows. Omit unaffected platforms and keep corresponding figures + in the same order. - Keep each entry brief. Put commands and step-by-step instructions in the relevant guide. Link directly to that section when readers need details. Use a full URL so the link also works in the GitHub release notes. @@ -27,6 +30,69 @@ here because Windows users can install it. Automating publication to an existing destination belongs in release-procedure.md. --> + +## 0.20.0 + +- If you have statements with brackets in their filenames, such as + `April [1].csv`, run `hledger-flow import` to regenerate their journals. + Each now imports exactly once alongside `April 1.csv`. +- If a statement is newer than its cached CSV and its preprocess hook is + missing, import stops and names both files. Restore the hook or move the + cached CSV aside, then run `hledger-flow import`. +- The documentation has moved to the [project site](https://hledger-flow.github.io/). + Links in hledger-flow's messages and `--help` open the relevant section + there, and links printed by earlier versions still lead to the right page. + The rewritten [tutorial](https://hledger-flow.github.io/tutorial/) shows how + far hledger's rules files go before you need a preprocess or construct script. +- `report` now writes aggregate annual and monthly income statements and + balance sheets even with zero or one owner, so they include root-level + manual entries. Owner reports still show only that owner's entries. +- In a benchmark rebuilding 124 statements, `import` took 11% less time on + Linux, 42% less on macOS, and 8% less on Windows than in 0.19.0. When + all four statements selected from that archive were up to date, + `import --new-files-only` took 82%, 71%, and 81% less time, respectively. + Parallel imports and reports start the next file as soon as a worker is + free and default to one file per core. Use `--batch-size` to change this. +- Dots before a statement's rules override are now supported. For example, + `2024.04_rfo-card.csv` uses `rfo-card.rules` when present. +- `import` no longer ends with a `Next:` suggestion. Run `hledger-flow status` + to see the next step. +- `import --new-files-only` now picks up statement corrections made later in + the same second as the previous output. +- If writing a rules-generated journal or an include file fails, the previous + complete copy stays in place for the next import. +- Running `import` from a subfolder of a statement year, such as + `1-in/2024/archive/`, now limits conversion and orphan cleanup to that + account. Sibling accounts keep their outputs. +- `status` and `--show-options` now name the + [hledger config file](https://hledger-flow.github.io/reference/status/#hledger-config-file) + that hledger finds by itself, such as `~/.hledger.conf`, instead of showing + none. Options in that file apply to import and reports, and can change the + generated journals. +- `status`, `init`, `--show-options` and import and report messages show + paths in your home folder as `~`. The commands they suggest write the home + folder as `"$HOME/…"`, so you can still paste them. `status --json` keeps + [full paths](https://hledger-flow.github.io/reference/status/#paths-in-your-home-folder). +- An empty owner folder created for future statements no longer stops + `report` for owners who already have journals. +- `status` marks journals outdated when a shared CSV rules file changes, + including rules included by another rules file. +- Owners, banks and accounts named `import` are supported when importing + statements and checking their status from the ledger root. +- Ctrl-C during hledger version detection now cancels `status`, including + `status --json`. +- Failed imports and reports finish writing their diagnostics before exiting, + including when output is piped to a slow reader. +- `import --start-year` now rejects mistyped years such as `24` before + importing. Use four digits or `current`. +- `status --rules-template` gives every CSV column a distinct field name, + even when the header already contains a name such as `Reference_2`. +- If `hledger --version` fails, `import` and `report` now name the command and + its exit code instead of exiting silently. +- When a symlink in a `3-journal` folder points to a generated journal, the + ledger now counts its transactions once. +- Local Linux x86-64 Snap builds now package the hledger-flow version named + on the snap and verify the executable before installation. ## 0.19.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,8 +29,8 @@ ## Overview of the Basic Workflow -1. Save each statement under its [account and year](docs/README.md#input-files). -2. Add an [hledger rules file](docs/README.md#rules-files) for the account or bank. +1. Save each statement under its [account and year](https://hledger-flow.github.io/reference/input-files/). +2. Add an [hledger rules file](https://hledger-flow.github.io/reference/rules-files/) for the account or bank. For most bank CSVs, rules are all you need. 3. Run `hledger-flow import` from the base directory. Use the generated `all-years.journal` as your `LEDGER_FILE`. @@ -43,7 +43,7 @@ Purchases from City Rail currently appear under `expenses:misc`. You also recorded a one-off cash fare by hand in `import/john/_manual_/2024/post-import.journal`. Keep handwritten adjustments -in a [manual journal](docs/README.md#manually-managed-journals), since each +in a [manual journal](https://hledger-flow.github.io/reference/manual-journals/), since each full import rewrites the statement journals in `3-journal/`. Add this rule to `import/mybank.rules`, the rules file used by those statements: @@ -68,114 +68,25 @@ ## How do I install it? -| Installation method | Platforms | Choose this if you want to… | -| --- | --- | --- | -| [Download a GitHub release](#download-a-github-release) | Windows, macOS, Linux | Run a prebuilt executable. | -| [Install with Homebrew](#install-with-homebrew) | macOS, Linux | Install and upgrade with `brew`. | -| [Build from source](#build-from-source) | Windows, macOS, Linux | Compile the project yourself with Stack. | - -### Download a GitHub release - -1. Download the archive for your OS and processor from the [latest GitHub release](https://github.com/apauley/hledger-flow/releases/latest). -2. Extract it and copy `hledger-flow` (or `hledger-flow.exe` on Windows) to a directory on your `PATH`. - On macOS, [extract and run it from your terminal](QUICKSTART.md#install-on-macos), not Finder. -3. [Install hledger](https://hledger.org/install.html) for imports and reports. - -The [quick-start guide](QUICKSTART.md) lists the archive names and walks through installation and your first import on each platform. - -#### Verifying a download - -From v0.17.0 onward, GitHub releases are immutable and the archives carry build -attestations. To verify a download, substitute its release tag and archive name -in both [GitHub CLI](https://cli.github.com/) commands: - -```sh -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 first command checks that the archive matches the published release. The -second checks its build provenance. The macOS binaries are signed with a -Developer ID and submitted to Apple for notarization. - -### Install with Homebrew - -On a [supported Mac or Linux system](https://github.com/FernTrail/homebrew-tap#supported-platforms), -check that `brew --version` works in your terminal. If you’re new to Homebrew, -[install Homebrew](https://brew.sh/) and follow the installer’s instructions to add `brew` to your `PATH`. - -To set up FernTrail’s package repository (its *tap*) for the first time: - -```sh -brew tap ferntrail/tap -``` - -Optionally, to inspect the package before installing it, trust just the -hledger-flow formula and show its details (Homebrew 6 or newer): - -```sh -brew trust --formula ferntrail/tap/hledger-flow -brew info ferntrail/tap/hledger-flow -``` - -Install hledger-flow and its `hledger` dependency: +Install with Homebrew on macOS or Linux: ```sh brew install ferntrail/tap/hledger-flow ``` -If you don’t want Homebrew to install `hledger`, add `--without-hledger` to the install command. -The fully qualified install command also works on its own: Homebrew adds the tap -automatically and trusts only the named formula. See [Homebrew’s tap trust guide](https://docs.brew.sh/Tap-Trust). - -For later releases, run `brew update` and `brew upgrade ferntrail/tap/hledger-flow`. - -### Build from source - -From a checkout of this repository, run `stack install`. Add the directory -reported by `stack path --local-bin` to your `PATH` and [install hledger](https://hledger.org/install.html). -See the [build instructions](CONTRIBUTING.md#build-the-project) for prerequisites and tests. - -## Getting Started - -Check that both commands are available with `hledger-flow --version` and -`hledger --version`. To select a specific copy of hledger, use -`hledger-flow --hledger-path /path/to/hledger import`. Windows users can -write account hooks in PowerShell (`preprocess.ps1` and `construct.ps1`) -or use native executables. See [Windows import hooks](docs/README.md#windows-import-hooks). - -Have a look at the [detailed step-by-step instructions](step-by-step/README.md) and the [feature reference](docs/README.md). - -You can see the example imported financial transactions as it was -generated by the step-by-step instructions here: - - - -## Compatibility with hledger - -`hledger-flow` should work with any recent version of `hledger`. - -## Compatibility with ledger-cli - -`hledger-flow` uses `hledger` to produce journal's, so this page about [hledger and Ledger](https://hledger.org/ledger.html) should be relevant for all `hledger-flow` users. - -That said, here are some observations that are specifically relevant to `hledger-flow`: - -When writing out the journal include files, `hledger-flow` sorts the -include statements by filename. - -[Ledger](https://www.ledger-cli.org/) fails any balance assertions -when the transactions aren't included in chronological order. +Or download a release for Windows, macOS or Linux, or build from source. +The [quick start](https://hledger-flow.github.io/quickstart/) covers each option, how to verify a +download, and your first import. -An easy way around this is to name your input files so that March's -statement is listed before December's statement. +## Documentation -Another option is to add `--permissive` to any -[ledger](https://www.ledger-cli.org/) command. +The full documentation is at ****: -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). +- [Quick start](https://hledger-flow.github.io/quickstart/) +- [Tutorial](https://hledger-flow.github.io/tutorial/) +- [Reference](https://hledger-flow.github.io/reference/status/) +- [Transfers between your accounts](https://hledger-flow.github.io/guides/transfers/) +- [Using Ledger](https://hledger-flow.github.io/guides/ledger/) ## Project Goals @@ -203,76 +114,3 @@ # Contributing to hledger-flow Have a look at the [contribution guidelines](CONTRIBUTING.md). - -# FAQ - -## How do you balance transfers between 2 accounts when you have statements for both accounts? - -### The Problem - -In your primary bank account you've happily been classifying transfers to a -secondary account as just `Expenses:OtherAccount`. - -But you've recently started processing the statements from the second account as -well so that you can classify those expenses more accurately. - -And now the balances of these two accounts are all wrong when the statements of -each account deals with money transferred between these two accounts. - -In `bank1.journal`, imported from `bank1.csv`: - - 2018/11/09 Transfer from primary account to secondary account - Assets:Bank1:Primary $-200 - Assets:Bank2:Secondary - -In `bank2.journal`, imported from `bank2.csv`: - - 2018/11/09 Transfer from primary account to secondary account - Assets:Bank2:Secondary $200 - Assets:Bank1:Primary - -### The Solution - -As soon as you start importing statements for both accounts you will have to -introduce an intermediate account for classification between these two accounts. - -I use `Assets:Transfers:*`. - -And we may have reports looking at these transfers accounts at some point, you -should consider using the same names. - -The above example then becomes as follows. - -In `bank1.journal`, imported from `bank1.csv`: - - 2019-05-18 Transfer from primary account to secondary account - Assets:Bank1:Primary $-200 - Assets:Transfers:Bank1Bank2 - -In `bank2.journal`, imported from `bank2.csv`: - - 2019-05-18 Transfer from primary account to secondary account - Assets:Bank2:Secondary $200 - Assets:Transfers:Bank1Bank2 - -Any posting to `Assets:Transfers:*` indicates an in "in-flight" amount. -You would expect the balance of `Assets:Transfers` to be zero most of the time. -Whenever it isn't zero it means that you either don't yet have the other side of -the transfer, or that something is wrong in your rules. - -You could theoretically just use `Assets:Transfers` without any subaccounts, but -I found it useful to use subaccounts. Because then the subaccounts can show me -where I should look for any missing transfer transaction. - -I typically use sorted names as the subaccount (Python code sample): - -``` python -"Assets:Transfers:" + "".join(sorted(["Bank2", "Bank1"])) -``` - -### External references - -This approach is based on what is described in Full-fledged hledger: - - -The question was first asked in [issue \#51](https://github.com/apauley/hledger-flow/issues/51). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,7 +5,7 @@ module Main where -import Parsing ( parseStartYear ) +import Parsing ( StartYear, resolveStartYear, startYearReader ) import Path ( reldir ) import Prelude hiding (putStrLn) @@ -36,15 +36,18 @@ str, switch ) -import Hledger.Flow.Common ( hledgerInfoFromPath ) +import Hledger.Flow.Types (HledgerInfo (..)) +import Hledger.Flow.Common ( deferredHledgerVersion, findHledgerConf, hledgerPathFromOption, hledgerInfoFromPath ) import Hledger.Flow.Status ( Situation (..) ) import Hledger.Flow.Status.Gather ( classifyDir ) import Hledger.Flow.Status.Render ( printStatus ) import qualified Data.Text as Text import Path.IO ( getCurrentDir, resolveDir' ) import Hledger.Flow.Init ( runInit ) +import Hledger.Flow.DocHelpers ( DocLink (Docs), docURL, siteURL ) import Hledger.Flow.RulesTemplate ( rulesTemplateFor ) -import Hledger.Flow.Internals (versionInfo, systemInfo) +import Data.Maybe (fromMaybe) +import Hledger.Flow.Internals (availableCores, versionInfo, systemInfo) import Hledger.Flow.BaseDir ( determineBaseDir, findBaseDir ) import qualified Hledger.Flow.RuntimeOptions as RT import Hledger.Flow.ReleaseNotice ( withReleaseNotice ) @@ -53,7 +56,7 @@ import qualified Data.Text.IO as T import Control.Exception (SomeAsyncException (..), SomeException, catch, displayException, fromException, throwIO) -import Hledger.Flow.PathHelpers (PathException (..), turtleToAbsDir) +import Hledger.Flow.PathHelpers (PathException (..), resolveExistingDir) import System.Exit (ExitCode (..), exitWith) import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8) import System.IO.Error (ioeGetErrorString, isUserError) @@ -62,7 +65,7 @@ #endif data ImportParams = ImportParams { maybeImportBaseDir :: Maybe FilePath - , importStartYear :: Maybe String + , importStartYear :: Maybe StartYear , onlyNewFiles :: Bool } deriving (Show) @@ -120,7 +123,7 @@ runCommand :: IO () runCommand = do - let description = "An hledger workflow focusing on automated statement import and classification:\nhttps://github.com/apauley/hledger-flow#readme" + let description = pretty ("An hledger workflow focusing on automated statement import and classification:\n" <> Text.unpack siteURL) cmd <- customExecParser (prefs mempty) (info (helper <*> baseCommandParser) (headerDoc (Just description) <> footerDoc (Just topExamples))) case cmd of @@ -161,7 +164,7 @@ runStatus :: MainParams -> StatusParams -> IO () runStatus mainParams' params = do cwd <- getCurrentDir - dir <- maybe (return cwd) (turtleToAbsDir cwd) (statusDir params) + dir <- maybe (return cwd) (resolveExistingDir cwd) (statusDir params) base <- findBaseDir dir >>= maybe (throwIO (MissingBaseDir dir)) return case statusRulesTemplate params of Just account -> rulesTemplateFor base (Text.pack account) >>= either (ioError . userError . Text.unpack) T.putStr @@ -172,7 +175,8 @@ runBare mainParams' = do situation <- getCurrentDir >>= classifyDir case situation of - InLedger base -> printStatus (hledgerPathOpt mainParams') (hledgerConfOpt mainParams') False base + InLedger base -> + printStatus (hledgerPathOpt mainParams') (hledgerConfOpt mainParams') False base EmptyDir -> T.putStrLn "This folder is empty. Run `hledger-flow init` to start your ledger here." Elsewhere -> T.putStr $ @@ -180,35 +184,28 @@ <> "\nNo hledger-flow ledger here or in any parent folder.\n" <> "Run `hledger-flow init` in an empty folder to start one.\n" -defaultBatchSize :: Int -defaultBatchSize = 20 - -determineBatchSize :: MainParams -> IO Int -determineBatchSize mainParams' = - case (batchSize mainParams') of - Nothing -> return defaultBatchSize - Just size -> return size - toRuntimeOptionsImport :: MainParams -> ImportParams -> IO RT.RuntimeOptions toRuntimeOptionsImport mainParams' subParams' = do - startYear <- parseStartYear $ importStartYear subParams' + startYear <- traverse resolveStartYear (importStartYear subParams') let maybeBD = maybeImportBaseDir subParams' :: Maybe FilePath (bd, runDir) <- determineBaseDir maybeBD - hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' - size <- determineBatchSize mainParams' + hlp <- hledgerPathFromOption $ hledgerPathOpt mainParams' + version <- deferredHledgerVersion hlp + conf <- findHledgerConf $ hledgerConfOpt mainParams' sysInfo <- systemInfo return RT.RuntimeOptions { RT.baseDir = bd , RT.importRunDir = runDir , RT.importStartYear = startYear , RT.onlyNewFiles = onlyNewFiles subParams' , RT.hfVersion = versionInfo sysInfo - , RT.hledgerInfo = hli - , RT.hledgerConf = hledgerConfOpt mainParams' + , RT.hledgerExecutable = hlp + , RT.hledgerVersion = version + , RT.hledgerConf = conf , RT.sysInfo = sysInfo , RT.verbose = verbosity mainParams' > 0 , RT.showOptions = showOpts mainParams' , RT.sequential = sequential mainParams' - , RT.batchSize = size + , RT.batchSize = fromMaybe (availableCores sysInfo) (batchSize mainParams') , RT.prettyReports = True } @@ -216,21 +213,22 @@ toRuntimeOptionsReport mainParams' subParams' = do let maybeBD = maybeReportBaseDir subParams' :: Maybe FilePath (bd, _) <- determineBaseDir maybeBD - hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' - size <- determineBatchSize mainParams' + HledgerInfo hlp version <- hledgerInfoFromPath $ hledgerPathOpt mainParams' + conf <- findHledgerConf $ hledgerConfOpt mainParams' sysInfo <- systemInfo return RT.RuntimeOptions { RT.baseDir = bd , RT.importRunDir = [reldir|.|] , RT.importStartYear = Nothing , RT.onlyNewFiles = False , RT.hfVersion = versionInfo sysInfo - , RT.hledgerInfo = hli - , RT.hledgerConf = hledgerConfOpt mainParams' + , RT.hledgerExecutable = hlp + , RT.hledgerVersion = return version + , RT.hledgerConf = conf , RT.sysInfo = sysInfo , RT.verbose = verbosity mainParams' > 0 , RT.showOptions = showOpts mainParams' , RT.sequential = sequential mainParams' - , RT.batchSize = size + , RT.batchSize = fromMaybe (availableCores sysInfo) (batchSize mainParams') , RT.prettyReports = not(asciiReports subParams') } @@ -260,7 +258,7 @@ " hledger-flow report Generate reports", " hledger-flow status --json The same status, for scripts and agents", "", - "Docs: https://github.com/apauley/hledger-flow/tree/master/docs" + "Docs: " <> Text.unpack (docURL Docs) ] subcommandExamples :: [(String, [String])] @@ -283,13 +281,13 @@ <*> 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" <> hidden <> help "The hledger config file to pass to hledger --conf")) <*> switch (long "show-options" <> hidden <> help "Print the hledger-flow version, hledger path and settings import or report runs with. status always shows them.") - <*> optional (option auto (long "batch-size" <> metavar "SIZE" <> hidden <> help ("Number of files to process in parallel. Must be positive. Default: " <> show defaultBatchSize <> ". Ignored during sequential processing."))) + <*> optional (option auto (long "batch-size" <> metavar "SIZE" <> hidden <> help "Number of files to process in parallel. Must be positive. Default: the number of cores in use. Ignored during sequential processing.")) <*> switch (long "sequential" <> hidden <> help "Disable parallel processing") subcommandParserImport :: Parser ImportParams subcommandParserImport = ImportParams <$> 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")) + <*> optional (option startYearReader (long "start-year" <> metavar "YEAR" <> help "Import only from the specified year and onwards, ignoring previous years. By default all available years are imported. Use 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 diff --git a/app/Parsing.hs b/app/Parsing.hs --- a/app/Parsing.hs +++ b/app/Parsing.hs @@ -1,25 +1,20 @@ -{-# LANGUAGE PartialTypeSignatures #-} - -module Parsing ( - parseStartYear - ) where +module Parsing (StartYear, startYearReader, resolveStartYear) where -import Hledger.Flow.DateTime -import System.Exit (die) +import Data.Char (isDigit) +import Hledger.Flow.DateTime (currentYear) +import Options.Applicative (ReadM, eitherReader) import Text.Read (readMaybe) -parseStartYear :: Maybe String -> IO (Maybe Integer) -parseStartYear y = case y of - Nothing -> return Nothing - Just "current" -> Just <$> currentYear - Just s -> Just <$> parseInt s "Unable to parse year" +data StartYear = CurrentYear | FromYear Integer deriving (Show) -parseInt :: String -> String -> IO Integer -parseInt s errPrefix = case safeParseInt s errPrefix of - Right i -> return i - Left err -> die err +startYearReader :: ReadM StartYear +startYearReader = eitherReader parse + where + parse "current" = Right CurrentYear + parse s + | length s == 4, all isDigit s, Just year <- readMaybe s = Right (FromYear year) + | otherwise = Left "expected a four-digit year or 'current'" -safeParseInt :: String -> String -> Either String Integer -safeParseInt s errPrefix = case (readMaybe s :: Maybe Integer) of - Nothing -> Left $ errPrefix ++ " " ++ s - Just i -> Right i +resolveStartYear :: StartYear -> IO Integer +resolveStartYear CurrentYear = currentYear +resolveStartYear (FromYear year) = return year diff --git a/hledger-flow.cabal b/hledger-flow.cabal --- a/hledger-flow.cabal +++ b/hledger-flow.cabal @@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack name: hledger-flow -version: 0.19.0 +version: 0.20.0 synopsis: An hledger workflow focusing on automated statement import and classification. -description: Please see the README on GitHub at +description: Documentation and a quick start are at category: Finance, Console homepage: https://github.com/apauley/hledger-flow#readme bug-reports: https://github.com/apauley/hledger-flow/issues @@ -20,6 +20,7 @@ extra-source-files: README.md ChangeLog.md + site/go-links.json source-repository head type: git @@ -34,7 +35,7 @@ Hledger.Flow.Environment Hledger.Flow.Import.CSVImport Hledger.Flow.Import.ImportHelpers - Hledger.Flow.Import.ImportHelpersTurtle + Hledger.Flow.Import.IncludeFiles Hledger.Flow.Import.Inventory Hledger.Flow.Import.Types Hledger.Flow.Init @@ -55,11 +56,11 @@ src ghc-options: -Wall build-depends: - aeson >=2.2.5 && <2.3 + aeson >=2.2.5.1 && <2.3 , ansi-terminal >=1.1.5 && <1.2 - , async >=2.2.5 && <2.3 + , async >=2.2.6 && <2.3 , base >=4.20 && <4.22 - , bytestring ==0.12.* + , bytestring >=0.12.2.0 && <0.13 , containers ==0.7.* , directory >=1.3.8.5 && <1.4 , exceptions >=0.10.9 && <0.11 @@ -104,7 +105,7 @@ Common.Integration Common.Unit CSVImport.ImportHelperTests - CSVImport.ImportHelperTurtleTests + CSVImport.IncludeFilesTests CSVImport.Integration CSVImport.Unit Environment.Unit @@ -113,6 +114,7 @@ PathHelpers.Unit ReleaseNotice.Unit RulesTemplate.Unit + RuntimeOptions.Unit Status.Integration Status.Unit TestHelpers @@ -122,7 +124,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit >=1.6.2.0 && <1.7 - , aeson >=2.2.5 && <2.3 + , aeson >=2.2.5.1 && <2.3 , base >=4.20 && <4.22 , containers ==0.7.* , directory >=1.3.8.5 && <1.4 diff --git a/site/go-links.json b/site/go-links.json new file mode 100644 --- /dev/null +++ b/site/go-links.json @@ -0,0 +1,8 @@ +{ + "docs": "/quickstart/", + "getting-started": "/quickstart/#import-your-first-statement", + "input-files": "/reference/input-files/", + "rules-files": "/reference/rules-files/", + "preprocess-script": "/reference/preprocess/", + "set-ledger-file": "/quickstart/#import-your-first-statement" +} diff --git a/src/Hledger/Flow/BaseDir.hs b/src/Hledger/Flow/BaseDir.hs --- a/src/Hledger/Flow/BaseDir.hs +++ b/src/Hledger/Flow/BaseDir.hs @@ -6,7 +6,7 @@ findBaseDir, relativeToBase, relativeToBase', - turtleBaseDir, + baseDirFilePath, effectiveRunDir, ) where @@ -30,7 +30,7 @@ determineBaseDir' :: AbsDir -> Maybe FilePath -> IO (BaseDir, RunDir) determineBaseDir' pwd (Just suppliedDir) = do - absDir <- turtleToAbsDir pwd suppliedDir + absDir <- resolveExistingDir pwd suppliedDir determineBaseDirFromStartDir absDir determineBaseDir' pwd Nothing = determineBaseDirFromStartDir pwd @@ -54,29 +54,24 @@ then return (Just dir) else if parent dir == dir then return Nothing else findBaseDir (parent dir) --- | We have unexpected behaviour when the runDir is deeper than the account directory, --- e.g. "1-in" or the year directory. Specifically, include files are generated incorrectly --- and some journals are written entirely outside of the baseDir. --- limitRunDir can possibly removed if the above is fixed. +-- | A directory below import/owner/bank/account selects that account. limitRunDir :: (MonadIO m, MonadThrow m) => BaseDir -> AbsDir -> m RunDir limitRunDir bd absRunDir = do rel <- makeRelative bd absRunDir let runDirDepth = pathSize rel - let fun = composeN (runDirDepth - 4) parent - let newRunDir = fun rel + let newRunDir = limitDepth runDirDepth rel when (runDirDepth > 4) $ do 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) -composeN n f - | n < 1 = id - | n == 1 = f - | otherwise = composeN (n - 1) (f . f) + where + limitDepth depth dir + | depth > 4 = limitDepth (depth - 1) (parent dir) + | otherwise = dir relativeToBase :: (HasBaseDir o) => o -> FilePath -> FilePath -relativeToBase opts = relativeToBase' $ pathToTurtle (baseDir opts) +relativeToBase opts = relativeToBase' $ baseDirFilePath opts relativeToBase' :: FilePath -> FilePath -> FilePath relativeToBase' bd p @@ -88,8 +83,8 @@ let suffix = concat parts in if FilePath.takeFileName suffix == ".." then suffix ++ "/" else suffix -turtleBaseDir :: (HasBaseDir o) => o -> FilePath -turtleBaseDir opts = pathToTurtle $ baseDir opts +baseDirFilePath :: (HasBaseDir o) => o -> FilePath +baseDirFilePath opts = toFilePath $ baseDir opts effectiveRunDir :: BaseDir -> RunDir -> AbsDir effectiveRunDir bd rd = do diff --git a/src/Hledger/Flow/Common.hs b/src/Hledger/Flow/Common.hs --- a/src/Hledger/Flow/Common.hs +++ b/src/Hledger/Flow/Common.hs @@ -3,28 +3,24 @@ module Hledger.Flow.Common where -import Control.Concurrent (threadDelay) -import Control.Exception (SomeException, try) -import Control.Monad (filterM, forM_, when) +import Control.Monad (filterM, forM_, unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.MVar (modifyMVar, newMVar) import Control.Concurrent.Async (concurrently, mapConcurrently) +import Control.Concurrent.Stream (mapConcurrentlyBounded) import Control.Concurrent.STM import Data.Char (isAlphaNum, isAscii, isDigit) import Data.Either -import Data.Function (on) -import qualified Data.List as List (groupBy, isPrefixOf, isSuffixOf, null, sortBy) -import Data.Maybe (mapMaybe) +import qualified Data.List as List (isPrefixOf, isSuffixOf, nub, null) 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 qualified GHC.IO.Handle.FD as H import Hledger.Flow.DateTime (timeAction) import Hledger.Flow.BaseDir (relativeToBase) import Hledger.Flow.Logging -import Hledger.Flow.PathHelpers (AbsFile, RelDir, fromTurtleAbsFile) +import Hledger.Flow.PathHelpers (AbsFile, RelDir, literalGlobPath, withStagedOutput) import qualified Hledger.Flow.RuntimeOptions as RT import Hledger.Flow.Types import Path (reldir, relfile, toFilePath) @@ -45,13 +41,16 @@ hledgerPathFromOption pathOption = do case pathOption of Just h -> do - hlAbs <- fromTurtleAbsFile h - isOnDisk <- Path.doesFileExist hlAbs - if isOnDisk - then return hlAbs - else do - let msg = "Unable to find hledger at " <> T.pack h - errExit' 1 (T.hPutStrLn H.stderr) msg hlAbs + hlAbs <- Path.parseAbsFile h + exists <- Path.doesFileExist hlAbs + let failWith = errExit' 1 (T.hPutStrLn H.stderr) + unless exists $ failWith ("Unable to find hledger at " <> T.pack h) + -- Windows has no POSIX execute bit. + unless (Sys.os == "mingw32") $ do + permissions <- Directory.getPermissions h + unless (Directory.executable permissions) $ + failWith ("The hledger file is not executable: " <> T.pack h) + return hlAbs Nothing -> do maybeH <- Directory.findExecutable "hledger" case maybeH of @@ -75,11 +74,22 @@ case found of Nothing -> return Nothing Just hlp -> do - version <- try (hledgerVersionFromPath hlp) :: IO (Either SomeException T.Text) - return (either (const Nothing) (Just . HledgerInfo hlp) version) + result <- tryIOError (probeHledgerVersion hlp) + return $ case result of + Right (ExitSuccess, version) -> Just (HledgerInfo hlp version) + _ -> Nothing hledgerVersionFromPath :: AbsFile -> IO T.Text hledgerVersionFromPath hlp = do + (status, version) <- probeHledgerVersion hlp + case status of + ExitSuccess -> return version + ExitFailure code -> errExit' code (T.hPutStrLn H.stderr) $ + "Failed to run " <> showCmdArgs [T.pack (toFilePath hlp), "--version"] + <> " (exit code " <> T.pack (show code) <> ")." + +probeHledgerVersion :: AbsFile -> IO (ExitCode, T.Text) +probeHledgerVersion 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 @@ -87,25 +97,107 @@ Just stdoutPipe <- return output version <- T.hGetContents stdoutPipe status <- Process.waitForProcess handle - case status of - ExitSuccess -> return (T.strip version) - ExitFailure _ -> exitWith status + return (status, T.strip version) +-- Share a successful probe among parallel conversions in this invocation. +deferredHledgerVersion :: AbsFile -> IO (IO T.Text) +deferredHledgerVersion path = do + cached <- newMVar Nothing + return $ modifyMVar cached $ \previous -> do + version <- maybe (hledgerVersionFromPath path) return previous + return (Just version, version) + hledgerInfoFromPath :: Maybe FilePath -> IO HledgerInfo hledgerInfoFromPath pathOption = do hlp <- hledgerPathFromOption pathOption hlv <- hledgerVersionFromPath hlp return $ HledgerInfo hlp hlv +-- | @"hledger 1.50.2, mac-aarch64"@ → @"1.50.2"@. +hledgerVersionNumber :: T.Text -> T.Text +hledgerVersionNumber txt = case dropWhile (== "hledger") (T.words txt) of + v : _ -> T.dropWhileEnd (== ',') v + [] -> "" + +-- | hledger started expanding globs in --file arguments in 1.52. +hledgerFileArgument :: HledgerInfo -> FilePath -> T.Text +hledgerFileArgument info path + | Right (major, rest) <- T.decimal (hledgerVersionNumber (hlVersion info)), + Just suffix <- T.stripPrefix "." rest, + Right (minor, _) <- T.decimal suffix, + (major, minor) >= ((1, 52) :: (Int, Int)) = T.pack (literalGlobPath path) + | otherwise = T.pack path + +-- | Pass only a given config; hledger finds the default one itself. hledgerConfArgs :: RT.RuntimeOptions -> [T.Text] hledgerConfArgs opts = case RT.hledgerConf opts of - Nothing -> [] - Just conf -> ["--conf", T.pack conf] + Just (GivenConf conf) -> ["--conf", T.pack conf] + _ -> [] +-- | The config file hledger will use: the given one, or the first that hledger 1.40+ finds +-- by itself, like possibleConfFiles in hledger's Hledger.Cli.Conf: hledger.conf in the current +-- directory or a parent, ~/.hledger.conf, or hledger.conf in the XDG config directory. +findHledgerConf :: Maybe FilePath -> IO (Maybe HledgerConf) +findHledgerConf (Just given) = return (Just (GivenConf given)) +findHledgerConf Nothing = do + found <- tryIOError $ do + here <- Directory.getCurrentDirectory + home <- Directory.getHomeDirectory + xdg <- Directory.getXdgDirectory Directory.XdgConfig "hledger" + let file d = d FilePath. if d == home then ".hledger.conf" else "hledger.conf" + filterM Directory.doesFileExist (map file (List.nub (upToRoot here ++ [home, xdg]))) + return $ case found of + Right (f : _) -> Just (FoundConf f) + _ -> Nothing + where + upToRoot d = let up = FilePath.takeDirectory d in d : if up == d then [] else upToRoot up + showCmdArgs :: [T.Text] -> T.Text showCmdArgs args = T.intercalate " " (map escapeArg args) +-- | The home folder as HOME spells it and as resolved, so paths from either spelling match, +-- such as macOS's /private/var for /var. +homeDirs :: IO [FilePath] +homeDirs = either (const []) id <$> tryIOError (do + home <- Directory.getHomeDirectory + real <- Directory.canonicalizePath home + return (List.nub [home, real])) + +-- | The path's components below the home folder; @Just []@ for the home folder itself. +belowHome :: [FilePath] -> FilePath -> Maybe [FilePath] +belowHome homes path = case [drop (length h) p | h <- map FilePath.splitDirectories homes, under h] of + rest : _ -> Just rest + [] -> Nothing + where + p = FilePath.splitDirectories path + under h = not (null h) && length h <= length p && and (zipWith FilePath.equalFilePath h p) + +-- | A path for people to read, with the home folder as @~@. +tildePath :: [FilePath] -> FilePath -> FilePath +tildePath homes path = maybe path (FilePath.joinPath . ("~" :)) (belowHome homes path) + +-- | A command line for people to read, with paths under the home folder as @~@. +showCmdArgsAt :: [FilePath] -> [T.Text] -> T.Text +showCmdArgsAt homes = T.unwords . map arg + where + arg a = case belowHome homes (T.unpack a) of + Just [] -> "~" + Just rest -> "~" <> T.singleton FilePath.pathSeparator <> escapeArg (T.pack (FilePath.joinPath rest)) + Nothing -> escapeArg a + +-- | A path under the home folder to paste into a command, as @"$HOME/…"@: the shell expands +-- that, unlike a quoted @~@. 'Nothing' outside the home folder, or when the rest of the path +-- has a character that is special inside double quotes; callers then paste the absolute path. +homeShellPath :: Shell -> [FilePath] -> FilePath -> Maybe T.Text +homeShellPath shell homes path = case belowHome homes path of + Just rest | not (any (any special) rest) -> Just ("\"" <> T.pack (FilePath.joinPath ("$HOME" : rest)) <> "\"") + _ -> Nothing + where + special c = case shell of + Posix -> c `elem` ("$`\"\\!" :: String) + PowerShell -> c `elem` ("$`\"" :: String) || (c >= '\x201c' && c <= '\x201e') + escapeArg :: T.Text -> T.Text escapeArg a | not (T.null a) && T.all safe a = a @@ -137,13 +229,12 @@ escape c | c == '\'' || (c >= '\x2018' && c <= '\x201b') = T.replicate 2 (T.singleton c) | otherwise = T.singleton c -errExit :: Int -> TChan LogMessage -> T.Text -> a -> IO a +errExit :: Int -> TChan LogMessage -> T.Text -> IO a errExit exitStatus ch = errExit' exitStatus (channelErrLn ch) -errExit' :: Int -> (T.Text -> IO ()) -> T.Text -> a -> IO a -errExit' exitStatus logFun errorMessage _ = do +errExit' :: Int -> (T.Text -> IO ()) -> T.Text -> IO a +errExit' exitStatus logFun errorMessage = do logFun errorMessage - threadDelay 100000 exitWith (ExitFailure exitStatus) descriptiveOutput :: T.Text -> T.Text -> T.Text @@ -166,7 +257,8 @@ IO FullTimedOutput logTimedAction opts ch cmdLabel extraCmdLabels cmd args stdoutLogger stderrLogger action = do logVerbose opts ch $ "Begin: " <> cmdLabel - logVerbose opts ch $ cmd <> " " <> T.intercalate " " args + homes <- homeDirs + logVerbose opts ch $ showCmdArgsAt homes (cmd : args) if (List.null extraCmdLabels) then return () else logVerbose opts ch $ T.intercalate "\n" extraCmdLabels timed@((ec, stdOut, stdErr), diff) <- timeAction action stdoutLogger ch stdOut @@ -221,14 +313,15 @@ timed@((ec, stdOut, stdErr), _) <- logTimedAction opts ch cmdLabel extraCmdLabels cmd args stdoutLogger (\_ _ -> return ()) action case ec of ExitFailure i -> do - let cmdText = cmd <> " " <> showCmdArgs args + homes <- homeDirs + let cmdText = showCmdArgsAt homes (cmd : args) let msgOut = descriptiveOutput "Standard output" (trimToolOutput stdOut) let msgErr = descriptiveOutput "Error output" (trimToolOutput stdErr) let exitMsg = "Failed " <> cmdLabel <> " (exit code " <> T.pack (show i) <> ").\n" <> "Command: " <> cmdText <> "\n" <> msgOut <> msgErr <> T.unlines hints - errExit i ch exitMsg timed + errExit i ch exitMsg ExitSuccess -> do stderrLogger ch stdErr return timed @@ -254,14 +347,8 @@ parBatchedActions :: Int -> [a] -> [IO a] -> IO [a] 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 - -- Keep result order, but cancel the batch as soon as any action fails. - results <- mapConcurrently id current - (results ++) <$> runBatches remaining + | null (drop batch todo) = (done ++) <$> mapConcurrently id todo + | otherwise = (done ++) <$> mapConcurrentlyBounded batch id todo verboseTestFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> AbsFile -> IO Bool verboseTestFile opts ch p = do @@ -274,36 +361,14 @@ needsRegeneration :: AbsFile -> AbsFile -> IO Bool needsRegeneration src target = do - 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' = - mapMaybe - ( \ll -> case ll of - [] -> Nothing - ((k, _) : _) -> Just (k, map snd ll) - ) - . List.groupBy ((==) `on` fst) - . List.sortBy (comparing fst) - -groupPairs :: (Eq a, Ord a) => [(a, b)] -> Map.Map a [b] -groupPairs = Map.fromList . groupPairs' - -pairBy :: (a -> b) -> [a] -> [(b, a)] -pairBy keyFun = map (\v -> (keyFun v, v)) + -- A missing or unreadable timestamp also requires regeneration. + newer <- tryIOError $ (>) <$> Path.getModificationTime src <*> Path.getModificationTime target + return (either (const True) id newer) -groupValuesBy :: (Ord k, Ord v) => (v -> k) -> [v] -> Map.Map k [v] -groupValuesBy keyFun = groupPairs . pairBy keyFun +-- | Group by key, preserving input order within each group. +groupValuesBy :: Ord k => (v -> k) -> [v] -> Map.Map k [v] +groupValuesBy key values = + Map.map reverse (Map.fromListWith (++) [(key v, [v]) | v <- values]) allYearsFileName :: FilePath allYearsFileName = "all-years" <.> "journal" @@ -351,7 +416,19 @@ writeTextMap :: Map.Map FilePath T.Text -> IO () writeTextMap files = forM_ (Map.toList files) $ \(path, contents) -> do changed <- textFileNeedsUpdate path contents - when changed $ T.writeFile path contents + when changed $ writeGeneratedText path contents + +writeGeneratedText :: FilePath -> T.Text -> IO () +writeGeneratedText path contents = do + -- Replace the file behind an existing symlink and keep its permissions. + target <- Directory.canonicalizePath path >>= Path.parseAbsFile + withStagedOutput target $ \staged -> do + let tmp = toFilePath staged + exists <- Path.doesFileExist target + when exists $ do + T.writeFile tmp "" + Directory.copyPermissions (toFilePath target) tmp + T.writeFile tmp contents textFileNeedsUpdate :: FilePath -> T.Text -> IO Bool textFileNeedsUpdate path contents = either (const True) (/= contents) <$> tryIOError (T.readFile path) diff --git a/src/Hledger/Flow/DocHelpers.hs b/src/Hledger/Flow/DocHelpers.hs --- a/src/Hledger/Flow/DocHelpers.hs +++ b/src/Hledger/Flow/DocHelpers.hs @@ -1,8 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} -module Hledger.Flow.DocHelpers where +module Hledger.Flow.DocHelpers + ( DocLink (..), + docSlug, + docURL, + siteURL, + ) +where import Data.Text (Text) -docURL :: Text -> Text -docURL section = "https://github.com/apauley/hledger-flow/tree/master/docs#" <> section +-- | Every documentation link the CLI prints. Each one is a permanent +-- @/go//@ URL that redirects to the current page and section, so +-- reorganising the site never breaks links printed by released binaries. +-- Redirect targets live in @site/go-links.json@; a test checks every +-- constructor has one. Never rename a slug once released. +data DocLink + = Docs + | GettingStarted + | InputFiles + | RulesFiles + | PreprocessScript + | SetLedgerFile + deriving (Bounded, Enum, Eq, Show) + +docSlug :: DocLink -> Text +docSlug Docs = "docs" +docSlug GettingStarted = "getting-started" +docSlug InputFiles = "input-files" +docSlug RulesFiles = "rules-files" +docSlug PreprocessScript = "preprocess-script" +docSlug SetLedgerFile = "set-ledger-file" + +siteURL :: Text +siteURL = "https://hledger-flow.github.io/" + +docURL :: DocLink -> Text +docURL link = siteURL <> "go/" <> docSlug link <> "/" diff --git a/src/Hledger/Flow/Environment.hs b/src/Hledger/Flow/Environment.hs --- a/src/Hledger/Flow/Environment.hs +++ b/src/Hledger/Flow/Environment.hs @@ -15,10 +15,11 @@ import Data.Aeson (Value, object, (.=)) import qualified Data.Text as T import Data.Version (showVersion) +import Hledger.Flow.Common (tildePath) import Hledger.Flow.Internals (SystemInfo (..), gitCommit) import Hledger.Flow.RuntimeOptions import Hledger.Flow.Status (hledgerVersionNumber) -import Hledger.Flow.Types (BaseDir, HledgerInfo (..)) +import Hledger.Flow.Types (HledgerConf (..), HledgerInfo (..), hledgerConfPath) import Path (toFilePath) import Paths_hledger_flow (version) import System.FilePath (dropTrailingPathSeparator) @@ -29,22 +30,30 @@ setting :: T.Text -> T.Text -> T.Text -> Setting setting l v f = Setting l v f False --- | What every command shares: hledger-flow, hledger, its config and the ledger. -environmentSettings :: SystemInfo -> Maybe HledgerInfo -> Maybe FilePath -> BaseDir -> [Setting] -environmentSettings sys hledger conf base = +-- | What every command shares: hledger-flow, hledger, and its config. +-- Paths under one of @homes@ show as @~@. +environmentSettings :: [FilePath] -> SystemInfo -> Maybe HledgerInfo -> Maybe HledgerConf -> [Setting] +environmentSettings homes sys hledger conf = [ setting "hledger-flow" (T.pack (showVersion version <> " (" <> gitCommit <> "), " <> compilerName sys <> " " <> showVersion (compilerVersion sys) <> ", " <> os sys <> " " <> arch sys)) "", case hledger of - Just hl -> setting "hledger" (T.pack (toFilePath (hlPath hl)) <> " (" <> hledgerVersionNumber (hlVersion hl) <> ")") "--hledger-path" + Just hl -> setting "hledger" (shown (toFilePath (hlPath hl)) <> " (" <> hledgerVersionNumber (hlVersion hl) <> ")") "--hledger-path" Nothing -> Setting "hledger" "not found" "--hledger-path" True, - setting "hledger.conf" (maybe "none" T.pack conf) "--hledger-conf", - setting "Ledger" (T.pack (dropTrailingPathSeparator (toFilePath base))) "" + setting "hledger.conf" confText "--hledger-conf" ] + where + shown = T.pack . tildePath homes + confText = case conf of + Nothing -> "none" + Just (GivenConf f) -> shown f + Just (FoundConf f) -> shown f <> " (found by hledger)" coresSetting :: SystemInfo -> Setting coresSetting sys = setting "Cores" (tshow (cores sys) <> ", using " <> tshow (availableCores sys)) "" -optsEnvironment :: RuntimeOptions -> [Setting] -optsEnvironment o = environmentSettings (sysInfo o) (Just (hledgerInfo o)) (hledgerConf o) (baseDir o) +optsEnvironment :: [FilePath] -> HledgerInfo -> RuntimeOptions -> [Setting] +optsEnvironment homes info o = + environmentSettings homes (sysInfo o) (Just info) (hledgerConf o) + ++ [setting "Ledger" (T.pack (tildePath homes (dropTrailingPathSeparator (toFilePath (baseDir o))))) ""] parallelism :: RuntimeOptions -> Setting parallelism o = setting "Parallelism" value "--batch-size, --sequential" @@ -54,9 +63,9 @@ | sequential o = "one file at a time" | otherwise = tshow (batchSize o) <> " files at a time, " <> tshow (availableCores sys) <> " of " <> tshow (cores sys) <> " cores" -importSettings :: RuntimeOptions -> [Setting] -importSettings o = - optsEnvironment o +importSettings :: [FilePath] -> HledgerInfo -> RuntimeOptions -> [Setting] +importSettings homes info o = + optsEnvironment homes info o ++ [ setting "Run from" runFrom "", setting "Start year" (maybe "all years" (\y -> tshow y <> " onwards") (importStartYear o)) "--start-year", setting "Files" (if onlyNewFiles o then "only new or changed" else "regenerate all") "--new-files-only", @@ -67,9 +76,9 @@ "." -> ". (whole ledger)" dir -> T.pack dir -reportSettings :: RuntimeOptions -> [Setting] -reportSettings o = - optsEnvironment o +reportSettings :: [FilePath] -> HledgerInfo -> RuntimeOptions -> [Setting] +reportSettings homes info o = + optsEnvironment homes info o ++ [ setting "Tables" (if prettyReports o then "pretty" else "ASCII") "--ascii-reports", parallelism o ] @@ -86,7 +95,7 @@ styled = if sProblem s then problem value else value in T.stripEnd (T.justifyLeft (width sLabel) ' ' (sLabel s) <> " " <> styled <> " " <> sFlags s) -environmentJSON :: SystemInfo -> Maybe FilePath -> Value +environmentJSON :: SystemInfo -> Maybe HledgerConf -> Value environmentJSON sys conf = object [ "hledgerFlowVersion" .= showVersion version, @@ -96,7 +105,7 @@ "arch" .= arch sys, "cores" .= cores sys, "availableCores" .= availableCores sys, - "hledgerConf" .= conf + "hledgerConf" .= fmap hledgerConfPath conf ] tshow :: Show a => a -> T.Text diff --git a/src/Hledger/Flow/Import/CSVImport.hs b/src/Hledger/Flow/Import/CSVImport.hs --- a/src/Hledger/Flow/Import/CSVImport.hs +++ b/src/Hledger/Flow/Import/CSVImport.hs @@ -10,18 +10,17 @@ import Control.Monad import Data.Maybe (fromMaybe) import qualified Data.Text as T -import qualified Data.Text.IO as T import Hledger.Flow.DateTime (timeAction) import Hledger.Flow.Environment (importSettings, renderSettings) import Hledger.Flow.BaseDir (effectiveRunDir, relativeToBase) import Hledger.Flow.Common -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import Hledger.Flow.Import.ImportHelpers -import Hledger.Flow.Import.ImportHelpersTurtle (writeIncludesFromInventory, writeToplevelAllYearsInclude) +import Hledger.Flow.Import.IncludeFiles (writeIncludesFromInventory, writeToplevelAllYearsInclude) import Hledger.Flow.Import.Inventory import Hledger.Flow.Import.Types import Hledger.Flow.Logging -import Hledger.Flow.PathHelpers (AbsFile) +import Hledger.Flow.PathHelpers (AbsDir, AbsFile, isGlobMetacharacter) import Hledger.Flow.RuntimeOptions import qualified Hledger.Flow.Types as FlowTypes import qualified Path @@ -34,16 +33,17 @@ import System.FilePath (dropTrailingPathSeparator, takeExtension, ()) import qualified Data.List as List import Hledger.Flow.Status (plural) -import Hledger.Flow.Status.Gather (accountName, gatherStatus) -import Hledger.Flow.Status.Render (nextStepHere, renderNext, useColor) -import System.IO (stdout) +import Hledger.Flow.Status.Gather (accountName) import Prelude hiding (putStrLn, take, writeFile) type FileWasGenerated = Bool importCSVs :: RuntimeOptions -> IO () importCSVs opts = withConsoleLogging $ \ch -> do - when (showOptions opts) (channelOutLn ch (T.unlines (renderSettings id (importSettings opts)))) + when (showOptions opts) $ do + homes <- homeDirs + info <- hledgerInfo opts + channelOutLn ch (T.unlines (renderSettings id (importSettings homes info opts))) logVerbose opts ch "Starting import" (journals, diff) <- timeAction $ importCSVs' opts ch let importRoot = baseDir opts Path. [Path.reldir|import|] @@ -52,10 +52,6 @@ accounts = List.nub (map (accountName importRoot . fst) journals) channelOutLn ch (importSummary scope (length journals) (length (filter snd journals)) accounts) logVerbose opts ch ("Import took " <> T.pack (show diff)) - status <- gatherStatus (Just (hledgerInfo opts)) (baseDir opts) - next <- nextStepHere status - color <- useColor stdout - channelOut ch (renderNext color next) -- | One line saying what import did. importSummary :: T.Text -> Int -> Int -> [T.Text] -> T.Text @@ -86,14 +82,18 @@ unless (null collisions) $ errExit 1 ch ("Multiple input files map to the same output:\n" <> T.intercalate "\n" [relative output <> " <- " <> T.intercalate ", " (map relative sources) - | (output, sources) <- collisions]) () + | (output, sources) <- collisions]) logVerbose opts ch $ "Found " <> T.pack (show fileCount) <> " input files" <> startYearMsg <> "in " <> T.pack (show diff) <> ". Proceeding with import..." - importedJournals <- parAwareActions opts (map (extractAndImport opts ch) inputFiles) + -- Glob escaping depends on the hledger version. Check it before any worker + -- writes output; conversions reuse this result. directives.journal and + -- cached CSVs share these paths' base and statement names. + when (any (any isGlobMetacharacter . Path.toFilePath) inputFiles) $ void (hledgerVersion opts) + importedJournals <- parAwareActions opts (map (extractAndImport opts ch importRoot) inputFiles) - -- Hooks may create files, so reconcile against a fresh inventory only after - -- every selected conversion succeeds. A cached CSV is never a source. - (refreshed, journalFindTime) <- timeAction $ findImportFiles importRoot - (orphans, journalsOnDisk) <- classifyGeneratedOutputs importRoot refreshed (stageFiles importRoot [Path.reldir|1-in|] refreshed) + -- Running a preprocess hook also forces conversion. When every journal was + -- skipped, neither a hook nor a conversion could have changed the inventory. + let cached = if any snd importedJournals then Nothing else Just inventory + ((refreshed, orphans, journalsOnDisk), journalFindTime) <- timeAction $ reconciliationInventory importRoot cached forM_ (filter selected orphans) $ \file -> do target <- moveToTrash file channelOutLn ch $ "Moved orphaned output " <> relative file <> " to " <> relative target @@ -103,12 +103,12 @@ logVerbose opts ch $ "Wrote include files for " <> T.pack (show (length journalsOnDisk)) <> " generated journals in " <> T.pack (show includeGenTime) return importedJournals -extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> AbsFile -> IO (AbsFile, FileWasGenerated) -extractAndImport opts ch inputFile = do - case extractImportDirs inputFile of +extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> AbsDir -> AbsFile -> IO (AbsFile, FileWasGenerated) +extractAndImport opts ch root inputFile = do + case extractImportDirs root inputFile of Right importDirs -> importCSV opts ch importDirs inputFile Left errorMessage -> do - errExit 1 ch errorMessage (inputFile, False) + errExit 1 ch errorMessage importCSV :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs Path.Abs -> AbsFile -> IO (AbsFile, FileWasGenerated) importCSV opts ch importDirs srcFile = do @@ -135,7 +135,15 @@ case hook of Nothing -> do cached <- verboseTestFile opts ch csvOut - return (if cached then csvOut else src, False) + if cached + then do + stale <- needsRegeneration src csvOut + when stale $ ioError $ userError $ + relativeToBase opts (Path.toFilePath src) ++ " is newer than its cached CSV " + ++ relativeToBase opts (Path.toFilePath csvOut) ++ ". Restore the preprocess hook to regenerate it," + ++ " or move the cached CSV aside to use the source directly. Then run hledger-flow import." + return (csvOut, False) + else return (src, False) Just script -> do regenerate <- if onlyNewFiles opts then needsRegeneration src csvOut else return True if regenerate @@ -196,17 +204,21 @@ case maybeRulesFile of Just rf -> do let relRules = relativeToBase opts (Path.toFilePath rf) - let hledger = T.pack (Path.toFilePath (FlowTypes.hlPath (hledgerInfo opts))) + let hledger = T.pack (Path.toFilePath (hledgerExecutable 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 paths = csvSrc : [Path.toFilePath directives | directivesExist] + fileArgument <- if any (any isGlobMetacharacter) paths + then hledgerFileArgument <$> hledgerInfo opts + else return T.pack + let directivesArgs = if directivesExist then ["--file", fileArgument (Path.toFilePath directives)] else [] + let csvArgs = ["--file", fileArgument csvSrc, "--rules-file", T.pack (Path.toFilePath rf)] let args = hledgerConfArgs opts ++ ["print", "--explicit"] ++ directivesArgs ++ csvArgs let cmdLabel = "importing '" <> T.pack relCSV <> "' using rules file '" <> T.pack relRules <> "'" - let hints = ["Check the skip, fields and separator lines in " <> T.pack relRules <> ".", "Docs: " <> docURL "rules-files"] + let hints = ["Check the skip, fields and separator lines in " <> T.pack relRules <> ".", "Docs: " <> docURL RulesFiles] ((_, stdOut, _), _) <- timeAndExitOnErr' opts ch cmdLabel [] hints dummyLogger channelErr (hledger, args, Nothing) - T.writeFile (Path.toFilePath journalOut) stdOut + writeGeneratedText (Path.toFilePath journalOut) stdOut Nothing -> do let candidatesTxt = T.intercalate "\n" $ map (T.pack . relativeToBase opts . Path.toFilePath) candidates @@ -215,8 +227,8 @@ <> "\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 () + <> docURL RulesFiles + errExit 1 ch msg hookDirArgs :: ImportDirs b -> [T.Text] hookDirArgs dirs = map (T.concat . importDirLines) [bankDir dirs, accountDir dirs, ownerDir dirs] @@ -226,11 +238,12 @@ 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 + homes <- homeDirs + let constructCmdText = "Running: " <> T.pack relScript <> " " <> showCmdArgsAt homes constructArgs (cmd, hookArgs) <- hookCommand constructScript constructArgs let hook = (Process.proc (T.unpack cmd) (map T.unpack hookArgs)) { Process.std_in = Process.CreatePipe, Process.std_out = Process.CreatePipe } - let hledger = T.pack (Path.toFilePath (FlowTypes.hlPath (hledgerInfo opts))) + let hledger = T.pack (Path.toFilePath (hledgerExecutable opts)) let args = hledgerConfArgs opts ++ [ "print", diff --git a/src/Hledger/Flow/Import/ImportHelpers.hs b/src/Hledger/Flow/Import/ImportHelpers.hs --- a/src/Hledger/Flow/Import/ImportHelpers.hs +++ b/src/Hledger/Flow/Import/ImportHelpers.hs @@ -7,34 +7,28 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Hledger.Flow.Common (groupValuesBy) -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import Hledger.Flow.Import.Types (ImportDirs (..), InputFileBundle) -import Hledger.Flow.PathHelpers (AbsFile, RelDir, RelFile, pathSize) +import Hledger.Flow.PathHelpers (AbsFile, RelDir, RelFile, pathSize, withStagedOutput) import Path -import qualified Path.IO as PathIO import Control.Monad.Catch (MonadThrow) -import System.FilePath (dropExtensions, dropTrailingPathSeparator) +import System.FilePath (dropTrailingPathSeparator) import qualified System.FilePath as FilePath --- 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) [] +extractImportDirs :: Path b Dir -> Path b File -> Either T.Text (ImportDirs b) +extractImportDirs root inputFile = + -- Split the short relative part once: each Path.parent renormalises the whole path. + case FilePath.splitDirectories . toFilePath <$> stripProperPrefix root inputFile of + Just [owner, bank, account, state, year, _] -> maybe malformed Right $ do + ownerD <- below root owner + bankD <- below ownerD bank + accountD <- below bankD account + stateD <- below accountD state + yearD <- below stateD year + return (ImportDirs root ownerD bankD accountD stateD yearD) + _ -> malformed 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) + below dir name = (dir ) <$> parseRelDir name malformed = Left $ "I couldn't find the right number of directories between \"import\" and the input file:\n" @@ -42,7 +36,7 @@ <> "\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" + <> docURL InputFiles groupIncludesUpTo :: RelDir -> [RelFile] -> InputFileBundle groupIncludesUpTo stopAt = collect Map.empty @@ -74,15 +68,18 @@ -- then the account's default rules files. rulesFileCandidates :: AbsFile -> ImportDirs Abs -> IO [AbsFile] rulesFileCandidates csv dirs = do - overrides <- if "rfo" `T.isPrefixOf` suffix + overrides <- if "rfo" `T.isPrefixOf` suffix && not (T.any (== '_') suffix) then do name <- rulesName [suffix] return [dir name | dir <- [accountDir dirs, bankDir dirs, importDir dirs]] else return [] (overrides ++) <$> defaultRulesCandidates dirs where - stem = dropExtensions (toFilePath (filename csv)) - suffix = snd (T.breakOnEnd "_" (T.pack stem)) + statementName = T.pack (toFilePath (filename csv)) + -- The statement prefix may contain dots, and the override may have several extensions. + suffix = T.takeWhile (/= '.') $ case T.breakOnEnd "_rfo" statementName of + ("", _) -> statementName + (_, rest) -> "rfo" <> rest -- | The account-level and bank-level rules files, in lookup order. defaultRulesCandidates :: ImportDirs Abs -> IO [AbsFile] diff --git a/src/Hledger/Flow/Import/ImportHelpersTurtle.hs b/src/Hledger/Flow/Import/ImportHelpersTurtle.hs deleted file mode 100644 --- a/src/Hledger/Flow/Import/ImportHelpersTurtle.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - --- | Generate journal include files and their relative include directives. -module Hledger.Flow.Import.ImportHelpersTurtle - ( extraIncludesForFile, - includePreamble, - includesNeedUpdate, - toIncludeFiles, - toIncludeLine, - writeIncludesFromInventory, - writeToplevelAllYearsInclude, - yearsIncludeMap, - ) -where - -import Control.Concurrent.STM (TChan) -import Control.Monad (filterM, unless) -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 qualified Data.Text.IO as T -import Hledger.Flow.BaseDir (relativeToBase') -import Hledger.Flow.Common (allYearsFileName, filterPaths, groupValuesBy, textFileNeedsUpdate, writeFiles') -import Hledger.Flow.Import.ImportHelpers (groupIncludesUpTo) -import Hledger.Flow.Import.Inventory (manualIncludeFiles, managedIncludeFiles) -import Hledger.Flow.Import.Types -import Hledger.Flow.Logging (logVerbose) -import Hledger.Flow.PathHelpers (AbsDir, AbsFile) -import Hledger.Flow.Types -import qualified Path -import qualified Path.IO as PathIO -import System.Directory (doesFileExist) -import qualified System.FilePath as FilePath -import System.FilePath (()) - -isJournalFile :: FilePath -> Bool -isJournalFile f = FilePath.takeExtension f == ".journal" - -yearsIncludeMap :: [FilePath] -> TurtleFileBundle -yearsIncludeMap = groupValuesBy allYearsPath - -allYearsPath :: FilePath -> FilePath -allYearsPath journal = fst (FilePath.splitFileName journal) allYearsFileName - -toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> TurtleFileBundle -> IO (Map.Map FilePath T.Text) -toIncludeFiles opts ch = renderIncludeFiles (baseDir opts) (logVerbose opts ch) - -renderIncludeFiles :: BaseDir -> (T.Text -> IO ()) -> TurtleFileBundle -> IO (Map.Map FilePath T.Text) -renderIncludeFiles base logMessage m = do - let extras suffixes manual prices = Map.unions <$> mapM - (\file -> findExtraIncludes base logMessage file suffixes manual prices) (Map.keys m) - preMap <- extras ["opening.journal"] ["pre-import.journal"] [] - postMap <- extras ["closing.journal"] ["post-import.journal"] ["prices.journal"] - return $ (addPreamble . toIncludeFiles' preMap postMap) m - -toIncludeFiles' :: TurtleFileBundle -> TurtleFileBundle -> TurtleFileBundle -> Map.Map FilePath T.Text -toIncludeFiles' preMap postMap = Map.mapWithKey $ generatedIncludeText preMap postMap - -addPreamble :: Map.Map FilePath T.Text -> Map.Map FilePath T.Text -addPreamble = Map.map (\txt -> includePreamble <> "\n" <> txt) - -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 -> 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 $ FilePath.takeDirectory outputFile) $ preFiles ++ files ++ postFiles - T.intercalate "\n" $ lns ++ [""] - -includePreamble :: T.Text -includePreamble = "### Generated by hledger-flow - DO NOT EDIT ###\n" - -writeIncludesFromInventory :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> AbsDir -> [AbsFile] -> [AbsFile] -> IO [AbsFile] -writeIncludesFromInventory opts ch stopAt inventory journals = do - (files, roots) <- expectedIncludes (baseDir opts) (logVerbose opts ch) stopAt inventory journals - _ <- writeFiles' files - return roots - --- | Check the same contents import would write, including obsolete generated indexes. -includesNeedUpdate :: BaseDir -> AbsDir -> [AbsFile] -> [AbsFile] -> IO Bool -includesNeedUpdate base root inventory journals = do - (includes, _) <- expectedIncludes base (const (return ())) root inventory journals - top <- toplevelAllYearsInclude base - anyChanged (Map.toList (Map.union top includes)) - where - anyChanged [] = return False - anyChanged ((file, contents) : rest) = do - changed <- textFileNeedsUpdate file contents - if changed then return True else anyChanged rest - -expectedIncludes :: BaseDir -> (T.Text -> IO ()) -> AbsDir -> [AbsFile] -> [AbsFile] -> IO (Map.Map FilePath T.Text, [AbsFile]) -expectedIncludes base logMessage stopAt inventory journals = do - let importRoot = base Path. [Path.reldir|import|] - 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 - manual <- manualIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory) - seeds <- mapM (Path.stripProperPrefix base) manual - let groups = Map.unionsWith (++) - [ groupIncludesUpTo boundary inputs, - groupIncludesUpTo boundary seeds, - Map.fromList [(seed, []) | seed <- seeds] - ] - 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 - indexes = Map.insertWith (++) allAtStop [] years - old = managedIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory) - rendered <- renderIncludeFiles base logMessage includes - let current = Map.union rendered ((addPreamble . toIncludeFiles' Map.empty Map.empty) indexes) - emptyIndex = includePreamble <> "\n" - -- Users may still open obsolete generated indexes directly. Leave hand-written files alone. - obsolete <- filterM (needsClearing emptyIndex) [file | file <- map Path.toFilePath old, Map.notMember file current] - let files = Map.union current (Map.fromList [(file, emptyIndex) | file <- obsolete]) - return (files, [base Path. f | f <- Map.keys groups, Path.parent f == boundary]) - where - needsClearing emptyIndex file = do - text <- T.readFile file - return (includePreamble `T.isPrefixOf` text && text /= emptyIndex) - -writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath] -writeToplevelAllYearsInclude opts = toplevelAllYearsInclude (baseDir opts) >>= writeFiles' - -toplevelAllYearsInclude :: BaseDir -> IO (Map.Map FilePath T.Text) -toplevelAllYearsInclude base = do - let directives = base Path. [Path.relfile|directives.journal|] - top = Path.toFilePath base allYearsFileName - directivesExists <- PathIO.doesFileExist directives - let preMap = if directivesExists then Map.singleton top [Path.toFilePath directives] else Map.empty - allTop = Map.singleton top ["import" allYearsFileName] - return $ (addPreamble . toIncludeFiles' preMap Map.empty) allTop - -extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle -extraIncludesForFile opts ch = findExtraIncludes (baseDir opts) (logVerbose opts ch) - -findExtraIncludes :: BaseDir -> (T.Text -> IO ()) -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO TurtleFileBundle -findExtraIncludes base logMessage file extraSuffixes manualFiles prices = do - 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 <- filterPaths doesFileExist extraFiles - let relative = relativeToBase' (Path.toFilePath base) - logMsg = - "Looking for possible extra include files for '" <> T.pack (relative file) - <> "' among these " <> T.pack (show (length extraFiles)) <> " options: " - <> T.pack (show (map (T.pack . relative) extraFiles)) - <> ". Found " <> T.pack (show (length filtered)) <> ": " - <> T.pack (show (map (T.pack . relative) filtered)) - logMessage logMsg - return $ Map.fromList [(file, filtered)] diff --git a/src/Hledger/Flow/Import/IncludeFiles.hs b/src/Hledger/Flow/Import/IncludeFiles.hs new file mode 100644 --- /dev/null +++ b/src/Hledger/Flow/Import/IncludeFiles.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | Generate journal include files and their relative include directives. +module Hledger.Flow.Import.IncludeFiles + ( extraIncludesForFile, + includePreamble, + includesNeedUpdate, + toIncludeFiles, + toIncludeLine, + writeIncludesFromInventory, + writeToplevelAllYearsInclude, + yearsIncludeMap, + ) +where + +import Control.Concurrent.STM (TChan) +import Control.Monad (filterM, unless) +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 qualified Data.Text.IO as T +import Hledger.Flow.BaseDir (relativeToBase') +import Hledger.Flow.Common (allYearsFileName, filterPaths, groupValuesBy, textFileNeedsUpdate, writeFiles') +import Hledger.Flow.Import.ImportHelpers (groupIncludesUpTo) +import Hledger.Flow.Import.Inventory (manualIncludeFiles, managedIncludeFiles) +import Hledger.Flow.Import.Types +import Hledger.Flow.Logging (logVerbose) +import Hledger.Flow.PathHelpers (AbsDir, AbsFile, literalGlobPath) +import Hledger.Flow.Types +import qualified Path +import qualified Path.IO as PathIO +import System.Directory (doesFileExist) +import qualified System.FilePath as FilePath +import System.FilePath (()) + +isJournalFile :: FilePath -> Bool +isJournalFile f = FilePath.takeExtension f == ".journal" + +yearsIncludeMap :: [FilePath] -> IncludeFileMap +yearsIncludeMap = groupValuesBy allYearsPath + +allYearsPath :: FilePath -> FilePath +allYearsPath journal = fst (FilePath.splitFileName journal) allYearsFileName + +toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> IncludeFileMap -> IO (Map.Map FilePath T.Text) +toIncludeFiles opts ch = renderIncludeFiles (baseDir opts) (logVerbose opts ch) + +renderIncludeFiles :: BaseDir -> (T.Text -> IO ()) -> IncludeFileMap -> IO (Map.Map FilePath T.Text) +renderIncludeFiles base logMessage m = do + let extras suffixes manual prices = Map.unions <$> mapM + (\file -> findExtraIncludes base logMessage file suffixes manual prices) (Map.keys m) + preMap <- extras ["opening.journal"] ["pre-import.journal"] [] + postMap <- extras ["closing.journal"] ["post-import.journal"] ["prices.journal"] + return $ (addPreamble . toIncludeFiles' preMap postMap) m + +toIncludeFiles' :: IncludeFileMap -> IncludeFileMap -> IncludeFileMap -> Map.Map FilePath T.Text +toIncludeFiles' preMap postMap = Map.mapWithKey $ generatedIncludeText preMap postMap + +addPreamble :: Map.Map FilePath T.Text -> Map.Map FilePath T.Text +addPreamble = Map.map (\txt -> includePreamble <> "\n" <> txt) + +toIncludeLine :: FilePath -> FilePath -> T.Text +toIncludeLine base file = "include " <> T.pack (literalGlobPath (map forwardSlash (relativeToBase' base file))) + where + forwardSlash c = if FilePath.isPathSeparator c then '/' else c + +generatedIncludeText :: IncludeFileMap -> IncludeFileMap -> 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 $ FilePath.takeDirectory outputFile) $ preFiles ++ files ++ postFiles + T.intercalate "\n" $ lns ++ [""] + +includePreamble :: T.Text +includePreamble = "### Generated by hledger-flow - DO NOT EDIT ###\n" + +writeIncludesFromInventory :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> AbsDir -> [AbsFile] -> [AbsFile] -> IO [AbsFile] +writeIncludesFromInventory opts ch stopAt inventory journals = do + (files, roots) <- expectedIncludes (baseDir opts) (logVerbose opts ch) stopAt inventory journals + _ <- writeFiles' files + return roots + +-- | Check the same contents import would write, including obsolete generated indexes. +includesNeedUpdate :: BaseDir -> AbsDir -> [AbsFile] -> [AbsFile] -> IO Bool +includesNeedUpdate base root inventory journals = do + (includes, _) <- expectedIncludes base (const (return ())) root inventory journals + top <- toplevelAllYearsInclude base + anyChanged (Map.toList (Map.union top includes)) + where + anyChanged [] = return False + anyChanged ((file, contents) : rest) = do + changed <- textFileNeedsUpdate file contents + if changed then return True else anyChanged rest + +expectedIncludes :: BaseDir -> (T.Text -> IO ()) -> AbsDir -> [AbsFile] -> [AbsFile] -> IO (Map.Map FilePath T.Text, [AbsFile]) +expectedIncludes base logMessage stopAt inventory journals = do + let importRoot = base Path. [Path.reldir|import|] + 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 + manual <- manualIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory) + seeds <- mapM (Path.stripProperPrefix base) manual + let groups = Map.unionsWith (++) + [ groupIncludesUpTo boundary inputs, + groupIncludesUpTo boundary seeds, + Map.fromList [(seed, []) | seed <- seeds] + ] + 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 + indexes = Map.insertWith (++) allAtStop [] years + old = managedIncludeFiles importRoot (filter (Path.isProperPrefixOf stopAt) inventory) + rendered <- renderIncludeFiles base logMessage includes + let current = Map.union rendered ((addPreamble . toIncludeFiles' Map.empty Map.empty) indexes) + emptyIndex = includePreamble <> "\n" + -- Users may still open obsolete generated indexes directly. Leave hand-written files alone. + obsolete <- filterM (needsClearing emptyIndex) [file | file <- map Path.toFilePath old, Map.notMember file current] + let files = Map.union current (Map.fromList [(file, emptyIndex) | file <- obsolete]) + return (files, [base Path. f | f <- Map.keys groups, Path.parent f == boundary]) + where + needsClearing emptyIndex file = do + text <- T.readFile file + return (includePreamble `T.isPrefixOf` text && text /= emptyIndex) + +writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath] +writeToplevelAllYearsInclude opts = toplevelAllYearsInclude (baseDir opts) >>= writeFiles' + +toplevelAllYearsInclude :: BaseDir -> IO (Map.Map FilePath T.Text) +toplevelAllYearsInclude base = do + let directives = base Path. [Path.relfile|directives.journal|] + top = Path.toFilePath base allYearsFileName + directivesExists <- PathIO.doesFileExist directives + let preMap = if directivesExists then Map.singleton top [Path.toFilePath directives] else Map.empty + allTop = Map.singleton top ["import" allYearsFileName] + return $ (addPreamble . toIncludeFiles' preMap Map.empty) allTop + +extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO IncludeFileMap +extraIncludesForFile opts ch = findExtraIncludes (baseDir opts) (logVerbose opts ch) + +findExtraIncludes :: BaseDir -> (T.Text -> IO ()) -> FilePath -> [T.Text] -> [FilePath] -> [FilePath] -> IO IncludeFileMap +findExtraIncludes base logMessage file extraSuffixes manualFiles prices = do + 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 <- filterPaths doesFileExist extraFiles + let relative = relativeToBase' (Path.toFilePath base) + logMsg = + "Looking for possible extra include files for '" <> T.pack (relative file) + <> "' among these " <> T.pack (show (length extraFiles)) <> " options: " + <> T.pack (show (map (T.pack . relative) extraFiles)) + <> ". Found " <> T.pack (show (length filtered)) <> ": " + <> T.pack (show (map (T.pack . relative) filtered)) + logMessage logMsg + return $ Map.fromList [(file, filtered)] diff --git a/src/Hledger/Flow/Import/Inventory.hs b/src/Hledger/Flow/Import/Inventory.hs --- a/src/Hledger/Flow/Import/Inventory.hs +++ b/src/Hledger/Flow/Import/Inventory.hs @@ -7,9 +7,10 @@ stageFiles, inImportScope, generatedOutput, - expectedOutputs, classifyGeneratedOutputs, + reconciliationInventory, conflictingOutputs, + cannotAlias, canonicalFile, manualIncludeFiles, isManualJournal, @@ -19,17 +20,18 @@ where import Control.Exception (bracket_) -import Control.Monad (forM) -import Data.Char (isDigit) +import Control.Monad (filterM, forM) +import Data.Char (isAscii, isDigit, isPrint, toLower) import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Hledger.Flow.Common (groupValuesBy, homeDirs, tildePath) import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelDir) import Path import qualified Path.IO as PathIO import qualified System.Directory as Directory import qualified System.FilePath as FilePath -import System.IO.Error (catchIOError, isAlreadyExistsError, isDoesNotExistError) +import System.IO.Error (catchIOError, isAlreadyExistsError, isDoesNotExistError, tryIOError) findImportFiles :: AbsDir -> IO [AbsFile] findImportFiles root = List.sort <$> PathIO.walkDirAccum (Just exclude) collect root @@ -63,31 +65,60 @@ year = FilePath.dropTrailingPathSeparator (toFilePath (dirname (parent file))) generatedOutput :: RelDir -> String -> AbsFile -> IO AbsFile -generatedOutput stage extension source = do - name <- parseRelFile (FilePath.replaceExtension (toFilePath (filename source)) extension) - return (parent (parent (parent source)) stage dirname (parent source) name) - -expectedOutputs :: [AbsFile] -> IO (Map.Map AbsFile [AbsFile]) -expectedOutputs sources = do - pairs <- outputPairs sources - canonical <- forM pairs $ \(output, source) -> do - key <- canonicalFile output - return (key, [source]) - return (Map.fromListWith (++) canonical) +generatedOutput stage extension source = + -- One parse instead of chained Path.parent calls, which each renormalise the whole path. + parseAbsFile (account FilePath. toFilePath stage FilePath. FilePath.takeFileName yearDir FilePath. name) + where + file = toFilePath source + yearDir = FilePath.takeDirectory file + account = FilePath.takeDirectory (FilePath.takeDirectory yearDir) + name = FilePath.replaceExtension (FilePath.takeFileName file) extension -- | Orphaned generated files and the source-backed journals to include. classifyGeneratedOutputs :: AbsDir -> [AbsFile] -> [AbsFile] -> IO ([AbsFile], [AbsFile]) classifyGeneratedOutputs root inventory sources = do - expected <- expectedOutputs sources - let staged stage ext = filter ((== ext) . FilePath.takeExtension . toFilePath) (stageFiles root stage inventory) + pairs <- outputPairs sources + let expected = Set.fromList (map (toFilePath . fst) pairs) + staged stage ext = filter ((== ext) . FilePath.takeExtension . toFilePath) (stageFiles root stage inventory) cached = staged [reldir|2-preprocessed|] ".csv" journals = staged [reldir|3-journal|] ".journal" - classified <- forM (cached ++ journals) $ \file -> do - key <- canonicalFile file - return (file, Map.member key expected) - return ([file | (file, False) <- classified], - [file | (file, True) <- classified, FilePath.takeExtension (toFilePath file) == ".journal"]) + unmatched = filter ((`Set.notMember` expected) . toFilePath) (cached ++ journals) + -- A differently spelled output can alias any expected file, even one which + -- also matched literally (for example, through a symlink). + orphans <- if null unmatched then return [] else do + resolved <- Set.fromList <$> mapM (canonicalFile . fst) pairs + filterM (fmap (`Set.notMember` resolved) . canonicalFile) unmatched + let retired = Set.fromList orphans + active = filter (`Set.notMember` retired) journals + preferExpected a b = if rank a <= rank b then a else b + rank file = (Set.notMember (toFilePath file) expected, file) + -- Resolve year directories once, including symlinked directories. Names + -- came from listing the directory, so only symlinks need a full lookup. + groups <- forM (Map.toList (groupValuesBy (FilePath.takeDirectory . toFilePath) active)) $ \(dir, files) -> do + resolvedDir <- Directory.canonicalizePath dir + forM files $ \file -> do + link <- PathIO.isSymlink file + key <- if link then Directory.canonicalizePath (toFilePath file) + else return (resolvedDir FilePath. FilePath.takeFileName (toFilePath file)) + return (key, file) + let chosen = Map.fromListWith preferExpected (concat groups) + return (orphans, List.sort (Map.elems chosen)) +-- | Inventory, orphaned outputs and source-backed journals for reconciliation. +-- Includes cover every year and account, even when orphan moves are scoped. +reconciliationInventory :: AbsDir -> Maybe [AbsFile] -> IO ([AbsFile], [AbsFile], [AbsFile]) +reconciliationInventory root cached = case cached of + Nothing -> refresh + Just files -> do + result@(_, orphans, _) <- classify files + if null orphans then return result else refresh + where + -- A source may have been restored since discovery. + refresh = findImportFiles root >>= classify + classify files = do + (orphans, journals) <- classifyGeneratedOutputs root files (stageFiles root [reldir|1-in|] files) + return (files, orphans, journals) + canonicalFile :: AbsFile -> IO AbsFile canonicalFile file = Directory.canonicalizePath (toFilePath file) >>= parseAbsFile @@ -104,25 +135,48 @@ conflictingOutputs :: [AbsFile] -> IO [(AbsFile, [AbsFile])] conflictingOutputs sources = do pairs <- outputPairs sources - grouped <- forM pairs $ \pair@(output, _) -> do - directory <- Directory.canonicalizePath (toFilePath (parent output)) >>= parseAbsDir - return (directory, [pair]) - fmap concat $ forM (Map.toAscList (Map.fromListWith (++) grouped)) $ \(directory, outputs) -> do - existing <- nearestDirectory directory - PathIO.withTempDir existing ".hledger-flow-destinations-" $ \tmp -> do - names <- forM outputs $ \pair@(output, _) -> do - name <- parseRelDir (toFilePath (filename output)) - let probe = tmp name - PathIO.createDirIfMissing True probe - key <- Directory.canonicalizePath (toFilePath probe) - return (key, [pair]) - return [(output, source : map snd rest) - | (output, source) : rest <- Map.elems (Map.fromListWith (++) names), not (null rest)] + -- Resolve each parent once, including links shared by different accounts. + let byParent = groupValuesBy (parent . fst) pairs + groups <- forM (Map.toList byParent) $ \(dir, outputs) -> do + resolved <- Directory.canonicalizePath (toFilePath dir) >>= parseAbsDir + return (resolved, outputs) + concat <$> mapM checkDirectory (Map.toList (Map.fromListWith (++) groups)) where + checkDirectory (_, [_]) = return [] + checkDirectory (_, outputs) | cannotAlias (outputNames outputs) = return [] + checkDirectory (directory, outputs) = do + let names = outputNames outputs + distinct = Set.fromList names + listed <- tryIOError (Directory.listDirectory (toFilePath directory)) + case listed of + Right entries + | Set.size distinct == length names && distinct `Set.isSubsetOf` Set.fromList entries -> return [] + _ -> do + existing <- nearestDirectory directory + PathIO.withTempDir existing ".hledger-flow-destinations-" $ \tmp -> do + let probes = map (toFilePath tmp FilePath.) names + mapM_ (Directory.createDirectoryIfMissing False) probes + entries <- Directory.listDirectory (toFilePath tmp) + if length entries == length names then return [] else do + -- Resolve individual probes only when some names actually alias. + keys <- mapM Directory.canonicalizePath probes + let groups = Map.fromListWith (++) (zip keys (map (:[]) outputs)) + return [(output, source : map snd rest) + | (output, source) : rest <- Map.elems groups, not (null rest)] + + outputNames = map (toFilePath . filename . fst) + nearestDirectory directory = do exists <- PathIO.doesDirExist directory if exists then return directory else nearestDirectory (parent directory) +-- | Generated .csv and .journal names stay distinct when they differ even +-- ignoring case, are plain ASCII and contain no Windows short-name marker (~). +cannotAlias :: [String] -> Bool +cannotAlias names = all plain names && Set.size (Set.fromList (map (map toLower) names)) == length names + where + plain = all (\c -> isAscii c && isPrint c && c /= '~') + -- Seed the include at the manual file's own level; its contents are added by -- the existing pre/post renderer, keeping ordering and avoiding duplicates. manualIncludeFiles :: AbsDir -> [AbsFile] -> IO [AbsFile] @@ -159,7 +213,7 @@ destination = trash year stage acquire = Directory.createDirectory (toFilePath lock) `catchIOError` \err -> if isAlreadyExistsError err - then ioError (userError ("Trash is in use: " ++ toFilePath lock + then homeDirs >>= \homes -> ioError (userError ("Trash is in use: " ++ tildePath homes (toFilePath lock) ++ ". If no import is running, remove this empty lock directory and retry.")) else ioError err PathIO.createDirIfMissing True trash diff --git a/src/Hledger/Flow/Import/Types.hs b/src/Hledger/Flow/Import/Types.hs --- a/src/Hledger/Flow/Import/Types.hs +++ b/src/Hledger/Flow/Import/Types.hs @@ -4,7 +4,7 @@ import Hledger.Flow.PathHelpers (RelFile) import Path (Dir, Path) -type TurtleFileBundle = Map.Map FilePath [FilePath] +type IncludeFileMap = Map.Map FilePath [FilePath] type InputFileBundle = Map.Map RelFile [RelFile] diff --git a/src/Hledger/Flow/Init.hs b/src/Hledger/Flow/Init.hs --- a/src/Hledger/Flow/Init.hs +++ b/src/Hledger/Flow/Init.hs @@ -9,17 +9,17 @@ ) where -import Control.Exception (IOException, catch) import Control.Monad (when) import qualified Data.Text as T import qualified Data.Text.IO as T import Hledger.Flow.BaseDir (findBaseDir) -import Hledger.Flow.Common (Shell (..), nativeShell, shellArgument) +import Data.Maybe (fromMaybe) +import Hledger.Flow.Common (Shell (..), homeDirs, homeShellPath, nativeShell, shellArgument, tildePath) import Hledger.Flow.PathHelpers (AbsDir) -import Hledger.Flow.Status.Render (printNext, tildePath) +import Hledger.Flow.Status.Render (printNext) import Hledger.Flow.Types (BaseDir) import Path -import Path.IO (createDirIfMissing, doesDirExist, getHomeDir) +import Path.IO (createDirIfMissing, doesDirExist) import qualified System.FilePath as FilePath data InitOutcome @@ -48,9 +48,9 @@ -- | Run @hledger-flow init@ for a folder, printing what happened and what's next. runInit :: Maybe FilePath -> AbsDir -> AbsDir -> IO () runInit hledgerPath cwd dir = do - home <- (Just <$> getHomeDir) `catch` (\e -> const (return Nothing) (e :: IOException)) - let absolute = T.pack . FilePath.dropTrailingPathSeparator . toFilePath - shown = T.pack . tildePath home . T.unpack . absolute + homes <- homeDirs + let absolute = FilePath.dropTrailingPathSeparator . toFilePath + shown = T.pack . tildePath homes . absolute outcome <- initLedger dir case outcome of AlreadyLedger b -> @@ -66,5 +66,6 @@ let changeDir = case nativeShell of Posix -> "cd " PowerShell -> "Set-Location -LiteralPath " - T.putStrLn ("Change to it first: " <> changeDir <> shellArgument nativeShell (absolute base)) + path = absolute base + T.putStrLn ("Change to it first: " <> changeDir <> fromMaybe (shellArgument nativeShell (T.pack path)) (homeShellPath nativeShell homes path)) printNext hledgerPath base diff --git a/src/Hledger/Flow/Logging.hs b/src/Hledger/Flow/Logging.hs --- a/src/Hledger/Flow/Logging.hs +++ b/src/Hledger/Flow/Logging.hs @@ -4,6 +4,7 @@ import Control.Concurrent.Async (wait, withAsync) import Control.Concurrent.STM +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, tryJust) import Control.Monad (when) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -41,10 +42,16 @@ withConsoleLogging action = do ch <- newTChanIO withAsync (consoleChannelLoop ch) $ \logger -> do - result <- action ch + result <- tryJust synchronous (action ch) terminateChannelLoop ch wait logger - return result + either throwIO return result + where + -- Drain queued diagnostics on failure, but allow Ctrl-C to cancel a blocked writer. + synchronous :: SomeException -> Maybe SomeException + synchronous err = case fromException err :: Maybe SomeAsyncException of + Just _ -> Nothing + Nothing -> Just err consoleChannelLoop :: TChan LogMessage -> IO () consoleChannelLoop ch = do diff --git a/src/Hledger/Flow/PathHelpers.hs b/src/Hledger/Flow/PathHelpers.hs --- a/src/Hledger/Flow/PathHelpers.hs +++ b/src/Hledger/Flow/PathHelpers.hs @@ -5,7 +5,7 @@ import Control.Monad.Catch (Exception, MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Text as T -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import qualified Path import qualified Path.IO as Path import System.Directory (doesDirectoryExist) @@ -19,7 +19,29 @@ type RelDir = Path.Path Path.Rel Path.Dir -data PathException = MissingBaseDir AbsDir | InvalidTurtleDir FilePath +-- | Publish a complete file by renaming it on the destination filesystem. +withStagedOutput :: AbsFile -> (AbsFile -> IO ()) -> IO () +withStagedOutput target writeOutput = do + let dir = Path.parent target + Path.createDirIfMissing True dir + Path.withTempDir dir ".hledger-flow-" $ \tmp -> do + let staged = tmp Path. Path.filename target + writeOutput staged + Path.renameFile staged target + +isGlobMetacharacter :: Char -> Bool +isGlobMetacharacter c = c `elem` ("*?[{<" :: String) + +-- | Match one literal path in an hledger glob. A range of one character +-- keeps hledger's include reader from treating the encoded spelling as a filename. +literalGlobPath :: FilePath -> FilePath +literalGlobPath = concatMap escape + where + escape c + | isGlobMetacharacter c = ['[', c, '-', c, ']'] + | otherwise = [c] + +data PathException = MissingBaseDir AbsDir | NotADirectory FilePath deriving (Eq) instance Show PathException where @@ -29,32 +51,17 @@ ++ ").\n" ++ "Run `hledger-flow init` to start one here, or pass the ledger's folder as an argument.\n" ++ "Docs: " - ++ T.unpack (docURL "getting-started") - show (InvalidTurtleDir d) = "Not a folder: " ++ d + ++ T.unpack (docURL GettingStarted) + show (NotADirectory d) = "Not a folder: " ++ d instance Exception PathException -fromTurtleAbsFile :: (MonadThrow m) => FilePath -> m AbsFile -fromTurtleAbsFile turtlePath = Path.parseAbsFile turtlePath - -fromTurtleRelFile :: (MonadThrow m) => FilePath -> m RelFile -fromTurtleRelFile turtlePath = Path.parseRelFile turtlePath - -fromTurtleAbsDir :: (MonadThrow m) => FilePath -> m AbsDir -fromTurtleAbsDir turtlePath = Path.parseAbsDir turtlePath - -fromTurtleRelDir :: (MonadThrow m) => FilePath -> m RelDir -fromTurtleRelDir turtlePath = Path.parseRelDir turtlePath - -turtleToAbsDir :: (MonadIO m, MonadThrow m) => AbsDir -> FilePath -> m AbsDir -turtleToAbsDir baseDir p = do +resolveExistingDir :: (MonadIO m, MonadThrow m) => AbsDir -> FilePath -> m AbsDir +resolveExistingDir baseDir p = do isDir <- liftIO (doesDirectoryExist p) if isDir then Path.resolveDir baseDir p - else throwM $ InvalidTurtleDir p - -pathToTurtle :: Path.Path b t -> FilePath -pathToTurtle = Path.toFilePath + else throwM $ NotADirectory p forceTrailingSlash :: FilePath -> FilePath forceTrailingSlash = FilePath.addTrailingPathSeparator . FilePath.normalise diff --git a/src/Hledger/Flow/ReleaseNotice.hs b/src/Hledger/Flow/ReleaseNotice.hs --- a/src/Hledger/Flow/ReleaseNotice.hs +++ b/src/Hledger/Flow/ReleaseNotice.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Hledger.Flow.ReleaseNotice - ( withReleaseNotice, startCheck, finishCommand, checkRelease + ( ReleaseResult (..), withReleaseNotice, startCheck, + finishCommand, checkRelease, renderUpdate ) where import Control.Concurrent.Async (async, poll) @@ -16,6 +17,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Version (Version, parseVersion, showVersion) +import Hledger.Flow.Status.Render (useColor, yellow) import Network.HTTP.Client (HttpException, checkResponse, httpLbs, parseRequest, requestHeaders, responseBody, throwErrorStatusCodes) import Network.HTTP.Client.TLS (getGlobalManager) import Paths_hledger_flow (version) @@ -28,6 +30,9 @@ import System.Timeout (timeout) import Text.ParserCombinators.ReadP (eof, readP_to_S) +data ReleaseResult = UpToDate | UpdateAvailable !Version !T.Text | CheckUnavailable + deriving (Eq, Show) + withReleaseNotice :: IO () -> IO () withReleaseNotice command = do finish <- setup `catchIOError` const (pure (pure ())) @@ -41,19 +46,29 @@ then startCheck (checkRelease fetch getExecutablePath) else pure (pure ()) --- The worker belongs to this CLI invocation. Do not join it or synchronously --- cancel it on exit: either would put network cleanup on the command's path. -startCheck :: IO (Maybe T.Text) -> IO (IO ()) +-- The CLI owns the worker. Let process exit handle any pending network cleanup. +startCheck :: IO ReleaseResult -> IO (IO ()) startCheck check = do - worker <- async $ do - notice <- check - traverse evaluate notice + worker <- async (check >>= evaluate) pure $ do result <- poll worker case result of - Just (Right (Just notice)) -> T.hPutStrLn stderr notice + Just (Right (UpdateAvailable latest advice)) -> do + color <- useColor stderr + T.hPutStrLn stderr ("\n" <> renderUpdate color latest advice) _ -> pure () +renderUpdate :: Bool -> Version -> T.Text -> T.Text +renderUpdate color latest advice = + " " <> yellow color ("↑ " <> availableMessage latest) <> "\n " <> advice + +availableMessage :: Version -> T.Text +availableMessage latest = "hledger-flow " <> renderVersion latest <> " is available (installed " + <> renderVersion version <> ")." + +renderVersion :: Version -> T.Text +renderVersion = T.pack . showVersion + -- The caller has already rendered ordinary errors as diagnostics + ExitCode. -- Catch just ExitCode here so that interrupts skip the notice altogether. finishCommand :: IO () -> IO () -> IO () @@ -75,7 +90,7 @@ ignoreHttpError :: HttpException -> IO (Maybe BL.ByteString) ignoreHttpError _ = pure Nothing -checkRelease :: (String -> IO (Maybe BL.ByteString)) -> IO FilePath -> IO (Maybe T.Text) +checkRelease :: (String -> IO (Maybe BL.ByteString)) -> IO FilePath -> IO ReleaseResult checkRelease get executable = do result <- timeout 3000000 (get "https://api.github.com/repos/apauley/hledger-flow/releases/latest") case join result >>= releaseVersion of @@ -84,17 +99,16 @@ let advice = if confirmed == Just True then "Upgrade with: brew update && brew upgrade ferntrail/tap/hledger-flow" else "https://github.com/apauley/hledger-flow/releases/latest" - pure $ Just $ "hledger-flow " <> render latest <> " is available (installed " - <> render version <> ").\n" <> advice - _ -> pure Nothing + pure (UpdateAvailable latest advice) + Just _ -> pure UpToDate + Nothing -> pure CheckUnavailable where - render = T.pack . showVersion homebrewOffers latest = do path <- executable >>= canonicalizePath owned <- ownsHomebrewBinary path if owned then do formula <- get "https://raw.githubusercontent.com/FernTrail/homebrew-tap/main/Formula/hledger-flow.rb" - let tagLine = "tag = \"v" <> render latest <> "\"" + let tagLine = "tag = \"v" <> renderVersion latest <> "\"" pure $ fromMaybe False $ do body <- formula contents <- either (const Nothing) Just (T.decodeUtf8' (BL.toStrict body)) diff --git a/src/Hledger/Flow/Reports.hs b/src/Hledger/Flow/Reports.hs --- a/src/Hledger/Flow/Reports.hs +++ b/src/Hledger/Flow/Reports.hs @@ -7,7 +7,7 @@ where import Control.Concurrent.STM -import Control.Monad (unless, when) +import Control.Monad (filterM, unless, when) import Data.Char (toLower) import Data.Either import qualified Data.List as List @@ -38,7 +38,10 @@ generateReports :: RuntimeOptions -> IO () generateReports opts = withConsoleLogging $ \ch -> do - when (showOptions opts) $ channelOutLn ch (T.unlines (renderSettings id (reportSettings opts))) + homes <- homeDirs + when (showOptions opts) $ do + info <- hledgerInfo opts + channelOutLn ch (T.unlines (renderSettings id (reportSettings homes info opts))) (reports, diff) <- timeAction $ generateReports' opts ch let skipped = length (lefts reports) skippedText = if skipped == 0 then "" else " Skipped " <> plural skipped "empty report" <> "." @@ -52,10 +55,11 @@ configured <- configuredLedgerFile let hledgerJournal = maybe (toFilePath (baseDir opts [relfile|all-years.journal|])) snd configured hledgerJournalExists <- Directory.doesFileExist hledgerJournal + homes <- homeDirs unless hledgerJournalExists $ ioError $ userError $ case configured of Just (v, _) -> "LEDGER_FILE is set to " ++ v ++ ", which doesn't exist. Point it at " - ++ toFilePath (baseDir opts [relfile|all-years.journal|]) ++ ", or unset it." - Nothing -> "No all-years.journal in " ++ toFilePath (baseDir opts) ++ " yet. Run `hledger-flow import` first." + ++ tildePath homes (toFilePath (baseDir opts [relfile|all-years.journal|])) ++ ", or unset it." + Nothing -> "No all-years.journal in " ++ tildePath homes (toFilePath (baseDir opts)) ++ " yet. Run `hledger-flow import` first." let journalWithYears = baseDir opts [relfile|import/all-years.journal|] let aggregateReportDir | any ((== toFilePath [reldir|all|]) . map toLower . toFilePath) owners = baseDir opts [reldir|reports/_all_|] @@ -69,7 +73,7 @@ } let aggregateOnlyReports = reportActions opts ch [transferBalance] aggregateParams ownerParams <- ownerParameters opts ch owners - let ownerWithAggregateParams = (if length owners > 1 then [aggregateParams] else []) ++ ownerParams + let ownerWithAggregateParams = aggregateParams : ownerParams let sharedOptions = (if prettyReports opts then ["--pretty-tables"] else []) ++ ["--depth", "2"] let ownerWithAggregateReports = List.concat $ fmap (reportActions opts ch [incomeStatement sharedOptions, incomeMonthlyStatement sharedOptions, balanceSheet sharedOptions]) ownerWithAggregateParams let ownerOnlyReports = List.concat $ fmap (reportActions opts ch [accountList, unknownTransactions]) ownerParams @@ -118,11 +122,12 @@ let relativeJournals = map (relativeToBase opts) journals let relativeOutputFile = relativeToBase opts (toFilePath outputFile) let confArgs = hledgerConfArgs opts - let fileArgs = concatMap (\file -> ["--file", T.pack file]) + info <- hledgerInfo opts + let fileArgs = concatMap (\file -> ["--file", hledgerFileArgument info file]) let periodArgs = ["--period", T.pack (show year)] let reportArgs = confArgs ++ fileArgs journals ++ periodArgs ++ args let reportDisplayArgs = confArgs ++ fileArgs relativeJournals ++ periodArgs ++ args - let hledger = T.pack (toFilePath (FlowTypes.hlPath (hledgerInfo opts))) + let hledger = T.pack (toFilePath (FlowTypes.hlPath info)) let cmdLabel = "hledger " <> showCmdArgs reportDisplayArgs ((_, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr (hledger, reportArgs, Nothing) if (successCheck stdOut) @@ -138,12 +143,15 @@ ownerParameters :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [RelDir] -> IO [ReportParams] ownerParameters opts ch owners = do - let actions = map (ownerParameters' opts ch) owners - parAwareActions opts actions + indexed <- filterM (PathIO.doesFileExist . ownerIndex opts) owners + parAwareActions opts (map (ownerParameters' opts ch) indexed) +ownerIndex :: RuntimeOptions -> RelDir -> AbsFile +ownerIndex opts owner = baseDir opts [reldir|import|] owner [relfile|all-years.journal|] + ownerParameters' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> RelDir -> IO ReportParams ownerParameters' opts ch owner = do - let ownerJournal = baseDir opts [reldir|import|] owner [relfile|all-years.journal|] + let ownerJournal = ownerIndex opts owner reportsDir = baseDir opts [reldir|reports|] owner years <- includeYears ch ownerJournal let directives = directivesFile opts diff --git a/src/Hledger/Flow/RulesTemplate.hs b/src/Hledger/Flow/RulesTemplate.hs --- a/src/Hledger/Flow/RulesTemplate.hs +++ b/src/Hledger/Flow/RulesTemplate.hs @@ -14,9 +14,10 @@ import Data.Char (isAlphaNum, isDigit, toLower) import qualified Data.List as List import Data.Maybe (fromMaybe) +import qualified Data.Set as Set import qualified Data.Text as T import Hledger.Flow.BaseDir (relativeToBase') -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import Hledger.Flow.Import.Inventory (findImportFiles, stageFiles) import Hledger.Flow.Status.Gather (accountName, cachedStatement) import Hledger.Flow.Types (BaseDir) @@ -66,12 +67,14 @@ | Just i == amountIx = "amount" | isSpecialField n = "bank_" <> n | otherwise = n - dedupe = go [] + dedupe = snd . List.mapAccumL unique Set.empty where - go _ [] = [] - go seen (n : rest) = - let k = length (filter (== n) seen) - in (if k == 0 then n else n <> "_" <> T.pack (show (k + 1))) : go (n : seen) rest + unique seen name = (Set.insert chosen seen, chosen) + where + chosen = available name (2 :: Int) + available candidate suffix + | Set.notMember candidate seen = candidate + | otherwise = available (name <> "_" <> T.pack (show suffix)) (suffix + 1) -- | Names hledger gives a meaning of its own, such as balance (assertions) or status. isSpecialField :: T.Text -> Bool @@ -83,14 +86,14 @@ notCsv path = T.pack path <> " isn't a CSV file, so there's no header row to build rules from. " <> "A preprocess script can convert it to CSV first: " - <> docURL "the-preprocess-script" + <> docURL PreprocessScript -- | The starter rules file for a statement, from its contents. rulesTemplate :: T.Text -> T.Text -> FilePath -> T.Text -> Either T.Text T.Text rulesTemplate bank account path contents | map toLower (FilePath.takeExtension path) `notElem` [".csv", ".tsv", ".ssv"] = Left (notCsv path) | T.null (T.strip line) || not (looksLikeHeader names) = - Left ("The first line of " <> T.pack path <> " looks like data, not column names. Write the fields line yourself: " <> docURL "rules-files") + Left ("The first line of " <> T.pack path <> " looks like data, not column names. Write the fields line yourself: " <> docURL RulesFiles) | otherwise = Right . T.unlines $ [ "# Starter rules for " <> bank <> "/" <> account <> ", made by hledger-flow from the header row of", diff --git a/src/Hledger/Flow/RuntimeOptions.hs b/src/Hledger/Flow/RuntimeOptions.hs --- a/src/Hledger/Flow/RuntimeOptions.hs +++ b/src/Hledger/Flow/RuntimeOptions.hs @@ -1,9 +1,10 @@ module Hledger.Flow.RuntimeOptions where import qualified Data.Text as T +import Hledger.Flow.PathHelpers (AbsFile) import Hledger.Flow.Internals (SystemInfo) -import Hledger.Flow.Types -import Prelude hiding (putStrLn) +import Hledger.Flow.Types (BaseDir, HledgerConf, HledgerInfo (..), RunDir) +import qualified Hledger.Flow.Types as Types data RuntimeOptions = RuntimeOptions { baseDir :: BaseDir, @@ -11,8 +12,9 @@ importStartYear :: Maybe Integer, onlyNewFiles :: Bool, hfVersion :: T.Text, - hledgerInfo :: HledgerInfo, - hledgerConf :: Maybe FilePath, + hledgerExecutable :: AbsFile, + hledgerVersion :: IO T.Text, + hledgerConf :: Maybe HledgerConf, sysInfo :: SystemInfo, verbose :: Bool, showOptions :: Bool, @@ -20,22 +22,24 @@ batchSize :: Int, prettyReports :: Bool } - deriving (Show) -instance HasVerbosity RuntimeOptions where - verbose (RuntimeOptions _ _ _ _ _ _ _ _ v _ _ _ _) = v +hledgerInfo :: RuntimeOptions -> IO HledgerInfo +hledgerInfo opts = HledgerInfo (hledgerExecutable opts) <$> hledgerVersion opts -instance HasSequential RuntimeOptions where - sequential (RuntimeOptions _ _ _ _ _ _ _ _ _ _ sq _ _) = sq +instance Types.HasVerbosity RuntimeOptions where + verbose RuntimeOptions {verbose = value} = value -instance HasBatchSize RuntimeOptions where - batchSize (RuntimeOptions _ _ _ _ _ _ _ _ _ _ _ bs _) = bs +instance Types.HasSequential RuntimeOptions where + sequential RuntimeOptions {sequential = value} = value -instance HasBaseDir RuntimeOptions where - baseDir (RuntimeOptions bd _ _ _ _ _ _ _ _ _ _ _ _) = bd +instance Types.HasBatchSize RuntimeOptions where + batchSize RuntimeOptions {batchSize = value} = value -instance HasRunDir RuntimeOptions where - importRunDir (RuntimeOptions _ rd _ _ _ _ _ _ _ _ _ _ _) = rd +instance Types.HasBaseDir RuntimeOptions where + baseDir RuntimeOptions {baseDir = value} = value -instance HasPrettyReports RuntimeOptions where - prettyReports (RuntimeOptions _ _ _ _ _ _ _ _ _ _ _ _ pr) = pr +instance Types.HasRunDir RuntimeOptions where + importRunDir RuntimeOptions {importRunDir = value} = value + +instance Types.HasPrettyReports RuntimeOptions where + prettyReports RuntimeOptions {prettyReports = value} = value diff --git a/src/Hledger/Flow/Status.hs b/src/Hledger/Flow/Status.hs --- a/src/Hledger/Flow/Status.hs +++ b/src/Hledger/Flow/Status.hs @@ -19,11 +19,11 @@ where import Data.Char (isDigit, toLower) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T -import Hledger.Flow.Common (Shell (..), posixLiteral, powerShellLiteral, shellArgument) -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.Common (Shell (..), hledgerVersionNumber, homeShellPath, posixLiteral, powerShellLiteral, shellArgument, tildePath) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import Hledger.Flow.Import.Inventory (stageFiles) import Hledger.Flow.PathHelpers (AbsDir, AbsFile) import Hledger.Flow.Types (BaseDir, HledgerInfo) @@ -108,8 +108,9 @@ plural n noun = T.pack (show n) <> " " <> noun <> "s" -- | The single most important next step. The first matching rule wins. -nextStep :: Integer -> Shell -> AbsDir -> LedgerStatus -> NextStep -nextStep year shell cwd s +-- Paths under one of @homes@ show as @~@, and as @"$HOME/…"@ in commands. +nextStep :: Integer -> Shell -> [FilePath] -> AbsDir -> LedgerStatus -> NextStep +nextStep year shell homes cwd s | Nothing <- lsHledger s = NextStep "Install hledger, or pass its location with --hledger-path" Nothing [] (Just "https://hledger.org/install.html") | statements == 0 && null (lsMisplaced s) && lsManualJournals s == 0 && not (lsNeedsReconciliation s) = @@ -119,19 +120,19 @@ [ "For example: import/me/mybank/checking/1-in/" <> T.pack (show year) <> "/statement.csv", "Then check with: " <> command "status" ] - (Just (docURL "input-files")) + (Just (docURL InputFiles)) | not (null (lsMisplaced s)) = NextStep ("Move " <> plural (length (lsMisplaced s)) "file" <> " to where hledger-flow looks") Nothing [T.pack (mpPath m) <> " → " <> T.pack (mpSuggestion m) | m <- lsMisplaced s] - (Just (docURL "input-files")) + (Just (docURL InputFiles)) | a : _ <- filter needsRules (lsAccounts s) = NextStep - ("Create " <> T.pack (firstCandidate a) <> " (rules for " <> asAccount a <> ")") + ("Create " <> T.pack (tildePath homes (firstCandidate a)) <> " (rules for " <> asAccount a <> ")") (Just (command "status" <> " --rules-template " <> shellArgument shell (asAccount a))) ["Save its output as that file, then edit it."] - (Just (docURL "rules-files")) + (Just (docURL RulesFiles)) | toImport > 0 = NextStep ("Import " <> plural toImport "new or changed statement") (Just importCommand) [] Nothing | not (lsAllYearsExists s) = @@ -145,14 +146,15 @@ [ "LEDGER_FILE is set to " <> T.pack (lfValue lf) <> ", which doesn't exist." | Just lf <- [lsLedgerFile s] ] - (Just "https://github.com/apauley/hledger-flow/blob/master/QUICKSTART.md#import-your-first-statement") + (Just (docURL SetLedgerFile)) | otherwise = NextStep "Generate reports, or explore with hledger" (Just (command "report")) ["Or try: hledger balance"] Nothing where command subcommand = "hledger-flow " <> subcommand <> baseArgument baseArgument | cwd == lsBaseDir s = "" - | otherwise = " " <> shellArgument shell (T.pack (FilePath.dropTrailingPathSeparator (toFilePath (lsBaseDir s)))) + | otherwise = " " <> pasteable (shellArgument shell) (FilePath.dropTrailingPathSeparator (toFilePath (lsBaseDir s))) + pasteable literal path = fromMaybe (literal (T.pack path)) (homeShellPath shell homes path) importCommand = command "import" statements = sum (map asStatements (lsAccounts s)) toImport = sum [asJournalsMissing a + asJournalsOutdated a | a <- lsAccounts s] @@ -161,13 +163,7 @@ c : _ | cwd /= lsBaseDir s -> toFilePath (lsBaseDir s) FilePath. c | otherwise -> c [] -> "a rules file" - allYears = T.pack (toFilePath (lsBaseDir s [relfile|all-years.journal|])) + allYears = toFilePath (lsBaseDir s [relfile|all-years.journal|]) exportLine = case shell of - Posix -> "export LEDGER_FILE=" <> posixLiteral allYears - PowerShell -> "$env:LEDGER_FILE = " <> powerShellLiteral allYears - --- | @"hledger 1.50.2, mac-aarch64"@ → @"1.50.2"@. -hledgerVersionNumber :: T.Text -> T.Text -hledgerVersionNumber txt = case dropWhile (== "hledger") (T.words txt) of - v : _ -> T.dropWhileEnd (== ',') v - [] -> "" + Posix -> "export LEDGER_FILE=" <> pasteable posixLiteral allYears + PowerShell -> "$env:LEDGER_FILE = " <> pasteable powerShellLiteral allYears diff --git a/src/Hledger/Flow/Status/Gather.hs b/src/Hledger/Flow/Status/Gather.hs --- a/src/Hledger/Flow/Status/Gather.hs +++ b/src/Hledger/Flow/Status/Gather.hs @@ -11,15 +11,19 @@ ) where -import Control.Monad (forM) +import Control.Applicative ((<|>)) +import Control.Monad (forM, when) import qualified Data.List as List import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Clock (UTCTime) import Hledger.Flow.BaseDir (findBaseDir, relativeToBase') -import Hledger.Flow.Common (configuredLedgerFile, firstExistingFile) +import Hledger.Flow.Common (configuredLedgerFile, firstExistingFile, groupValuesBy) import Hledger.Flow.Import.ImportHelpers (defaultRulesCandidates, extractImportDirs, rulesFileCandidates) -import Hledger.Flow.Import.ImportHelpersTurtle (includesNeedUpdate) +import Hledger.Flow.Import.IncludeFiles (includesNeedUpdate) import Hledger.Flow.Import.Inventory (classifyGeneratedOutputs, findImportFiles, generatedOutput, isManualJournal, managedIncludeFiles, stageFiles) import Hledger.Flow.Import.Types (ImportDirs (..)) import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelFile) @@ -48,7 +52,7 @@ let root = base [reldir|import|] files <- findImportFiles root let statements = stageFiles root [reldir|1-in|] files - groups = Map.toAscList (Map.fromListWith (flip (++)) [(accountName root s, [s]) | s <- statements]) + groups = Map.toAscList (groupValuesBy (accountName root) statements) accounts <- forM groups (uncurry (accountStatus base)) configured <- configuredLedgerFile ledgerFile <- forM configured $ \(value, path) -> LedgerFile value <$> Directory.doesFileExist path @@ -78,7 +82,7 @@ accountStatus :: BaseDir -> T.Text -> [AbsFile] -> IO AccountStatus accountStatus base name statements = do dirs <- case statements of - s : _ -> either (ioError . userError . T.unpack) return (extractImportDirs s) + s : _ -> either (ioError . userError . T.unpack) return (extractImportDirs (base [reldir|import|]) s) [] -> ioError (userError ("No statements for " ++ T.unpack name)) let relative = relativeToBase' (toFilePath base) . toFilePath defaults <- defaultRulesCandidates dirs @@ -86,17 +90,20 @@ preprocess <- hookFile (accountDir dirs) [relfile|preprocess|] construct <- hookFile (accountDir dirs) [relfile|construct|] directives <- firstExistingFile [base [relfile|directives.journal|]] - results <- forM statements $ \s -> do + sources <- forM statements $ \s -> do cached <- cachedStatement s rules <- rulesFileCandidates (fromMaybe s cached) dirs >>= firstExistingFile - let conversionInputs = case construct of - Just script -> [Just script] - Nothing -> [rules, directives] - inputs = s : catMaybes (cached : preprocess : conversionInputs) + return (s, cached, rules) + let resolved = [rules | (_, _, rules) <- sources] + -- Statements in an account commonly share one rules file. + ruleTimes <- case construct of + Just _ -> return Map.empty + Nothing -> traverse (tryIOError . latestRuleChange) $ + Map.fromSet id (Set.fromList (catMaybes resolved)) + journals <- forM sources $ \(s, cached, rules) -> do + let inputs = s : catMaybes [cached, preprocess, construct <|> directives] journal <- generatedOutput [reldir|3-journal|] ".journal" s - state <- journalState inputs journal - return (rules, state) - let (resolved, journals) = unzip results + journalState inputs (rules >>= (`Map.lookup` ruleTimes)) journal return AccountStatus { asAccount = name, @@ -115,15 +122,31 @@ data JournalState = Current | Outdated | Missing deriving (Eq) -journalState :: [AbsFile] -> AbsFile -> IO JournalState -journalState inputs journal = do +-- hledger interprets each include path relative to the file containing it. +latestRuleChange :: AbsFile -> IO UTCTime +latestRuleChange = visit Set.empty . toFilePath + where + visit ancestors file = do + key <- Directory.canonicalizePath file + when (Set.member key ancestors) $ ioError (userError ("cyclic rules include: " ++ file)) + modified <- Directory.getModificationTime file + contents <- T.readFile file + let children = [FilePath.takeDirectory file FilePath. T.unpack (T.strip path) + | line <- T.lines (T.dropWhile (== '\xFEFF') contents) + , Just path <- [T.stripPrefix "include " line]] + times <- mapM (visit (Set.insert key ancestors)) children + return (maximum (modified : times)) + +journalState :: [AbsFile] -> Maybe (Either IOError UTCTime) -> AbsFile -> IO JournalState +journalState inputs rulesTime journal = do exists <- PathIO.doesFileExist journal if exists then do -- Keep filesystem precision so a rule edited just after import is noticed. newer <- tryIOError $ do written <- PathIO.getModificationTime journal - any (> written) <$> mapM PathIO.getModificationTime inputs + times <- mapM PathIO.getModificationTime inputs + return (any (> written) times || maybe False (either (const True) (> written)) rulesTime) return (if either (const True) id newer then Outdated else Current) else return Missing diff --git a/src/Hledger/Flow/Status/Render.hs b/src/Hledger/Flow/Status/Render.hs --- a/src/Hledger/Flow/Status/Render.hs +++ b/src/Hledger/Flow/Status/Render.hs @@ -3,34 +3,31 @@ -- | Status as text for people and JSON for scripts and agents. module Hledger.Flow.Status.Render ( useColor, + yellow, renderStatus, renderNext, renderEnvironment, statusJSON, - tildePath, nextStepHere, printStatus, printNext, ) where -import Control.Exception (IOException, catch) import Data.Aeson (Value, object, (.=)) import Data.Aeson.Text (encodeToLazyText) import qualified Data.Text.IO as T import qualified Data.Text.Lazy.IO as TL -import Hledger.Flow.Common (findHledger, nativeShell) +import Hledger.Flow.Common (findHledger, findHledgerConf, homeDirs, nativeShell, tildePath) import Hledger.Flow.DateTime (currentYear) import Hledger.Flow.Environment (coresSetting, environmentJSON, environmentSettings, renderSettings) import Hledger.Flow.Internals (SystemInfo, systemInfo) import Hledger.Flow.Status.Gather (gatherStatus) import Hledger.Flow.Types (BaseDir) -import Path.IO (getCurrentDir, getHomeDir) -import qualified Data.List as List +import Path.IO (getCurrentDir) import qualified Data.Text as T -import Hledger.Flow.PathHelpers (AbsDir) import Hledger.Flow.Status -import Hledger.Flow.Types (HledgerInfo (..)) +import Hledger.Flow.Types (HledgerConf, HledgerInfo (..)) import Path (toFilePath) import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..), SGR (..), hSupportsANSIColor, setSGRCode) import System.Environment (lookupEnv) @@ -44,12 +41,6 @@ supported <- hSupportsANSIColor h return (supported && maybe True null noColor) --- | An absolute path, with the home directory shown as @~@. -tildePath :: Maybe AbsDir -> FilePath -> FilePath -tildePath home path = case home of - Just h | Just rest <- List.stripPrefix (toFilePath h) path -> "~" FilePath. rest - _ -> path - paint :: Bool -> [SGR] -> T.Text -> T.Text paint False _ txt = txt paint True sgr txt = T.pack (setSGRCode sgr) <> txt <> T.pack (setSGRCode [Reset]) @@ -63,11 +54,11 @@ baseText :: LedgerStatus -> FilePath baseText = FilePath.dropTrailingPathSeparator . toFilePath . lsBaseDir -renderStatus :: Bool -> Maybe AbsDir -> LedgerStatus -> NextStep -> T.Text -renderStatus color home s next = +renderStatus :: Bool -> [FilePath] -> LedgerStatus -> NextStep -> T.Text +renderStatus color homes s next = T.unlines (header : accountBlock ++ misplacedBlock) <> renderNext color next where - header = bold color "Ledger: " <> T.pack (tildePath home (baseText s)) <> " (" <> hledgerText <> ")" + header = bold color "Ledger: " <> T.pack (tildePath homes (baseText s)) <> " (" <> hledgerText <> ")" hledgerText = case lsHledger s of Just hl -> "hledger " <> hledgerVersionNumber (hlVersion hl) <> " found" Nothing -> red color "hledger not found" @@ -109,7 +100,7 @@ tshow :: Show a => a -> T.Text tshow = T.pack . show -statusJSON :: SystemInfo -> Maybe FilePath -> LedgerStatus -> NextStep -> Value +statusJSON :: SystemInfo -> Maybe HledgerConf -> LedgerStatus -> NextStep -> Value statusJSON sys conf s next = object [ "schemaVersion" .= (1 :: Int), @@ -144,38 +135,43 @@ "journalsOutdated" .= asJournalsOutdated a ] -nextStepHere :: LedgerStatus -> IO NextStep -nextStepHere status = do +-- | The next step for people to read with @homes@, or for scripts with @[]@ (absolute paths). +nextStepHere :: [FilePath] -> LedgerStatus -> IO NextStep +nextStepHere homes status = do year <- currentYear cwd <- getCurrentDir - return (nextStep year nativeShell cwd status) + return (nextStep year nativeShell homes cwd status) --- | The versions and paths status ran with, with full paths for bug reports. -renderEnvironment :: Bool -> SystemInfo -> Maybe FilePath -> LedgerStatus -> T.Text -renderEnvironment color sys conf s = +-- | The versions and paths status ran with, for bug reports. Paths under the home folder show as @~@. +renderEnvironment :: Bool -> [FilePath] -> SystemInfo -> Maybe HledgerConf -> LedgerStatus -> T.Text +renderEnvironment color homes sys conf s = T.unlines ("" : bold color "Environment:" : map (" " <>) (renderSettings (red color) settings)) where - settings = environmentSettings sys (lsHledger s) conf (lsBaseDir s) ++ [coresSetting sys] + settings = environmentSettings homes sys (lsHledger s) conf ++ [coresSetting sys] -- | Print the ledger's status as text, or as JSON for scripts and agents. printStatus :: Maybe FilePath -> Maybe FilePath -> Bool -> BaseDir -> IO () -printStatus hledgerPath conf json base = do +printStatus hledgerPath confOpt json base = do hledger <- findHledger hledgerPath + conf <- findHledgerConf confOpt status <- gatherStatus hledger base - next <- nextStepHere status sys <- systemInfo if json - then TL.putStrLn (encodeToLazyText (statusJSON sys conf status next)) + then do + next <- nextStepHere [] status + TL.putStrLn (encodeToLazyText (statusJSON sys conf status next)) else do color <- useColor stdout - home <- (Just <$> getHomeDir) `catch` (\e -> const (return Nothing) (e :: IOException)) - T.putStr (renderStatus color home status next <> renderEnvironment color sys conf status) + homes <- homeDirs + next <- nextStepHere homes status + T.putStr (renderStatus color homes status next <> renderEnvironment color homes sys conf status) -- | Print only the next step for a ledger. printNext :: Maybe FilePath -> BaseDir -> IO () printNext hledgerPath base = do hledger <- findHledger hledgerPath status <- gatherStatus hledger base - next <- nextStepHere status + homes <- homeDirs + next <- nextStepHere homes status color <- useColor stdout T.putStr (renderNext color next) diff --git a/src/Hledger/Flow/Types.hs b/src/Hledger/Flow/Types.hs --- a/src/Hledger/Flow/Types.hs +++ b/src/Hledger/Flow/Types.hs @@ -20,6 +20,13 @@ type ProcInput = (T.Text, [T.Text], Maybe Handle) +-- | The hledger config file hledger runs with: given with --hledger-conf, or found by hledger's own search. +data HledgerConf = GivenConf FilePath | FoundConf FilePath deriving (Eq, Show) + +hledgerConfPath :: HledgerConf -> FilePath +hledgerConfPath (GivenConf f) = f +hledgerConfPath (FoundConf f) = f + data HledgerInfo = HledgerInfo { hlPath :: AbsFile, hlVersion :: T.Text diff --git a/test/BaseDir/Integration.hs b/test/BaseDir/Integration.hs --- a/test/BaseDir/Integration.hs +++ b/test/BaseDir/Integration.hs @@ -23,7 +23,7 @@ assertDetermineBaseDir :: AbsDir -> BaseDir -> Path.Path b Dir -> IO () assertDetermineBaseDir initialPwd expectedBaseDir subDir = do setCurrentDir initialPwd - (bd1, runDir1) <- determineBaseDir $ Just $ pathToTurtle subDir + (bd1, runDir1) <- determineBaseDir $ Just $ toFilePath subDir assertFindTestFileUsingRundir bd1 runDir1 setCurrentDir subDir @@ -57,7 +57,7 @@ (bd1, runDir1) <- determineBaseDir Nothing (bd2, runDir2) <- determineBaseDir $ Just "." (bd3, runDir3) <- determineBaseDir $ Just "./" - (bd4, runDir4) <- determineBaseDir $ Just $ pathToTurtle absBaseDir + (bd4, runDir4) <- determineBaseDir $ Just $ toFilePath absBaseDir let msg label dir = "When pwd is the base dir, determineBaseDir returns the same " ++ label ++ ", regardless of the input variation. " ++ show dir sequence_ $ map (\dir -> assertEqual (msg "baseDir" dir) absBaseDir dir) [bd1, bd2, bd3, bd4] @@ -66,12 +66,12 @@ testBaseDirWithTempDir :: AbsDir -> AbsDir -> IO () testBaseDirWithTempDir initialPwd absoluteTempDir = do error1 <- try $ determineBaseDir $ Just "/path/to/dir" - assertEqual "determineBaseDir produces an error message when given a non-existant dir" (Left $ InvalidTurtleDir "/path/to/dir") error1 + assertEqual "determineBaseDir produces an error message when given a non-existant dir" (Left $ NotADirectory "/path/to/dir") error1 let unrelatedDir = absoluteTempDir [reldir|unrelated|] createDir unrelatedDir - bdUnrelated <- try $ determineBaseDir $ Just (pathToTurtle unrelatedDir) + bdUnrelated <- try $ determineBaseDir $ Just (toFilePath unrelatedDir) assertEqual "determineBaseDir produces an error message when it cannot find a baseDir" (Left $ MissingBaseDir unrelatedDir) bdUnrelated let baseDir = [reldir|bd1|] @@ -86,8 +86,8 @@ createDirIfMissing True $ absoluteTempDir yearDir let fictionalDir = absoluteTempDir ownerDir [reldir|fictionalDir|] - errorSub <- try $ determineBaseDir $ Just $ pathToTurtle fictionalDir - assertEqual "determineBaseDir produces an error message when given a non-existant subdir of a valid basedir" (Left $ InvalidTurtleDir $ pathToTurtle fictionalDir) errorSub + errorSub <- try $ determineBaseDir $ Just $ toFilePath fictionalDir + assertEqual "determineBaseDir produces an error message when given a non-existant subdir of a valid basedir" (Left $ NotADirectory $ toFilePath fictionalDir) errorSub assertCurrentDirVariations absoluteTempDir baseDir @@ -100,7 +100,7 @@ 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 + assertEqual "An existing file cannot be used as the base directory" (Left (NotADirectory file)) fileResult assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir subDirs assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir absoluteSubDirs @@ -114,7 +114,7 @@ assertRunDir :: (RelDir -> RelDir) -> String -> RelDir -> IO () assertRunDir expectedRunDir msg subDir = do - (_, runDir) <- determineBaseDir $ Just $ pathToTurtle subDir + (_, runDir) <- determineBaseDir $ Just $ toFilePath subDir assertEqual msg (expectedRunDir subDir) runDir testRunDirsWithTempDir :: AbsDir -> IO () @@ -128,9 +128,11 @@ let inDir = accDir [reldir|1-in|] let yearDir = inDir [reldir|2019|] - createDirIfMissing True $ baseDir yearDir + let archive = yearDir [reldir|archive|] + let nested = archive [reldir|old/downloads|] + createDirIfMissing True $ baseDir nested - withCurrentDir baseDir $ assertRunDirs accDir [accDir, bankDir, ownerDir, importDir] [yearDir, inDir] + withCurrentDir baseDir $ assertRunDirs accDir [accDir, bankDir, ownerDir, importDir] [inDir, yearDir, archive, nested] testRunDirs :: Test testRunDirs = diff --git a/test/CSVImport/ImportHelperTests.hs b/test/CSVImport/ImportHelperTests.hs --- a/test/CSVImport/ImportHelperTests.hs +++ b/test/CSVImport/ImportHelperTests.hs @@ -5,7 +5,7 @@ module CSVImport.ImportHelperTests where import qualified Data.Text as T -import Hledger.Flow.DocHelpers (docURL) +import Hledger.Flow.DocHelpers (DocLink (..), docURL) import Hledger.Flow.Import.ImportHelpers (extractImportDirs, groupIncludesUpTo) import Hledger.Flow.Import.Types (ImportDirs (..), InputFileBundle) import Path @@ -28,13 +28,13 @@ 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|]) + (Right (ImportDirs root owner bank account state year)) (extractImportDirs root statement) + checkMalformed root (account [relfile|2019-01-01.csv|]) + checkMalformed root (year [relfile|extra/2019-01-01.csv|]) + checkMalformed root (base [relfile|outside/john/mybank/checking/1-in/2019/statement.csv|]) - checkMalformed file = - case extractImportDirs file of + checkMalformed root file = + case extractImportDirs root 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" @@ -42,7 +42,7 @@ <> "\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 + <> docURL InputFiles) err testGroupIncludesUpTo :: Test testGroupIncludesUpTo = TestCase $ do diff --git a/test/CSVImport/ImportHelperTurtleTests.hs b/test/CSVImport/ImportHelperTurtleTests.hs deleted file mode 100644 --- a/test/CSVImport/ImportHelperTurtleTests.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module CSVImport.ImportHelperTurtleTests where - -import Control.Concurrent.STM (newTChanIO) -import Data.Either (lefts) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Hledger.Flow.Common (includeYears') -import Hledger.Flow.Import.ImportHelpersTurtle (includePreamble, toIncludeFiles, toIncludeLine, yearsIncludeMap) -import qualified Path -import System.FilePath (()) -import Test.HUnit -import TestHelpers (defaultOpts, withTestDir) - -testIncludeYears :: Test -testIncludeYears = - TestCase - ( do - let txterr = "Some text without years" - let expectederr = ["Unable to extract years from the following text:", txterr, "Errors:"] - let actualerr = case lefts [includeYears' txterr] of - (errTxt : _) -> (init . T.lines) errTxt - [] -> [] - assertEqual "Get a list of years from an include file - error case" expectederr actualerr - - let txt1 = - "### Generated by hledger-flow - DO NOT EDIT ###\n\n" - <> "include import/2014-include.journal\n" - <> "include import/2015-include.journal\n" - <> "include import/2016-include.journal\n" - <> "include import/2017-include.journal\n" - <> "include import/2018-include.journal\n" - <> "include import/2019-include.journal" - - let expected1 = Right [2014 .. 2019] - let actual1 = includeYears' txt1 - assertEqual "Get a list of years from an include file - success case 1" expected1 actual1 - - let txt2 = "include 2019-include.journal" - - let expected2 = Right [2019] - let actual2 = includeYears' txt2 - assertEqual "Get a list of years from an include file - success case 2" expected2 actual2 - ) - -testToIncludeLine :: Test -testToIncludeLine = - TestCase - ( do - let expected = "include file1.journal" - let relativeWithTrailingSlash = toIncludeLine "./base/dir/" "./base/dir/file1.journal" - assertEqual "Include line - relative base dir with trailing slash" expected relativeWithTrailingSlash - - let relativeNoTrailingSlash = toIncludeLine "./base/dir" "./base/dir/file1.journal" - assertEqual "Include line - relative base dir without a trailing slash" expected relativeNoTrailingSlash - - let absoluteWithTrailingSlash = toIncludeLine "/base/dir/" "/base/dir/file1.journal" - assertEqual "Include line - absolute base dir with trailing slash" expected absoluteWithTrailingSlash - - let absoluteNoTrailingSlash = toIncludeLine "/base/dir" "/base/dir/file1.journal" - assertEqual "Include line - absolute base dir without a trailing slash" expected absoluteNoTrailingSlash - ) - -testIncludeRendering :: Test -testIncludeRendering = TestCase $ withTestDir $ \base -> do - let account = Path.toFilePath base "import/john/bank/checking" - year2019 = account "2019-include.journal" - year2020 = account "2020-include.journal" - first = account "3-journal/2019/first.journal" - lastJournal = account "3-journal/2019/last.journal" - assertEqual "years share their account index" - (Map.singleton (account "all-years.journal") [year2019, year2020]) - (yearsIncludeMap [year2019, year2020]) - ch <- newTChanIO - rendered <- toIncludeFiles (defaultOpts base) ch - (Map.singleton year2019 [lastJournal, first, lastJournal]) - assertEqual "sort and deduplicate relative include lines" - (Map.singleton year2019 (includePreamble <> "\ninclude 3-journal/2019/first.journal\ninclude 3-journal/2019/last.journal\n")) rendered - -tests :: Test -tests = TestList [testIncludeYears, testToIncludeLine, testIncludeRendering] diff --git a/test/CSVImport/IncludeFilesTests.hs b/test/CSVImport/IncludeFilesTests.hs new file mode 100644 --- /dev/null +++ b/test/CSVImport/IncludeFilesTests.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CSVImport.IncludeFilesTests where + +import Control.Concurrent.STM (newTChanIO) +import Data.Either (lefts) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Hledger.Flow.Common (includeYears') +import Hledger.Flow.Import.IncludeFiles (includePreamble, toIncludeFiles, toIncludeLine, yearsIncludeMap) +import qualified Path +import System.FilePath (()) +import Test.HUnit +import TestHelpers (defaultOpts, withTestDir) + +testIncludeYears :: Test +testIncludeYears = + TestCase + ( do + let txterr = "Some text without years" + let expectederr = ["Unable to extract years from the following text:", txterr, "Errors:"] + let actualerr = case lefts [includeYears' txterr] of + (errTxt : _) -> (init . T.lines) errTxt + [] -> [] + assertEqual "Get a list of years from an include file - error case" expectederr actualerr + + let txt1 = + "### Generated by hledger-flow - DO NOT EDIT ###\n\n" + <> "include import/2014-include.journal\n" + <> "include import/2015-include.journal\n" + <> "include import/2016-include.journal\n" + <> "include import/2017-include.journal\n" + <> "include import/2018-include.journal\n" + <> "include import/2019-include.journal" + + let expected1 = Right [2014 .. 2019] + let actual1 = includeYears' txt1 + assertEqual "Get a list of years from an include file - success case 1" expected1 actual1 + + let txt2 = "include 2019-include.journal" + + let expected2 = Right [2019] + let actual2 = includeYears' txt2 + assertEqual "Get a list of years from an include file - success case 2" expected2 actual2 + ) + +testToIncludeLine :: Test +testToIncludeLine = + TestCase + ( do + let expected = "include file1.journal" + let relativeWithTrailingSlash = toIncludeLine "./base/dir/" "./base/dir/file1.journal" + assertEqual "Include line - relative base dir with trailing slash" expected relativeWithTrailingSlash + + let relativeNoTrailingSlash = toIncludeLine "./base/dir" "./base/dir/file1.journal" + assertEqual "Include line - relative base dir without a trailing slash" expected relativeNoTrailingSlash + + let absoluteWithTrailingSlash = toIncludeLine "/base/dir/" "/base/dir/file1.journal" + assertEqual "Include line - absolute base dir with trailing slash" expected absoluteWithTrailingSlash + + let absoluteNoTrailingSlash = toIncludeLine "/base/dir" "/base/dir/file1.journal" + assertEqual "Include line - absolute base dir without a trailing slash" expected absoluteNoTrailingSlash + ) + +testIncludeRendering :: Test +testIncludeRendering = TestCase $ withTestDir $ \base -> do + let account = Path.toFilePath base "import/john/bank/checking" + year2019 = account "2019-include.journal" + year2020 = account "2020-include.journal" + first = account "3-journal/2019/first.journal" + lastJournal = account "3-journal/2019/last.journal" + assertEqual "years share their account index" + (Map.singleton (account "all-years.journal") [year2019, year2020]) + (yearsIncludeMap [year2019, year2020]) + ch <- newTChanIO + rendered <- toIncludeFiles (defaultOpts base) ch + (Map.singleton year2019 [lastJournal, first, lastJournal]) + assertEqual "sort and deduplicate relative include lines" + (Map.singleton year2019 (includePreamble <> "\ninclude 3-journal/2019/first.journal\ninclude 3-journal/2019/last.journal\n")) rendered + +tests :: Test +tests = TestList [testIncludeYears, testToIncludeLine, testIncludeRendering] diff --git a/test/CSVImport/Integration.hs b/test/CSVImport/Integration.hs --- a/test/CSVImport/Integration.hs +++ b/test/CSVImport/Integration.hs @@ -6,7 +6,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as Map import qualified Data.Text.IO as T -import Hledger.Flow.Import.ImportHelpersTurtle (extraIncludesForFile, includePreamble, toIncludeFiles, writeIncludesFromInventory, writeToplevelAllYearsInclude) +import Hledger.Flow.Import.IncludeFiles (extraIncludesForFile, includePreamble, toIncludeFiles, writeIncludesFromInventory, writeToplevelAllYearsInclude) import Hledger.Flow.Import.Inventory (findImportFiles) import Hledger.Flow.RuntimeOptions (RuntimeOptions) import Hledger.Flow.Types (LogMessage) diff --git a/test/CSVImport/Unit.hs b/test/CSVImport/Unit.hs --- a/test/CSVImport/Unit.hs +++ b/test/CSVImport/Unit.hs @@ -1,8 +1,8 @@ module CSVImport.Unit where import qualified CSVImport.ImportHelperTests -import qualified CSVImport.ImportHelperTurtleTests +import qualified CSVImport.IncludeFilesTests import Test.HUnit tests :: Test -tests = TestList [CSVImport.ImportHelperTests.tests, CSVImport.ImportHelperTurtleTests.tests] +tests = TestList [CSVImport.ImportHelperTests.tests, CSVImport.IncludeFilesTests.tests] diff --git a/test/Common/Integration.hs b/test/Common/Integration.hs --- a/test/Common/Integration.hs +++ b/test/Common/Integration.hs @@ -5,17 +5,17 @@ module Common.Integration (tests) where import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryTakeMVar) -import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan) -import Control.Exception (bracket, finally) +import Control.Concurrent.STM (atomically, modifyTVar', newTChanIO, newTVarIO, readTVarIO, tryReadTChan) +import Control.Exception (bracket, bracket_, finally) import Control.Monad (forM_, unless) -import qualified Data.List as List (intercalate, isInfixOf) +import qualified Data.List as List (intercalate, isInfixOf, isPrefixOf) 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 qualified Hledger.Flow.RuntimeOptions as RT -import Hledger.Flow.Types (LogMessage (StdErr)) +import Hledger.Flow.Types (HledgerConf (..), LogMessage (StdErr)) import qualified Path import qualified Path.IO as PathIO import System.Directory (doesFileExist) @@ -143,23 +143,25 @@ PathIO.setModificationTime target older check "equal timestamps" False PathIO.setModificationTime source (addUTCTime 0.75 older) - check "subsecond differences alone do not trigger regeneration" False + check "source newer within the same second" True PathIO.removeFile source check "source timestamp no longer available" True 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 + firstStarted <- newEmptyMVar + thirdStarted <- newEmptyMVar + concurrency <- newTVarIO (0, 0 :: Int) + let track = bracket_ + (atomically $ modifyTVar' concurrency $ \(active, peak) -> (active + 1, max peak (active + 1))) + (atomically $ modifyTVar' concurrency $ \(active, peak) -> (active - 1, peak)) + first = putMVar firstStarted () >> takeMVar thirdStarted >> return (1 :: Int) + second = takeMVar firstStarted >> return 2 + third = putMVar thirdStarted () >> return 3 + result <- timeout 10000000 (parBatchedActions 2 [0] (map track [first, second, third])) + readTVarIO concurrency >>= assertEqual "two simultaneous workers, both joined" (0, 2) + assertEqual "refill a free worker while preserving input order" (Just [0, 1, 2, 3]) result testBatchFailure :: Test testBatchFailure = TestLabel "batch failure cancels siblings and stops later batches" $ @@ -181,5 +183,70 @@ tryTakeMVar stopped >>= assertEqual "cancel and join the running sibling" (Just ()) tryTakeMVar later >>= assertEqual "never start the next batch" Nothing +-- Status must name the config file hledger loads by itself, in hledger's search order. +testFindHledgerConf :: Test +testFindHledgerConf = TestLabel "hledger config lookup" $ TestCase $ withTestDir $ \base -> do + let root = Path.toFilePath base + found expected = do + actual <- findHledgerConf Nothing + expectedPath <- Directory.canonicalizePath expected + assertEqual ("found " ++ expected) (Just (FoundConf expectedPath)) actual + forM_ (["near/work", "home/work", "xdg/hledger"] :: [FilePath]) $ \dir -> + Directory.createDirectoryIfMissing True (root dir) + withEnv "HOME" (root "home") $ withEnv "XDG_CONFIG_HOME" (root "xdg") $ do + writeFile (root "near" "hledger.conf") "" + writeFile (root "home" "hledger.conf") "" + writeFile (root "home" ".hledger.conf") "" + writeFile (root "xdg" "hledger" "hledger.conf") "" + Directory.withCurrentDirectory (root "near" "work") $ do + found (root "near" "hledger.conf") + given <- findHledgerConf (Just "other.conf") + assertEqual "--hledger-conf wins" (Just (GivenConf "other.conf")) given + unless (Sys.os == "mingw32") $ do + Directory.withCurrentDirectory (root "home" "work") $ do + found (root "home" ".hledger.conf") + Directory.removeFile (root "home" ".hledger.conf") + found (root "xdg" "hledger" "hledger.conf") + +-- HUnit runs these cases sequentially; restore the variable even on failure. +withEnv :: String -> String -> IO a -> IO a +withEnv name value action = bracket (lookupEnv name) (maybe (unsetEnv name) (setEnv name)) $ \_ -> + setEnv name value >> action + +-- Paths come out resolved (macOS /private/var, symlinked homes), so match both spellings of HOME. +testHomeDirs :: Test +testHomeDirs = TestLabel "home folder spellings" $ TestCase $ unless (Sys.os == "mingw32") $ withTestDir $ \base -> do + let root = Path.toFilePath base + Directory.createDirectory (root "real") + Directory.createDirectoryLink (root "real") (root "link") + real <- Directory.canonicalizePath (root "real") + forM_ ([root "link", root "link/", real ++ "/"] :: [FilePath]) $ \home -> withEnv "HOME" home $ do + homes <- homeDirs + assertEqual ("resolved path with HOME=" ++ home) ("~" "fin") (tildePath homes (real "fin")) + assertEqual ("HOME's spelling with HOME=" ++ home) ("~" "fin") (tildePath homes (home "fin")) + +testWriteGeneratedText :: Test +testWriteGeneratedText = TestLabel "write generated text" $ TestCase $ withTestDir $ \base -> do + let dir = Path.toFilePath base "out" + journal = dir "2024-include.journal" + writeGeneratedText journal "first\n" + T.readFile journal >>= assertEqual "create missing directory and file" "first\n" + unless (Sys.os == "mingw32") $ do + perms <- Directory.getPermissions journal + Directory.setPermissions journal (Directory.setOwnerExecutable True perms) + let real = dir "real.journal" + link = dir "link.journal" + T.writeFile real "old\n" + Directory.createFileLink "real.journal" link + writeGeneratedText link "through link\n" + T.readFile real >>= assertEqual "replace the file behind a symlink" "through link\n" + Directory.pathIsSymbolicLink link >>= assertBool "keep the symlink" + writeGeneratedText journal "second\n" + T.readFile journal >>= assertEqual "replace existing contents" "second\n" + unless (Sys.os == "mingw32") $ + Directory.getPermissions journal >>= assertBool "keep existing permissions" . Directory.executable + entries <- Directory.listDirectory dir + assertBool ("no staged files left: " ++ show entries) (not (any (List.isPrefixOf ".") entries)) + tests :: Test -tests = TestList [testHledgerLookup, testFilterPaths, testFirstExistingFile, testVerboseTestFile, testNeedsRegeneration, testBatchOrder, testBatchFailure] +tests = TestList [testWriteGeneratedText, testHledgerLookup, testFindHledgerConf, testHomeDirs, testFilterPaths, testFirstExistingFile, testVerboseTestFile, testNeedsRegeneration, testBatchOrder, testBatchFailure] diff --git a/test/Common/Unit.hs b/test/Common/Unit.hs --- a/test/Common/Unit.hs +++ b/test/Common/Unit.hs @@ -6,22 +6,29 @@ import Hledger.Flow.BaseDir (relativeToBase') import Hledger.Flow.Common -import Hledger.Flow.DocHelpers (docURL) +import Data.Aeson (eitherDecodeFileStrict) +import Hledger.Flow.DocHelpers (DocLink (..), docSlug, docURL) import Hledger.Flow.RuntimeOptions (RuntimeOptions (hledgerConf)) -import qualified Data.List as List +import Hledger.Flow.Types (HledgerConf (..), HledgerInfo (hlVersion)) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Path ((), reldir) import Test.HUnit -import TestHelpers (defaultOpts, testRoot) +import TestHelpers (defaultHlInfo, 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") + "https://hledger-flow.github.io/go/input-files/" + (docURL InputFiles) +testDocLinksHaveRedirects :: Test +testDocLinksHaveRedirects = TestCase $ do + redirects <- either fail pure =<< eitherDecodeFileStrict "site/go-links.json" :: IO (Map.Map T.Text T.Text) + let missing = [docSlug l | l <- [minBound .. maxBound], docSlug l `Map.notMember` redirects] + assertEqual "Every DocLink needs a redirect in site/go-links.json" [] missing + testShowCmdArgs :: Test testShowCmdArgs = TestCase @@ -49,10 +56,47 @@ 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"} + let optsWithConf = optsWithoutConf {hledgerConf = Just (GivenConf "/tmp/hledger.conf")} assertEqual "Configured hledger config should produce --conf args" ["--conf", "/tmp/hledger.conf"] (hledgerConfArgs optsWithConf) + + let optsWithFoundConf = optsWithoutConf {hledgerConf = Just (FoundConf "/home/me/.hledger.conf")} + assertEqual "hledger finds its default config itself" [] (hledgerConfArgs optsWithFoundConf) ) +testHledgerFileArgument :: Test +testHledgerFileArgument = TestList + [ "1.51 reads a literal filename" ~: argument "hledger 1.51.2, mac-aarch64" ~?= "April [1].csv", + "1.52 expands file globs" ~: argument "hledger 1.52, mac-aarch64" ~?= "April [[-[]1].csv", + "development versions expand file globs" ~: argument "hledger 1.99-g123abc" ~?= "April [[-[]1].csv" + ] + where + argument version = hledgerFileArgument (defaultHlInfo {hlVersion = version}) "April [1].csv" + +testHomePaths :: Test +testHomePaths = + let homes = ["/home/me/", "/real/me"] + native = T.pack . FilePath.joinPath + quoted parts = "\"" <> native ("$HOME" : parts) <> "\"" + displayedProgram = if FilePath.isPathSeparator '\\' then "~\\'bin\\hledger'" else "~/bin/hledger" + in TestList + [ "home itself" ~: tildePath homes "/home/me" ~?= "~", + "below home, trailing slash on HOME" ~: tildePath homes "/home/me/fin" ~?= FilePath.joinPath ["~", "fin"], + "resolved spelling" ~: tildePath homes "/real/me/fin" ~?= FilePath.joinPath ["~", "fin"], + "a sibling with the same prefix" ~: tildePath homes "/home/meg/fin" ~?= "/home/meg/fin", + "outside home" ~: tildePath homes "/srv/fin" ~?= "/srv/fin", + "command line" ~: showCmdArgsAt homes ["/home/me/bin/hledger", "--file", "/home/me/my fin/a.csv", "/srv/b"] + ~?= displayedProgram <> " --file ~" <> T.singleton FilePath.pathSeparator <> "'" <> native ["my fin", "a.csv"] <> "' /srv/b", + "posix command path" ~: homeShellPath Posix homes "/home/me/my fin" ~?= Just (quoted ["my fin"]), + "home itself in a command" ~: homeShellPath Posix homes "/real/me" ~?= Just "\"$HOME\"", + "powershell command path" ~: homeShellPath PowerShell homes "/home/me/Lee's fin" ~?= Just (quoted ["Lee's fin"]), + "outside home in a command" ~: homeShellPath Posix homes "/srv/fin" ~?= Nothing, + "posix specials fall back" ~: map (\c -> homeShellPath Posix homes ("/home/me/a" ++ [c])) "$`\"!" ~?= replicate 4 Nothing, + "trailing backslash is special unless it separates paths" ~: homeShellPath Posix homes "/home/me/a\\" + ~?= if FilePath.isPathSeparator '\\' then Just (quoted ["a"]) else Nothing, + "powershell specials fall back" ~: map (\c -> homeShellPath PowerShell homes ("/home/me/a" ++ [c])) "$`\"\x201c\x201d\x201e" ~?= replicate 6 Nothing, + "posix-only specials are fine in powershell" ~: homeShellPath PowerShell homes "/home/me/a!" ~?= Just (quoted ["a!"]) + ] + testRelativeToBase :: Test testRelativeToBase = TestCase @@ -109,19 +153,22 @@ assertEqual "Extract digits from text 2" expected2 actual2 ) +-- Grouping requires an ordering on the key alone. +data Entry = Entry Char Int deriving (Eq, Show) + testGroupValuesBy :: Test -testGroupValuesBy = - TestCase - ( do - let values = ["b2", "a1", "b1", "a2"] - let grouped = groupValuesBy (take 1) values - let normalize = Map.map List.sort - let expected = Map.fromList [("a", ["a1", "a2"]), ("b", ["b1", "b2"])] - assertEqual "Group values by key" (normalize expected) (normalize grouped) - ) +testGroupValuesBy = TestCase $ do + let key (Entry k _) = k + a1 = Entry 'a' 1 + a2 = Entry 'a' 2 + b1 = Entry 'b' 1 + b2 = Entry 'b' 2 + assertEqual "interleaved keys retain input order and duplicates" + (Map.fromList [('a', [a1, a2]), ('b', [b2, b1, b2])]) + (groupValuesBy key [b2, a1, b1, a2, b2]) tests :: Test -tests = TestList [testDocURL, testShowCmdArgs, testHledgerConfArgs, testRelativeToBase, testExtractDigits, testGroupValuesBy, testTrimToolOutput] +tests = TestList [testDocURL, testDocLinksHaveRedirects, testShowCmdArgs, testHledgerConfArgs, testHledgerFileArgument, testHomePaths, testRelativeToBase, testExtractDigits, testGroupValuesBy, testTrimToolOutput] testTrimToolOutput :: Test testTrimToolOutput = diff --git a/test/Environment/Unit.hs b/test/Environment/Unit.hs --- a/test/Environment/Unit.hs +++ b/test/Environment/Unit.hs @@ -6,16 +6,18 @@ import qualified Data.Text as T import Hledger.Flow.Environment import Hledger.Flow.RuntimeOptions +import Hledger.Flow.Types (HledgerConf (..)) import Path import Test.HUnit -import TestHelpers (defaultOpts, testRoot) +import qualified System.FilePath as FilePath +import TestHelpers (defaultHlInfo, defaultOpts, testRoot) opts :: RuntimeOptions opts = defaultOpts (testRoot [reldir|fin|]) testImportLines :: Test testImportLines = TestCase $ do - let out = renderSettings id (importSettings opts {importStartYear = Just 2024, batchSize = 20}) + let out = renderSettings id (importSettings [] defaultHlInfo opts {importStartYear = Just 2024, batchSize = 20}) line l = filter ((l <> " ") `T.isPrefixOf`) out assertEqual "one line per setting" 8 (length out) assertBool "full hledger path and version" (any ((T.pack (toFilePath [relfile|path/to/hledger|]) <> " (1.2.3)") `T.isInfixOf`) (line "hledger")) @@ -26,16 +28,30 @@ testMissingHledger :: Test testMissingHledger = TestCase $ do - let out = renderSettings (\v -> "<" <> v <> ">") (environmentSettings (sysInfo opts) Nothing Nothing (baseDir opts)) + let out = renderSettings (\v -> "<" <> v <> ">") (environmentSettings [] (sysInfo opts) Nothing Nothing) assertBool "missing hledger styled as a problem" (any (" " ") `T.isPrefixOf`) out + assertBool "hledger under home" (any ((T.pack (FilePath.joinPath ["~", "path", "to", "hledger"]) <> " (1.2.3)") `T.isInfixOf`) (line "hledger")) + assertBool "ledger under home" (any ((T.pack (FilePath.joinPath ["~", "fin"])) `T.isSuffixOf`) (line "Ledger")) + testReportTables :: Test testReportTables = TestCase $ do - let out = renderSettings id (reportSettings opts {prettyReports = False, sequential = True}) + let out = renderSettings id (reportSettings [] defaultHlInfo opts {prettyReports = False, sequential = True}) assertBool "ascii tables" (any ("ASCII" `T.isInfixOf`) out) assertBool "sequential" (any ("one file at a time" `T.isInfixOf`) out) assertBool "no import settings" (not (any ("Start year" `T.isPrefixOf`) out)) tests :: Test -tests = TestList [testImportLines, testMissingHledger, testReportTables] +tests = TestList [testImportLines, testMissingHledger, testHledgerConf, testHomePaths, testReportTables] diff --git a/test/ImportHelpers/Integration.hs b/test/ImportHelpers/Integration.hs --- a/test/ImportHelpers/Integration.hs +++ b/test/ImportHelpers/Integration.hs @@ -59,6 +59,20 @@ [account [relfile|3-journal/2019/march.bank.journal|]] (stageFiles root [reldir|3-journal|] inventory) +testRestoredSource :: Test +testRestoredSource = TestLabel "restore a source after discovery" $ TestCase $ withTestDir $ \root -> do + let account = root [reldir|owner/bank/checking|] + source = account [relfile|1-in/2026/march.txt|] + csv = account [relfile|2-preprocessed/2026/march.csv|] + journal = account [relfile|3-journal/2026/march.journal|] + mapM_ touchFile [csv, journal] + cached <- findImportFiles root + touchFile source + (files, orphans, journals) <- reconciliationInventory root (Just cached) + assertEqual "keep both restored outputs" [] orphans + assertEqual "include the restored journal" [journal] journals + assertBool "use refreshed inventory for includes" (source `elem` files) + testStagedOutput :: Test testStagedOutput = TestCase $ withSystemTempDir "hlflow-output" $ \dir -> do let target = dir [relfile|march.bank.csv|] @@ -80,8 +94,18 @@ withStagedOutput target $ \staged -> T.writeFile (toFilePath staged) "complete" T.readFile (toFilePath target) >>= assertEqual "publish successful retry" "complete" +testCannotAlias :: Test +testCannotAlias = TestCase $ do + assertBool "distinct plain names" (cannotAlias ["2024-01.journal", "2024-02.journal", "April [1].journal"]) + mapM_ (\names -> assertBool ("may alias: " ++ show names) (not (cannotAlias names))) + [ ["march.journal", "march.journal"], + ["march.journal", "March.journal"], + ["caf\233.journal", "other.journal"], + ["PROGRA~1.journal", "other.journal"] + ] + tests :: Test -tests = TestList [testInventory, testStagedOutput, testTrashLock] +tests = TestList [testInventory, testRestoredSource, testStagedOutput, testTrashLock, testCannotAlias] testTrashLock :: Test testTrashLock = TestCase $ withSystemTempDir "hlflow-trash" $ \root -> do diff --git a/test/ReleaseNotice/Unit.hs b/test/ReleaseNotice/Unit.hs --- a/test/ReleaseNotice/Unit.hs +++ b/test/ReleaseNotice/Unit.hs @@ -8,9 +8,9 @@ import Data.Aeson (encode, object, (.=)) import Data.IORef import qualified Data.Text as T -import Data.Version (showVersion) +import Data.Version (makeVersion, showVersion) import Paths_hledger_flow (version) -import Hledger.Flow.ReleaseNotice (checkRelease, finishCommand, startCheck) +import Hledger.Flow.ReleaseNotice (ReleaseResult (..), checkRelease, finishCommand, renderUpdate, startCheck) import Path (toFilePath) import System.Directory (createDirectoryIfMissing) import System.Exit (ExitCode (ExitFailure)) @@ -21,14 +21,22 @@ tests :: Test tests = TestLabel "release notice" $ TestList - [ "ignore malformed, nonstable and non-newer releases" ~: TestCase $ - forM_ [Nothing, Just "invalid", Just "{\"tag_name\":\"v0\"}", - Just (encode (object ["tag_name" .= ("v" ++ showVersion version)])), + [ "invalid or missing responses cannot confirm release status" ~: TestCase $ + forM_ [Nothing, Just "invalid", Just "{\"tag_name\":\"v999-rc1\"}", Just "{\"tag_name\":\"v999x\"}", Just "{\"tag_name\":\"v999\",\"prerelease\":true}", Just "{\"tag_name\":\"v999\",\"draft\":true}"] $ \body -> do notice <- checkRelease (const $ pure body) (fail "unexpected ownership check") - Nothing @=? notice + CheckUnavailable @=? notice + , "installed version matches or exceeds the latest stable release" ~: TestCase $ + forM_ ["v0", "v" ++ showVersion version] $ \tag -> do + let response = Just (encode (object ["tag_name" .= tag])) + notice <- checkRelease (const $ pure response) (fail "unexpected ownership check") + UpToDate @=? notice + , "upgrade notice keeps its meaning with colour disabled" ~: TestCase $ do + let installed = T.pack (showVersion version) + (" ↑ hledger-flow 999 is available (installed " <> installed <> ").\n upgrade advice") + @=? renderUpdate False (makeVersion [999]) "upgrade advice" , "verified Homebrew ownership and published formula" ~: TestCase $ withTestDir $ \dir -> do let keg = toFilePath dir "Cellar" "hledger-flow" "1.2.3" @@ -42,7 +50,7 @@ | otherwise = assertFailure ("unexpected URL " ++ url) >> pure Nothing check advice formula = do notice <- checkRelease (fetch formula) (pure exe) - assertBool ("expected " ++ T.unpack advice) (maybe False (T.isInfixOf advice) notice) + UpdateAvailable (makeVersion [999, 10, 0]) advice @=? notice published = Just " tag = \"v999.10.0\"\n" releases = "https://github.com/apauley/hledger-flow/releases/latest" createDirectoryIfMissing True (keg "bin") @@ -53,7 +61,7 @@ writeFile receipt "{\"source\":{\"tap\":\"ferntrail/tap\"}}" check releases Nothing check releases (Just " tag = \"v999.9.0\"\n") - check "brew update && brew upgrade ferntrail/tap/hledger-flow" published + check "Upgrade with: brew update && brew upgrade ferntrail/tap/hledger-flow" published , "command finishes with worker still pending" ~: TestCase $ do started <- newEmptyMVar release <- newEmptyMVar @@ -63,7 +71,7 @@ failure <- timeout 1000000 $ try (finishCommand finish (throwIO (ExitFailure 37))) Just () @=? success Just (Left (ExitFailure 37)) @=? failure - putMVar release Nothing + putMVar release UpToDate , "ready notice follows diagnostics and preserves the exit code" ~: TestCase $ do events <- newIORef ([] :: [String]) let record msg = modifyIORef' events (++ [msg]) diff --git a/test/RulesTemplate/Unit.hs b/test/RulesTemplate/Unit.hs --- a/test/RulesTemplate/Unit.hs +++ b/test/RulesTemplate/Unit.hs @@ -17,6 +17,11 @@ "hledger's special names renamed" ~: templateFields ["Date", "Description", "Amount", "Balance", "Status", "Code"] ~?= ["date", "description", "amount", "bank_balance", "bank_status", "bank_code"], "single amount column mapped" ~: templateFields ["Date", "Desc", "Transaction Amount"] ~?= ["date", "description", "amount"], + "suffixes are unique even when present in the header" ~: + templateFields ["Reference", "Reference", "Reference_2", "Reference"] + ~?= ["reference", "reference_2", "reference_2_2", "reference_3"], + "skip a suffix already used by an earlier column" ~: + templateFields ["Reference_2", "Reference", "Reference"] ~?= ["reference_2", "reference", "reference_3"], "debit and credit amounts left alone" ~: templateFields ["Date", "Desc", "Debit Amount", "Credit Amount"] ~?= ["date", "description", "debit_amount", "credit_amount"], "renamed columns explained" ~: fmap (T.isInfixOf "bank_balance") diff --git a/test/RuntimeOptions/Unit.hs b/test/RuntimeOptions/Unit.hs new file mode 100644 --- /dev/null +++ b/test/RuntimeOptions/Unit.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE QuasiQuotes #-} + +module RuntimeOptions.Unit (tests) where + +import Hledger.Flow.RuntimeOptions +import qualified Hledger.Flow.Types as Types +import Path +import Test.HUnit +import TestHelpers (defaultOpts, testRoot) + +tests :: Test +tests = TestCase $ do + let base = testRoot [reldir|ledger|] + run = [reldir|import/owner|] + opts = (defaultOpts base) {importRunDir = run, batchSize = 19, prettyReports = False} + flags o = (Types.verbose o, Types.sequential o, Types.prettyReports o) + assertEqual "base directory" base (Types.baseDir opts) + assertEqual "import directory" run (Types.importRunDir opts) + assertEqual "batch size" 19 (Types.batchSize opts) + assertEqual "verbose alone" (True, False, False) (flags opts {verbose = True}) + assertEqual "sequential alone" (False, True, False) (flags opts {sequential = True}) + assertEqual "pretty reports alone" (False, False, True) (flags opts {prettyReports = True}) + assertEqual "unrelated flags" (False, False, False) (flags opts {onlyNewFiles = True, showOptions = True}) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,6 +14,7 @@ import qualified PathHelpers.Unit import qualified ReleaseNotice.Unit import qualified RulesTemplate.Unit +import qualified RuntimeOptions.Unit import qualified Status.Integration import qualified Status.Unit import Test.HUnit @@ -34,6 +35,7 @@ Init.Integration.tests, ReleaseNotice.Unit.tests, RulesTemplate.Unit.tests, + RuntimeOptions.Unit.tests, Environment.Unit.tests ] diff --git a/test/Status/Unit.hs b/test/Status/Unit.hs --- a/test/Status/Unit.hs +++ b/test/Status/Unit.hs @@ -71,7 +71,7 @@ map native ["import/me/mybank/JAN.CSV", "import/me/mybank/checking/3-journal/2026/mar.csv"] atRoot :: LedgerStatus -> NextStep -atRoot = nextStep 2026 Posix (lsBaseDir blank) +atRoot = nextStep 2026 Posix [] (lsBaseDir blank) summaryOf :: LedgerStatus -> T.Text summaryOf = nsSummary . atRoot @@ -96,17 +96,36 @@ "4 rules" ~: commandOf blank {lsAccounts = [acct {asWithoutRules = 1, asRulesFile = Nothing}]} ~?= Just "hledger-flow status --rules-template me/mybank/checking", "4 summary" ~: summaryOf blank {lsAccounts = [acct {asWithoutRules = 1, asRulesFile = Nothing}]} ~?= "Create import/me/mybank/checking/mybank-checking.rules (rules for me/mybank/checking)", "4 powershell literal account" ~: - nsCommand (nextStep 2026 PowerShell (lsBaseDir blank) blank {lsAccounts = [acct {asWithoutRules = 1, asAccount = "me/Bob's Bank/Lee’s $(example)"}]}) + nsCommand (nextStep 2026 PowerShell [] (lsBaseDir blank) blank {lsAccounts = [acct {asWithoutRules = 1, asAccount = "me/Bob's Bank/Lee’s $(example)"}]}) ~?= Just "hledger-flow status --rules-template 'me/Bob''s Bank/Lee’’s $(example)'", "4 skipped with construct" ~: commandOf blank {lsAccounts = [acct {asWithoutRules = 1, asConstruct = True}]} ~?= Just "hledger-flow report", "5 import" ~: summaryOf blank {lsAccounts = [acct {asJournalsMissing = 1, asJournalsOutdated = 1}]} ~?= "Import 2 new or changed statements", "5 import singular" ~: summaryOf blank {lsAccounts = [acct {asJournalsMissing = 1}]} ~?= "Import 1 new or changed statement", "6 posix" ~: commandOf blank {lsAccounts = [acct], lsLedgerFile = Nothing} ~?= Just ("export LEDGER_FILE='" <> allYears <> "'"), - "6 windows" ~: nsCommand (nextStep 2026 PowerShell (lsBaseDir blank) blank {lsAccounts = [acct], lsLedgerFile = Nothing}) ~?= Just ("$env:LEDGER_FILE = '" <> allYears <> "'"), + "6 windows" ~: nsCommand (nextStep 2026 PowerShell [] (lsBaseDir blank) blank {lsAccounts = [acct], lsLedgerFile = Nothing}) ~?= Just ("$env:LEDGER_FILE = '" <> allYears <> "'"), "6 set but missing" ~: nsDetail (atRoot blank {lsAccounts = [acct], lsLedgerFile = Just (LedgerFile "/nope.journal" False)}) ~?= ["LEDGER_FILE is set to /nope.journal, which doesn't exist."], "7 done" ~: commandOf blank {lsAccounts = [acct]} ~?= Just "hledger-flow report" ] +-- Readable text shows the home folder as ~; pasteable commands use "$HOME", which shells expand. +testHome :: Test +testHome = + let homes = [toFilePath testRoot] + elsewhere = testRoot [reldir|elsewhere|] + next shell cwd s = nextStep 2026 shell homes cwd s + unset = blank {lsAccounts = [acct], lsLedgerFile = Nothing} + quoted parts = "\"" <> T.pack (FilePath.joinPath ("$HOME" : parts)) <> "\"" + dollarInPath = unset {lsBaseDir = testRoot [reldir|fin$|]} + in TestList + [ "posix export" ~: nsCommand (next Posix (lsBaseDir blank) unset) ~?= Just ("export LEDGER_FILE=" <> quoted ["fin", "all-years.journal"]), + "powershell export" ~: nsCommand (next PowerShell (lsBaseDir blank) unset) ~?= Just ("$env:LEDGER_FILE = " <> quoted ["fin", "all-years.journal"]), + "ledger argument" ~: nsCommand (next Posix elsewhere blank {lsAccounts = [acct]}) ~?= Just ("hledger-flow report " <> quoted ["fin"]), + "summary" ~: nsSummary (next Posix elsewhere blank {lsAccounts = [acct {asWithoutRules = 1, asRulesFile = Nothing}]}) + ~?= T.pack ("Create " <> FilePath.joinPath ["~", "fin", "import", "me", "mybank", "checking", "mybank-checking.rules"]) <> " (rules for me/mybank/checking)", + "special character falls back to the absolute path" ~: nsCommand (next Posix (lsBaseDir dollarInPath) dollarInPath) + ~?= Just ("export LEDGER_FILE='" <> T.pack (toFilePath (lsBaseDir dollarInPath [relfile|all-years.journal|])) <> "'") + ] + testVersion :: Test testVersion = TestList @@ -118,14 +137,14 @@ testRenderNoColour :: Test testRenderNoColour = TestCase $ do let s = blank {lsAccounts = [acct {asWithoutRules = 1, asRulesFile = Nothing}]} - out = renderStatus False Nothing s (atRoot s) + out = renderStatus False [] s (atRoot s) assertBool "account line" ("me/mybank/checking" `T.isInfixOf` out && "✗ no rules file" `T.isInfixOf` out) assertBool "next step" ("Next: Create import/me/mybank/checking/mybank-checking.rules" `T.isInfixOf` out) assertBool "no escapes" (not ("\ESC" `T.isInfixOf` out)) testRenderPending :: Test testRenderPending = TestCase $ do - let render a = renderStatus False Nothing blank {lsAccounts = [a]} (atRoot blank) + let render a = renderStatus False [] blank {lsAccounts = [a]} (atRoot blank) assertBool "nothing imported yet" ("• 1 not imported" `T.isInfixOf` render acct {asJournalsMissing = 1}) assertBool "mixed" ("• 11 journals, 1 not imported, 2 outdated" `T.isInfixOf` render acct {asStatements = 12, asJournalsMissing = 1, asJournalsOutdated = 2}) assertBool "clean" ("✓ 1 journal" `T.isInfixOf` render acct) @@ -137,4 +156,4 @@ @?= ["accounts", "allYearsJournalExists", "baseDir", "environment", "hledger", "ledgerFile", "manualJournals", "misplaced", "next", "schemaVersion"] _ -> assertFailure "status JSON is an object" -tests = TestList [testSuggest, testMisplacedUpperCase, testRules, testVersion, testRenderNoColour, testRenderPending, testJSONShape] +tests = TestList [testSuggest, testMisplacedUpperCase, testRules, testHome, testVersion, testRenderNoColour, testRenderPending, testJSONShape] diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs --- a/test/TestHelpers.hs +++ b/test/TestHelpers.hs @@ -51,7 +51,8 @@ importStartYear = Nothing, onlyNewFiles = False, hfVersion = versionInfo testSystemInfo, - hledgerInfo = defaultHlInfo, + hledgerExecutable = FlowTypes.hlPath defaultHlInfo, + hledgerVersion = return (FlowTypes.hlVersion defaultHlInfo), hledgerConf = Nothing, sysInfo = testSystemInfo, verbose = False,