diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow) +## 0.13.2 + +Improve support for importing a subset of journals: start importing only from the directory given as argument, +or the current directory, and generate only the relevant include files. + +This is a behavioural change and (for now) it needs to be enabled with the --enable-future-rundir switch. +This will become the default behaviour in 0.14.x, at which time the switch will be removed. + +Reports: +Use the LEDGER_FILE env var (if set) when generating reports. +Default to the top-level all-years.journal if not set. + +Build with Stackage Nightly 2020-03-10 (ghc-8.8.3) + ## 0.13.1 - Automatically add [include lines for yearly price files](https://github.com/apauley/hledger-flow/#price-files) if they are present on disk. diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -18,7 +18,7 @@ workflow. It is important to note that most of the heavy lifting is done by the upstream =hledger= project. For example, =hledger-flow= cares about where you put your files for long-term maintainability, but the actual conversion to -classified accounting journals are done by =hledger=. +classified accounting journals is done by =hledger=. =hledger-flow= focuses on automated processing of electronic statements as much as possible, as opposed to manually adding your own hledger journal entries. Manual entries diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -12,10 +12,13 @@ import Hledger.Flow.Reports import Hledger.Flow.CSVImport -data SubcommandParams = SubcommandParams { maybeBaseDir :: Maybe FilePath - , maybeRunDir :: Maybe FilePath } deriving (Show) -data Command = Import SubcommandParams | Report SubcommandParams deriving (Show) +data ImportParams = ImportParams { maybeImportBaseDir :: Maybe FilePath + , importUseRunDir :: Bool } deriving (Show) +data ReportParams = ReportParams { maybeReportBaseDir :: Maybe FilePath } deriving (Show) + +data Command = Import ImportParams | Report ReportParams deriving (Show) + data MainParams = MainParams { verbosity :: Int , hledgerPathOpt :: Maybe FilePath , showOpts :: Bool @@ -28,15 +31,16 @@ cmd <- options "An hledger workflow focusing on automated statement import and classification:\nhttps://github.com/apauley/hledger-flow#readme" baseCommandParser case cmd of Version -> stdout $ select versionInfo - Command mainParams' (Import subParams) -> toRuntimeOptions mainParams' subParams >>= importCSVs - Command mainParams' (Report subParams) -> toRuntimeOptions mainParams' subParams >>= generateReports + Command mainParams' (Import subParams) -> toRuntimeOptionsImport mainParams' subParams >>= importCSVs + Command mainParams' (Report subParams) -> toRuntimeOptionsReport mainParams' subParams >>= generateReports -toRuntimeOptions :: MainParams -> SubcommandParams -> IO RT.RuntimeOptions -toRuntimeOptions mainParams' subParams' = do - bd <- determineBaseDir $ maybeBaseDir subParams' +toRuntimeOptionsImport :: MainParams -> ImportParams -> IO RT.RuntimeOptions +toRuntimeOptionsImport mainParams' subParams' = do + (bd, runDir) <- determineBaseDir $ maybeImportBaseDir subParams' hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' return RT.RuntimeOptions { RT.baseDir = bd - , RT.runDir = maybeRunDir subParams' + , RT.importRunDir = runDir + , RT.useRunDir = importUseRunDir subParams' , RT.hfVersion = versionInfo' , RT.hledgerInfo = hli , RT.sysInfo = systemInfo @@ -44,13 +48,27 @@ , RT.showOptions = showOpts mainParams' , RT.sequential = sequential mainParams' } +toRuntimeOptionsReport :: MainParams -> ReportParams -> IO RT.RuntimeOptions +toRuntimeOptionsReport mainParams' subParams' = do + (bd, _) <- determineBaseDir $ maybeReportBaseDir subParams' + hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams' + return RT.RuntimeOptions { RT.baseDir = bd + , RT.importRunDir = "./" + , RT.useRunDir = False + , RT.hfVersion = versionInfo' + , RT.hledgerInfo = hli + , RT.sysInfo = systemInfo + , RT.verbose = verbosity mainParams' > 0 + , RT.showOptions = showOpts mainParams' + , RT.sequential = sequential mainParams' } + baseCommandParser :: Parser BaseCommand baseCommandParser = (Command <$> verboseParser <*> commandParser) <|> flag' Version (long "version" <> short 'V' <> help "Display version information") commandParser :: Parser Command -commandParser = fmap Import (subcommand "import" "Converts electronic transactions into categorised journal files" subcommandParser) - <|> fmap Report (subcommand "report" "Generate Reports" subcommandParser) +commandParser = fmap Import (subcommand "import" "Uses hledger with your own rules and/or scripts to convert electronic statements into categorised journal files" subcommandParserImport) + <|> fmap Report (subcommand "report" "Generate Reports" subcommandParserReport) verboseParser :: Parser MainParams verboseParser = MainParams @@ -59,7 +77,11 @@ <*> switch (long "show-options" <> help "Print the options this program will run with") <*> switch (long "sequential" <> help "Disable parallel processing") -subcommandParser :: Parser SubcommandParams -subcommandParser = SubcommandParams +subcommandParserImport :: Parser ImportParams +subcommandParserImport = ImportParams + <$> optional (argPath "dir" "The directory to import. Use the base directory for a full import or a sub-directory for a partial import. Defaults to the current directory. This behaviour is changing: see --enable-future-rundir") + <*> switch (long "enable-future-rundir" <> help "Enable the future (0.14.x) default behaviour now: start importing only from the directory that was given as an argument, or the currect directory. Previously a full import was always done. This switch will be removed in 0.14.x") + +subcommandParserReport :: Parser ReportParams +subcommandParserReport = ReportParams <$> optional (argPath "basedir" "The hledger-flow base directory") - <*> optional (strOption (long "experimental-rundir" <> help "A subdirectory of the base where the command will restrict itself to")) diff --git a/hledger-flow.cabal b/hledger-flow.cabal --- a/hledger-flow.cabal +++ b/hledger-flow.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 617874a347909e345431628a3616c190537a585179618eb631c162fb36a81bff +-- hash: 735099a4aed6ae3be8f511959f660740e93a66852c0a4aeb4b1d3b29e7a951c8 name: hledger-flow -version: 0.13.1.0 +version: 0.13.2.0 synopsis: An hledger workflow focusing on automated statement import and classification. description: Please see the README on GitHub at category: Finance, Console diff --git a/src/Hledger/Flow/CSVImport.hs b/src/Hledger/Flow/CSVImport.hs --- a/src/Hledger/Flow/CSVImport.hs +++ b/src/Hledger/Flow/CSVImport.hs @@ -35,10 +35,12 @@ importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [FilePath] importCSVs' opts ch = do - channelOutLn ch "Collecting input files..." - let effectiveDir = case runDir opts of - Nothing -> (baseDir opts) "import" - Just rd -> rd + let baseImportDir = forceTrailingSlash $ (baseDir opts) "import" + let runDir = forceTrailingSlash $ collapse $ (baseDir opts) (importRunDir opts) + let effectiveDir = if useRunDir opts + then if (forceTrailingSlash $ runDir "import") == baseImportDir then baseImportDir else runDir + else baseImportDir + channelOutLn ch $ format ("Collecting input files from "%fp) effectiveDir (inputFiles, diff) <- time $ single . shellToList . onlyFiles $ find inputFilePattern effectiveDir let fileCount = length inputFiles if (fileCount == 0) then @@ -52,7 +54,8 @@ channelOutLn ch $ format ("Found "%d%" input files in "%s%". Proceeding with import...") fileCount (repr diff) let actions = map (extractAndImport opts ch) inputFiles :: [IO FilePath] importedJournals <- parAwareActions opts actions - sh $ writeIncludesUpTo opts ch "import" importedJournals + _ <- writeIncludesUpTo opts ch effectiveDir importedJournals + _ <- writeToplevelAllYearsInclude opts return importedJournals extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> FilePath -> IO FilePath 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 @@ -211,7 +211,8 @@ relativeToBase opts = relativeToBase' (baseDir opts) relativeToBase' :: FilePath -> FilePath -> FilePath -relativeToBase' bd p = fromMaybe p $ stripPrefix (forceTrailingSlash bd) p +relativeToBase' bd p = if forceTrailingSlash bd == forceTrailingSlash p then "./" else + fromMaybe p $ stripPrefix (forceTrailingSlash bd) p groupPairs' :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])] groupPairs' = map (\ll -> (fst . head $ ll, map snd ll)) . List.groupBy ((==) `on` fst) @@ -238,6 +239,9 @@ allYearsPath' :: (FilePath -> FilePath) -> FilePath -> FilePath allYearsPath' dir p = dir p "all-years.journal" +allYearsFileName :: FilePath +allYearsFileName = "all-years" <.> "journal" + groupIncludeFiles :: [FilePath] -> (InputFileBundle, InputFileBundle) groupIncludeFiles = allYearIncludeFiles . groupIncludeFilesPerYear @@ -320,22 +324,22 @@ includeFileName :: FilePath -> FilePath includeFileName = (<.> "journal") . fromText . (format (fp%"-include")) . dirname -toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> InputFileBundle -> Shell (Map.Map FilePath Text) +toIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> InputFileBundle -> IO (Map.Map FilePath Text) toIncludeFiles opts ch m = do preMap <- extraIncludes opts ch (Map.keys m) ["opening.journal"] ["pre-import.journal"] [] postMap <- extraIncludes opts ch (Map.keys m) ["closing.journal"] ["post-import.journal"] ["prices.journal"] return $ (addPreamble . toIncludeFiles' preMap postMap) m -extraIncludes :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> [Text] -> [FilePath] -> [FilePath] -> Shell InputFileBundle +extraIncludes :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> [Text] -> [FilePath] -> [FilePath] -> IO InputFileBundle extraIncludes opts ch = extraIncludes' opts ch Map.empty -extraIncludes' :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> InputFileBundle -> [FilePath] -> [Text] -> [FilePath] -> [FilePath] -> Shell InputFileBundle +extraIncludes' :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> InputFileBundle -> [FilePath] -> [Text] -> [FilePath] -> [FilePath] -> IO InputFileBundle extraIncludes' _ _ acc [] _ _ _ = return acc extraIncludes' opts ch acc (file:files) extraSuffixes manualFiles prices = do extra <- extraIncludesForFile opts ch file extraSuffixes manualFiles prices extraIncludes' opts ch (Map.unionWith (++) acc extra) files extraSuffixes manualFiles prices -extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [Text] -> [FilePath] -> [FilePath] -> Shell InputFileBundle +extraIncludesForFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> [Text] -> [FilePath] -> [FilePath] -> IO InputFileBundle extraIncludesForFile opts ch file extraSuffixes manualFiles prices = do let dirprefix = fromText $ fst $ T.breakOn "-" $ format fp $ basename file let fileNames = map (\suff -> fromText $ format (fp%"-"%s) dirprefix suff) extraSuffixes @@ -343,11 +347,11 @@ let suffixDirFiles = map (directory file "_manual_" dirprefix ) manualFiles let priceFiles = map (directory file ".." "prices" dirprefix ) prices let extraFiles = suffixFiles ++ suffixDirFiles ++ priceFiles - filtered <- filterPaths testfile extraFiles + filtered <- single $ filterPaths testfile extraFiles let logMsg = format ("Looking for possible extra include files for '"%fp%"' among these "%d%" options: "%s%". Found "%d%": "%s) (relativeToBase opts file) (length extraFiles) (repr $ relativeFilesAsText opts extraFiles) (length filtered) (repr $ relativeFilesAsText opts filtered) - liftIO $ logVerbose opts ch logMsg + logVerbose opts ch logMsg return $ Map.fromList [(file, filtered)] relativeFilesAsText :: HasBaseDir o => o -> [FilePath] -> [Text] @@ -373,39 +377,42 @@ includePreamble :: Text includePreamble = "### Generated by hledger-flow - DO NOT EDIT ###\n" -groupAndWriteIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> Shell [FilePath] +groupAndWriteIncludeFiles :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> [FilePath] -> IO [FilePath] groupAndWriteIncludeFiles opts ch = writeFileMap opts ch . groupIncludeFiles -writeFiles :: Shell (Map.Map FilePath Text) -> Shell [FilePath] +writeFiles :: IO (Map.Map FilePath Text) -> IO [FilePath] writeFiles fileMap = do m <- fileMap writeFiles' m -writeFiles' :: Map.Map FilePath Text -> Shell [FilePath] +writeFiles' :: Map.Map FilePath Text -> IO [FilePath] writeFiles' fileMap = do - liftIO $ writeTextMap fileMap + writeTextMap fileMap return $ Map.keys fileMap writeTextMap :: Map.Map FilePath Text -> IO () writeTextMap = Map.foldlWithKey (\a k v -> a <> writeTextFile k v) (return ()) -writeFileMap :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> (InputFileBundle, InputFileBundle) -> Shell [FilePath] +writeFileMap :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> (InputFileBundle, InputFileBundle) -> IO [FilePath] writeFileMap opts ch (m, allYears) = do _ <- writeFiles' $ (addPreamble . toIncludeFiles' Map.empty Map.empty) allYears writeFiles . (toIncludeFiles opts ch) $ m -writeIncludesUpTo :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> FilePath -> [FilePath] -> Shell [FilePath] +writeIncludesUpTo :: (HasBaseDir o, HasVerbosity o) => o -> TChan LogMessage -> FilePath -> [FilePath] -> IO [FilePath] writeIncludesUpTo _ _ _ [] = return [] -writeIncludesUpTo opts ch stopAt paths = do - let shouldStop = any (\dir -> dir == stopAt) $ map dirname paths +writeIncludesUpTo opts ch stopAt journalFiles = do + let shouldStop = any (\dir -> dir == stopAt) $ map parent journalFiles if shouldStop - then do - let allTop = groupValuesBy (allYearsPath' (parent . parent)) paths - writeFileMap opts ch (Map.empty, allTop) + then return journalFiles else do - newPaths <- groupAndWriteIncludeFiles opts ch paths - writeIncludesUpTo opts ch stopAt newPaths + newJournalFiles <- groupAndWriteIncludeFiles opts ch journalFiles + writeIncludesUpTo opts ch stopAt newJournalFiles +writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath] +writeToplevelAllYearsInclude opts = do + let allTop = Map.singleton (baseDir opts allYearsFileName) ["import" allYearsFileName] + writeFiles' $ (addPreamble . toIncludeFiles' Map.empty Map.empty) allTop + changeExtension :: Text -> FilePath -> FilePath changeExtension ext path = (dropExtension path) <.> ext @@ -422,30 +429,42 @@ %"Have a look at the documentation for more information:\n"%s%"\n") startDir (docURL "getting-started") -determineBaseDir :: Maybe FilePath -> IO FilePath +determineBaseDir :: Maybe FilePath -> IO (FilePath, FilePath) determineBaseDir (Just suppliedDir) = determineBaseDir' suppliedDir determineBaseDir Nothing = pwd >>= determineBaseDir' -determineBaseDir' :: FilePath -> IO FilePath +determineBaseDir' :: FilePath -> IO (FilePath, FilePath) determineBaseDir' startDir = do currentDir <- pwd let absoluteStartDir = if relative startDir then collapse (currentDir startDir) else startDir - ebd <- determineBaseDir'' absoluteStartDir absoluteStartDir + ebd <- determineBaseDirFromAbsoluteStartDir absoluteStartDir case ebd of Right bd -> return bd Left t -> die t -determineBaseDir'' :: FilePath -> FilePath -> IO (Either Text FilePath) -determineBaseDir'' startDir currentDir = do - foundBaseDir <- testdir $ currentDir "import" - if foundBaseDir - then return $ Right $ forceTrailingSlash currentDir +determineBaseDirFromAbsoluteStartDir :: FilePath -> IO (Either Text (FilePath, FilePath)) +determineBaseDirFromAbsoluteStartDir absoluteStartDir = determineBaseDirFromAbsoluteStartDir' absoluteStartDir absoluteStartDir + +determineBaseDirFromAbsoluteStartDir' :: FilePath -> FilePath -> IO (Either Text (FilePath, FilePath)) +determineBaseDirFromAbsoluteStartDir' startDir possibleBaseDir = do + possibleBDExists <- testdir possibleBaseDir + if not possibleBDExists then return $ Left $ format ("The provided directory does not exist: "%fp) possibleBaseDir else - do - let doneSearching = (currentDir `elem` ["/", "./"]) + if relative startDir || relative possibleBaseDir then + return $ Left $ format ("Internal error: found a relative path when expecting only absolute paths:\n"%fp%"\n"%fp%"\n") startDir possibleBaseDir + else do + foundBaseDir <- testdir $ possibleBaseDir "import" + if foundBaseDir then + do + let baseD = forceTrailingSlash possibleBaseDir + let runDir = forceTrailingSlash $ relativeToBase' baseD startDir + return $ Right $ (baseD, runDir) + else do + let doneSearching = (possibleBaseDir `elem` ["/", "./"]) if doneSearching then return $ Left $ errorMessageBaseDir startDir - else determineBaseDir'' startDir $ parent currentDir + else determineBaseDirFromAbsoluteStartDir' startDir $ parent possibleBaseDir + dirOrPwd :: Maybe FilePath -> IO FilePath dirOrPwd maybeBaseDir = fmap forceTrailingSlash (fromMaybe pwd $ fmap realpath maybeBaseDir) 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 @@ -10,6 +10,7 @@ import Hledger.Flow.Common import Control.Concurrent.STM import Data.Either +import Data.Maybe import qualified Data.Text as T import qualified Hledger.Flow.Types as FlowTypes @@ -44,10 +45,16 @@ <> "https://github.com/apauley/hledger-flow/issues\n" channelOutLn ch wipMsg owners <- single $ shellToList $ listOwners opts - let aggregateJournal = journalFile opts [] + ledgerEnvValue <- need "LEDGER_FILE" :: IO (Maybe Text) + let hledgerJournal = fromMaybe (baseDir opts allYearsFileName) $ fmap fromText ledgerEnvValue + hledgerJournalExists <- testfile hledgerJournal + _ <- if not hledgerJournalExists then die $ format ("Unable to find journal file: "%fp%"\nIs your LEDGER_FILE environment variable set correctly?") hledgerJournal else return () + let journalWithYears = journalFile opts [] let aggregateReportDir = outputReportDir opts ["all"] - aggregateYears <- includeYears ch aggregateJournal - let aggregateParams = ReportParams aggregateJournal aggregateYears aggregateReportDir + aggregateYears <- includeYears ch journalWithYears + let aggregateParams = ReportParams { ledgerFile = hledgerJournal + , reportYears = aggregateYears + , outputDir = aggregateReportDir} let aggregateOnlyReports = reportActions opts ch [transferBalance] aggregateParams ownerParams <- ownerParameters opts ch owners let ownerWithAggregateParams = (if length owners > 1 then [aggregateParams] else []) ++ ownerParams @@ -112,7 +119,7 @@ return $ Left outputFile journalFile :: RuntimeOptions -> [FilePath] -> FilePath -journalFile opts dirs = (foldl () (baseDir opts) dirs) "all-years" <.> "journal" +journalFile opts dirs = (foldl () (baseDir opts) ("import":dirs)) allYearsFileName outputReportDir :: RuntimeOptions -> [FilePath] -> FilePath outputReportDir opts dirs = foldl () (baseDir opts) ("reports":dirs) @@ -124,6 +131,6 @@ ownerParameters' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> FilePath -> IO ReportParams ownerParameters' opts ch owner = do - let ownerJournal = journalFile opts ["import", owner] + let ownerJournal = journalFile opts [owner] years <- includeYears ch ownerJournal return $ ReportParams ownerJournal years (outputReportDir opts [owner]) 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 @@ -6,7 +6,8 @@ import Hledger.Flow.Types data RuntimeOptions = RuntimeOptions { baseDir :: FilePath - , runDir :: Maybe FilePath + , importRunDir :: FilePath + , useRunDir :: Bool , hfVersion :: Text , hledgerInfo :: HledgerInfo , sysInfo :: SystemInfo @@ -17,10 +18,10 @@ deriving (Show) instance HasVerbosity RuntimeOptions where - verbose (RuntimeOptions _ _ _ _ _ v _ _) = v + verbose (RuntimeOptions _ _ _ _ _ _ v _ _) = v instance HasSequential RuntimeOptions where - sequential (RuntimeOptions _ _ _ _ _ _ _ sq) = sq + sequential (RuntimeOptions _ _ _ _ _ _ _ _ sq) = sq instance HasBaseDir RuntimeOptions where - baseDir (RuntimeOptions bd _ _ _ _ _ _ _) = bd + baseDir (RuntimeOptions bd _ _ _ _ _ _ _ _) = bd diff --git a/test/CSVImport/Integration.hs b/test/CSVImport/Integration.hs --- a/test/CSVImport/Integration.hs +++ b/test/CSVImport/Integration.hs @@ -30,18 +30,18 @@ ch <- liftIO newTChanIO - extraOpening1 <- extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["opening.journal"] [] [] + extraOpening1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["opening.journal"] [] [] liftIO $ assertEqual "The opening journal should not be included when it is not on disk" expectedEmpty extraOpening1 - extraClosing1 <- extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["closing.journal"] [] [] + extraClosing1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["closing.journal"] [] [] liftIO $ assertEqual "The closing journal should not be included when it is not on disk" expectedEmpty extraClosing1 touchAll [opening, closing] - extraOpening2 <- extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["opening.journal"] [] [] + extraOpening2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["opening.journal"] [] [] liftIO $ assertEqual "The opening journal should be included when it is on disk" [(accountInclude, [opening])] extraOpening2 - extraClosing2 <- extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["closing.journal"] [] [] + extraClosing2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch accountInclude ["closing.journal"] [] [] liftIO $ assertEqual "The closing journal should be included when it is on disk" [(accountInclude, [closing])] extraClosing2 )) @@ -60,13 +60,13 @@ ch <- liftIO newTChanIO - price1 <- extraIncludesForFile (defaultOpts tmpdir) ch includeFile [] [] ["prices.journal"] + price1 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch includeFile [] [] ["prices.journal"] liftIO $ assertEqual "The price file should not be included when it is not on disk" expectedEmpty price1 touchAll [tmpdir priceFile] let expectedPricePath = tmpdir "import" ".." priceFile - price2 <- extraIncludesForFile (defaultOpts tmpdir) ch includeFile [] [] ["prices.journal"] + price2 <- liftIO $ extraIncludesForFile (defaultOpts tmpdir) ch includeFile [] [] ["prices.journal"] liftIO $ assertEqual "The price file should be included when it is on disk" [(includeFile, [expectedPricePath])] price2 )) @@ -85,7 +85,7 @@ ownerDir "bank2" "2019-include.journal"] ch <- liftIO newTChanIO - fileMap <- toIncludeFiles (defaultOpts tmpdir) ch includeMap + fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdir) ch includeMap let expectedText = includePreamble <> "\n" <> "!include _manual_/2019/pre-import.journal\n" <> "!include bank1/2019-include.journal\n" @@ -110,7 +110,7 @@ let includeMap = Map.singleton includeFile [accountDir "3-journal" "2019" "2019-01-30.journal"] ch <- liftIO newTChanIO - fileMap <- toIncludeFiles (defaultOpts tmpdir) ch includeMap + fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdir) ch includeMap let expectedText = includePreamble <> "\n" <> "!include 2019-opening.journal\n" <> "!include 3-journal/2019/2019-01-30.journal\n" @@ -134,7 +134,7 @@ let includeMap = Map.singleton includeFile [importDir "john" "2020-include.journal"] ch <- liftIO newTChanIO - fileMap <- toIncludeFiles (defaultOpts tmpdir) ch includeMap + fileMap <- liftIO $ toIncludeFiles (defaultOpts tmpdir) ch includeMap let expectedText = includePreamble <> "\n" <> "!include _manual_/2020/pre-import.journal\n" <> "!include john/2020-include.journal\n" @@ -175,7 +175,7 @@ john1, john2, john3, john4, john5, john6, john7, john8] ch <- liftIO newTChanIO - reportedAsWritten <- single $ groupAndWriteIncludeFiles (defaultOpts tmpdir) ch importedJournals + reportedAsWritten <- liftIO $ groupAndWriteIncludeFiles (defaultOpts tmpdir) ch importedJournals liftIO $ assertEqual "groupAndWriteIncludeFiles should return which files it wrote" expectedIncludes reportedAsWritten let allYears = [tmpdir "import/jane/bogartbank/checking/all-years.journal", diff --git a/test/CSVImport/Unit.hs b/test/CSVImport/Unit.hs --- a/test/CSVImport/Unit.hs +++ b/test/CSVImport/Unit.hs @@ -12,6 +12,9 @@ import TestHelpers import Hledger.Flow.Common +import Data.Either +import qualified Data.Text as T + groupedJaneBogart :: Map.Map FilePath [FilePath] groupedJaneBogart = [ ("./import/jane/bogartbank/checking/2018-include.journal", @@ -350,24 +353,31 @@ assertEqual "groupIncludeFiles 5" expectedGroup5 group5 ) -testRelativeToBase :: Test -testRelativeToBase = TestCase ( +testIncludeYears :: Test +testIncludeYears = TestCase ( do - let expected = "file1.journal" - let relativeWithTrailingSlash = relativeToBase' "./base/dir/" "./base/dir/file1.journal" - assertEqual "relative base dir with trailing slash" expected relativeWithTrailingSlash + let txterr = "Some text without years" + let expectederr = ["Unable to extract years from the following text:", txterr, "Errors:"] + let actualerr = (init . head) $ map (T.lines) $ lefts [includeYears' txterr] :: [Text] + assertEqual "Get a list of years from an include file - error case" expectederr actualerr - let relativeNoTrailingSlash = relativeToBase' "./base/dir" "./base/dir/file1.journal" - assertEqual "relative base dir without a trailing slash" expected relativeNoTrailingSlash + 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 absoluteWithTrailingSlash = relativeToBase' "/base/dir/" "/base/dir/file1.journal" - assertEqual "absolute base dir with trailing slash" expected absoluteWithTrailingSlash + 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 absoluteNoTrailingSlash = relativeToBase' "/base/dir" "/base/dir/file1.journal" - assertEqual "absolute base dir without a trailing slash" expected absoluteNoTrailingSlash + let txt2 = "!include 2019-include.journal" - let mismatch = relativeToBase' "/base/dir" "/unrelated/dir/file1.journal" - assertEqual "A basedir with no shared prefix should return the supplied file unchanged" "/unrelated/dir/file1.journal" mismatch + 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 @@ -409,9 +419,9 @@ "!include import/john/bogartbank/savings/3-journal/2018/2018-01-30.journal\n" <> "!include import/john/bogartbank/savings/3-journal/2018/2018-02-30.journal\n")] - ch <- liftIO newTChanIO - txt <- single $ toIncludeFiles (defaultOpts ".") ch groupedJohnBogart + ch <- newTChanIO + txt <- toIncludeFiles (defaultOpts ".") ch groupedJohnBogart assertEqual "Convert a grouped map of paths, to a map with text contents for each file" expected txt) tests :: Test -tests = TestList [testYearsIncludeMap, testYearsIncludeGrouping, testGroupIncludeFilesTinySet, testGroupIncludeFilesSmallSet, testGroupIncludeFiles, testRelativeToBase, testToIncludeLine, testToIncludeFiles] +tests = TestList [testYearsIncludeMap, testYearsIncludeGrouping, testGroupIncludeFilesTinySet, testGroupIncludeFilesSmallSet, testGroupIncludeFiles, testIncludeYears, testToIncludeLine, testToIncludeFiles] diff --git a/test/Common/Integration.hs b/test/Common/Integration.hs --- a/test/Common/Integration.hs +++ b/test/Common/Integration.hs @@ -16,7 +16,9 @@ testHiddenFiles = TestCase ( sh ( do - tmpdir <- using (mktempdir "." "hlflow") + let tmpbase = "." "test" "tmp" + mktree tmpbase + tmpdir <- using (mktempdir tmpbase "hlflowtest") let tmpJournals = map (tmpdir ) journalFiles :: [FilePath] let tmpExtras = map (tmpdir ) extraFiles :: [FilePath] let tmpHidden = map (tmpdir ) hiddenFiles :: [FilePath] @@ -28,35 +30,78 @@ ) ) -assertSubDirsForDetermineBaseDir :: FilePath -> [FilePath] -> IO () -assertSubDirsForDetermineBaseDir expectedBaseDir importDirs = do - _ <- sequence $ map (assertDetermineBaseDir expectedBaseDir) importDirs +assertSubDirsForDetermineBaseDir :: FilePath -> FilePath -> [FilePath] -> IO () +assertSubDirsForDetermineBaseDir initialPwd expectedBaseDir importDirs = do + _ <- sequence $ map (assertDetermineBaseDir initialPwd expectedBaseDir) importDirs return () -assertDetermineBaseDir :: FilePath -> FilePath -> IO () -assertDetermineBaseDir expectedBaseDir subDir = do - initialPwd <- pwd - bd1 <- determineBaseDir $ Just subDir +assertDetermineBaseDir :: FilePath -> FilePath -> FilePath -> IO () +assertDetermineBaseDir initialPwd expectedBaseDir subDir = do + cd initialPwd + (bd1, runDir1) <- determineBaseDir $ Just subDir + assertFindTestFileUsingRundir bd1 runDir1 + cd subDir - bd2 <- determineBaseDir Nothing - bd3 <- determineBaseDir $ Just "." + (bd2, runDir2) <- determineBaseDir Nothing + assertFindTestFileUsingRundir bd2 runDir2 + + (bd3, runDir3) <- determineBaseDir $ Just "." + assertFindTestFileUsingRundir bd3 runDir3 + + (bd4, runDir4) <- determineBaseDir $ Just "./" + assertFindTestFileUsingRundir bd4 runDir4 + cd initialPwd let msg = format ("determineBaseDir searches from pwd upwards until it finds a dir containing 'import' - "%fp) subDir - _ <- sequence $ map (assertEqual (T.unpack msg) expectedBaseDir) [bd1, bd2, bd3] + _ <- sequence $ map (assertEqual (T.unpack msg) expectedBaseDir) [bd1, bd2, bd3, bd4] return () +assertFindTestFileUsingRundir :: FilePath -> FilePath -> IO () +assertFindTestFileUsingRundir baseDir runDir = do + let absRunDir = baseDir runDir + let dirTestMsg = format ("Directories should end with a slash: "%fp) + _ <- sequence $ map (\dir -> assertEqual (T.unpack $ dirTestMsg dir) (forceTrailingSlash dir) dir) [baseDir, runDir, absRunDir] + + found <- single $ fmap head $ shellToList $ find (has "test-file.txt") absRunDir + fileContents <- readTextFile found + assertEqual "We should find our test file by searching from the returned runDir" (format ("The expected base dir is "%fp) baseDir) fileContents + +assertCurrentDirVariations :: FilePath -> FilePath -> IO () +assertCurrentDirVariations absoluteTempDir bdRelativeToTempDir = do + let absBaseDirNoTrailingSlash = absoluteTempDir bdRelativeToTempDir + let absBaseDirWithTrailingSlash = forceTrailingSlash absBaseDirNoTrailingSlash + assertEqual "Test the test: with and without slashes should really be that" '/' (T.last $ format fp absBaseDirWithTrailingSlash) + assertBool "Test the test: with and without slashes should really be that" ('/' /= (T.last $ format fp absBaseDirNoTrailingSlash)) + + cd absBaseDirNoTrailingSlash + (bd1, runDir1) <- liftIO $ determineBaseDir Nothing + (bd2, runDir2) <- liftIO $ determineBaseDir $ Just "." + (bd3, runDir3) <- liftIO $ determineBaseDir $ Just "./" + (bd4, runDir4) <- liftIO $ determineBaseDir $ Just absBaseDirNoTrailingSlash + (bd5, runDir5) <- liftIO $ determineBaseDir $ Just absBaseDirWithTrailingSlash + + let msg label dir = format ("When pwd is the base dir, determineBaseDir returns the same "%s%", regardless of the input variation. "%s%": "%fp) label label dir + _ <- sequence $ map (\dir -> assertEqual (T.unpack $ msg "baseDir" dir) (forceTrailingSlash dir) dir) [bd1, bd2, bd3, bd4,bd5] + _ <- sequence $ map (\dir -> assertEqual (T.unpack $ msg "runDir" dir) "./" dir) [runDir1, runDir2, runDir3, runDir4, runDir5] + -- _ <- sequence $ map (\dir -> assertEqual (T.unpack $ msg "runDir" dir) "./" dir) [runDir2, runDir3, runDir4, runDir5] + return () + testDetermineBaseDir :: Test testDetermineBaseDir = TestCase ( sh ( do - error1 <- liftIO $ determineBaseDir'' "/path/to/dir" "/path/to/dir" - liftIO $ assertEqual "determineBaseDir produces an error message when given a non-existant dir" (Left $ errorMessageBaseDir "/path/to/dir") error1 - tmpdir <- using (mktempdir "." "hlflow") + error1 <- liftIO $ determineBaseDirFromAbsoluteStartDir "/path/to/dir" + liftIO $ assertEqual "determineBaseDir produces an error message when given a non-existant dir" (Left "The provided directory does not exist: /path/to/dir") error1 - let unrelatedDir = collapse $ tmpdir "unrelated" + initialPwd <- fmap forceTrailingSlash pwd + let tmpbase = initialPwd "test" "tmp" + mktree tmpbase + absoluteTempDir <- fmap forceTrailingSlash $ using (mktempdir tmpbase "hlflowtest") + + let unrelatedDir = absoluteTempDir "unrelated" mkdir unrelatedDir - bdUnrelated <- liftIO $ determineBaseDir'' unrelatedDir unrelatedDir + bdUnrelated <- liftIO $ determineBaseDirFromAbsoluteStartDir unrelatedDir liftIO $ assertEqual "determineBaseDir produces an error message when it cannot find a baseDir" (Left $ errorMessageBaseDir unrelatedDir) bdUnrelated let baseDir = "bd1" @@ -68,20 +113,27 @@ let yearDir = inDir "2019" let subDirs = [yearDir, inDir, accDir, bankDir, ownerDir, importDir, baseDir] - mktree $ tmpdir yearDir + mktree $ absoluteTempDir yearDir - let subDirsRelativeToTop = map (tmpdir ) subDirs + let fictionalDir = absoluteTempDir ownerDir "fictionalDir" + errorSub <- liftIO $ determineBaseDirFromAbsoluteStartDir fictionalDir + liftIO $ assertEqual "determineBaseDir produces an error message when given a non-existant subdir of a valid basedir" (Left $ format ("The provided directory does not exist: "%fp) fictionalDir) errorSub - currentDir <- pwd - let absoluteTempDir = forceTrailingSlash $ collapse $ currentDir tmpdir + let relativeTempDir = foldl1 mappend (dropWhile (\el -> el `elem` (splitDirectories initialPwd)) (splitDirectories absoluteTempDir)) + + + let subDirsRelativeToTop = map (relativeTempDir ) subDirs let absoluteSubDirs = map (absoluteTempDir ) subDirs let absoluteBaseDir = forceTrailingSlash $ absoluteTempDir baseDir - liftIO $ assertSubDirsForDetermineBaseDir absoluteBaseDir absoluteSubDirs - liftIO $ assertSubDirsForDetermineBaseDir absoluteBaseDir subDirsRelativeToTop - cd absoluteTempDir - liftIO $ assertSubDirsForDetermineBaseDir absoluteBaseDir subDirs + liftIO $ assertCurrentDirVariations absoluteTempDir baseDir + + liftIO $ writeTextFile (absoluteTempDir yearDir "test-file.txt") $ format ("The expected base dir is "%fp) absoluteBaseDir + + liftIO $ assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir subDirs + liftIO $ assertSubDirsForDetermineBaseDir absoluteTempDir absoluteBaseDir absoluteSubDirs + liftIO $ assertSubDirsForDetermineBaseDir initialPwd absoluteBaseDir subDirsRelativeToTop ) ) @@ -89,7 +141,9 @@ testFilterPaths = TestCase ( sh ( do - tmpdir <- using (mktempdir "." "hlflow") + let tmpbase = "." "test" "tmp" + mktree tmpbase + tmpdir <- using (mktempdir tmpbase "hlflowtest") let tmpJournals = map (tmpdir ) journalFiles :: [FilePath] let tmpExtras = map (tmpdir ) extraFiles :: [FilePath] let tmpHidden = map (tmpdir ) hiddenFiles :: [FilePath] diff --git a/test/Common/Unit.hs b/test/Common/Unit.hs --- a/test/Common/Unit.hs +++ b/test/Common/Unit.hs @@ -4,14 +4,10 @@ module Common.Unit where import Test.HUnit -import Turtle import Prelude hiding (FilePath) import Hledger.Flow.Common -import Data.Either -import qualified Data.Text as T - testShowCmdArgs :: Test testShowCmdArgs = TestCase ( do @@ -20,31 +16,33 @@ let actual = showCmdArgs opts assertEqual "Convert command-line arguments to text" expected actual) -testIncludeYears :: Test -testIncludeYears = TestCase ( +testRelativeToBase :: Test +testRelativeToBase = TestCase ( do - let txterr = "Some text without years" - let expectederr = ["Unable to extract years from the following text:", txterr, "Errors:"] - let actualerr = (init . head) $ map (T.lines) $ lefts [includeYears' txterr] :: [Text] - assertEqual "Get a list of years from an include file - error case" expectederr actualerr + let expected = "file1.journal" + let relativeWithTrailingSlash = relativeToBase' "./base/dir/" "./base/dir/file1.journal" + assertEqual "relative base dir with trailing slash" expected relativeWithTrailingSlash - 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 relativeNoTrailingSlash = relativeToBase' "./base/dir" "./base/dir/file1.journal" + assertEqual "relative base dir without a trailing slash" expected relativeNoTrailingSlash - 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 absoluteWithTrailingSlash = relativeToBase' "/base/dir/" "/base/dir/file1.journal" + assertEqual "absolute base dir with trailing slash" expected absoluteWithTrailingSlash - let txt2 = "!include 2019-include.journal" + let absoluteNoTrailingSlash = relativeToBase' "/base/dir" "/base/dir/file1.journal" + assertEqual "absolute base dir without a trailing slash" expected absoluteNoTrailingSlash - let expected2 = Right [2019] - let actual2 = includeYears' txt2 - assertEqual "Get a list of years from an include file - success case 2" expected2 actual2 + let absoluteTwiceNoTrailingSlash = relativeToBase' "/base/dir" "/base/dir" + assertEqual "absolute base dir without a trailing slash supplied twice" "./" absoluteTwiceNoTrailingSlash + + let absoluteTwiceWithTrailingSlash = relativeToBase' "/base/dir/" "/base/dir/" + assertEqual "absolute base dir with a trailing slash supplied twice" "./" absoluteTwiceWithTrailingSlash + + let absoluteTwiceNoTrailingSlashOnSecondParam = relativeToBase' "/base/dir/" "/base/dir" + assertEqual "absolute base dir supplied twice, but the second param has no slash" "./" absoluteTwiceNoTrailingSlashOnSecondParam + + let mismatch = relativeToBase' "/base/dir" "/unrelated/dir/file1.journal" + assertEqual "A basedir with no shared prefix should return the supplied file unchanged" "/unrelated/dir/file1.journal" mismatch ) testExtractDigits :: Test @@ -64,4 +62,4 @@ ) tests :: Test -tests = TestList [testShowCmdArgs, testIncludeYears, testExtractDigits] +tests = TestList [testShowCmdArgs, testRelativeToBase, testExtractDigits] diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs --- a/test/TestHelpers.hs +++ b/test/TestHelpers.hs @@ -59,7 +59,7 @@ defaultHlInfo = FlowTypes.HledgerInfo "/path/to/hledger" "1.2.3" defaultOpts :: FilePath -> RuntimeOptions -defaultOpts bd = RuntimeOptions bd Nothing versionInfo' defaultHlInfo systemInfo False False False +defaultOpts bd = RuntimeOptions bd "./" True versionInfo' defaultHlInfo systemInfo False False False toJournals :: [FilePath] -> [FilePath] toJournals = map (changePathAndExtension "3-journal" "journal")