hledger-flow 0.14.1.0 → 0.14.2.0

raw patch · 15 files changed

+399/−272 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• app/Main.hs +10/−4
• app/Parsing.hs +25/−0
• hledger-flow.cabal +7/−3
• src/Hledger/Flow/CSVImport.hs +0/−210
• src/Hledger/Flow/Common.hs +5/−48
• src/Hledger/Flow/DateTime.hs +12/−0
• src/Hledger/Flow/Import/CSVImport.hs +212/−0
• src/Hledger/Flow/Import/ImportHelpers.hs +32/−0
• src/Hledger/Flow/Logging.hs +58/−0
• src/Hledger/Flow/PathHelpers.hs +19/−0
• src/Hledger/Flow/Reports.hs +1/−0
• src/Hledger/Flow/RuntimeOptions.hs +5/−4
• src/Hledger/Flow/Types.hs +2/−3
• test/TestHelpers.hs +1/−0

@@ -1,5 +1,15 @@ # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow) +## 0.14.2++Add an optional `--start-year` command-line option for imports:++Import only from the specified year and onwards,+ignoring previous years. Valid values include a 4-digit+year or 'current' for the current year.++An implementation for [this feature request](https://github.com/apauley/hledger-flow/issues/81)+ ## 0.14.1  - Make `--enable-future-rundir` the default, and deprecate the command-line option. To be removed in a future release.

@@ -3,6 +3,7 @@  module Main where +import Parsing import Path import qualified Turtle hiding (switch) import Prelude hiding (putStrLn)@@ -14,17 +15,18 @@ import Hledger.Flow.BaseDir import qualified Hledger.Flow.RuntimeOptions as RT import Hledger.Flow.Reports-import Hledger.Flow.CSVImport+import Hledger.Flow.Import.CSVImport  import Control.Monad (when) import qualified Data.Text.IO as T  data ImportParams = ImportParams { maybeImportBaseDir :: Maybe TurtlePath-                                 , importUseRunDir :: Bool+                                 , importStartYear :: Maybe String                                  , onlyNewFiles :: Bool+                                 , importUseRunDir :: Bool                                  } deriving (Show) -data ReportParams = ReportParams { maybeReportBaseDir :: Maybe TurtlePath } deriving (Show)+newtype ReportParams = ReportParams {maybeReportBaseDir :: Maybe TurtlePath} deriving Show  data Command = Import ImportParams | Report ReportParams deriving (Show) @@ -45,6 +47,7 @@  toRuntimeOptionsImport :: MainParams -> ImportParams -> IO RT.RuntimeOptions toRuntimeOptionsImport mainParams' subParams' = do+  startYear <- parseStartYear $ importStartYear subParams'   let maybeBD = maybeImportBaseDir subParams' :: Maybe TurtlePath   Control.Monad.when (importUseRunDir subParams') $ do     T.putStrLn "The enable-future-rundir option is now the default, no need to specify it. This option is currently being ignored and will be removed in future."@@ -52,6 +55,7 @@   hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams'   return RT.RuntimeOptions { RT.baseDir = bd                            , RT.importRunDir = runDir+                           , RT.importStartYear = startYear                            , RT.onlyNewFiles = onlyNewFiles subParams'                            , RT.hfVersion = versionInfo'                            , RT.hledgerInfo = hli@@ -67,6 +71,7 @@   hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams'   return RT.RuntimeOptions { RT.baseDir = bd                            , RT.importRunDir = [reldir|.|]+                           , RT.importStartYear = Nothing                            , RT.onlyNewFiles = False                            , RT.hfVersion = versionInfo'                            , RT.hledgerInfo = hli@@ -93,8 +98,9 @@ subcommandParserImport :: Parser ImportParams subcommandParserImport = ImportParams   <$> optional (Turtle.argPath "dir" "The directory to import. Use the base directory for a full import or a sub-directory for a partial import. Defaults to the current directory. This behaviour is changing: see --enable-future-rundir")-  <*> switch (long "enable-future-rundir" <> help "This switch is currently being ignored, since the behaviour it previously enabled is now the default. It will be removed in future.")+  <*> optional (strOption (long "start-year" <> metavar "YEAR" <> help "Import only from the specified year and onwards, ignoring previous years. By default all available years are imported. Valid values include a 4-digit year or 'current' for the current year"))   <*> switch (long "new-files-only" <> help "Don't regenerate transaction files if they are already present. This applies to hledger journal files as well as files produced by the preprocess and construct scripts.")+  <*> switch (long "enable-future-rundir" <> help "This switch is currently being ignored, since the behaviour it previously enabled is now the default. It will be removed in future.")  subcommandParserReport :: Parser ReportParams subcommandParserReport = ReportParams

@@ -0,0 +1,25 @@+{-# LANGUAGE PartialTypeSignatures #-}++module Parsing (+    parseStartYear+  ) where++import Hledger.Flow.DateTime+import System.Exit (die)+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"++parseInt :: String -> String -> IO Integer+parseInt s errPrefix = case safeParseInt s errPrefix of+  Right i -> return i+  Left err -> die err++safeParseInt :: String -> String -> Either String Integer+safeParseInt s errPrefix = case (readMaybe s :: Maybe Integer) of+  Nothing -> Left $ errPrefix ++ " " ++ s+  Just i  -> Right i

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a351ed4904c5177d5fa526e91057902c42ef97c4bc7814624f684725f3f17abd+-- hash: cb2578ca8c6701d18ddc78599992215ad8c3b4f13ee2deb248bd30112365d3e4  name:           hledger-flow-version:        0.14.1.0+version:        0.14.2.0 synopsis:       An hledger workflow focusing on automated statement import and classification. description:    Please see the README on GitHub at <https://github.com/apauley/hledger-flow#readme> category:       Finance, Console@@ -31,9 +31,12 @@   exposed-modules:       Hledger.Flow.BaseDir       Hledger.Flow.Common-      Hledger.Flow.CSVImport+      Hledger.Flow.DateTime       Hledger.Flow.DocHelpers+      Hledger.Flow.Import.CSVImport+      Hledger.Flow.Import.ImportHelpers       Hledger.Flow.Import.Types+      Hledger.Flow.Logging       Hledger.Flow.PathHelpers       Hledger.Flow.Reports       Hledger.Flow.RuntimeOptions@@ -59,6 +62,7 @@ executable hledger-flow   main-is: Main.hs   other-modules:+      Parsing       Paths_hledger_flow   hs-source-dirs:       app

@@ -1,210 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Hledger.Flow.CSVImport-    ( importCSVs-    ) where--import qualified Turtle hiding (stdout, stderr, proc, procStrictWithErr)-import Turtle ((%), (</>), (<.>))-import Prelude hiding (putStrLn, take)-import qualified Data.Text as T-import qualified Data.List.NonEmpty as NonEmpty-import qualified Hledger.Flow.Types as FlowTypes-import Hledger.Flow.Import.Types-import Hledger.Flow.BaseDir (relativeToBase, effectiveRunDir)-import Hledger.Flow.PathHelpers (TurtlePath, pathToTurtle)-import Hledger.Flow.DocHelpers (docURL)-import Hledger.Flow.Common-import Hledger.Flow.RuntimeOptions-import Control.Concurrent.STM-import Control.Monad--type FileWasGenerated = Bool--importCSVs :: RuntimeOptions -> IO ()-importCSVs opts = Turtle.sh (-  do-    ch <- Turtle.liftIO newTChanIO-    logHandle <- Turtle.fork $ consoleChannelLoop ch-    Turtle.liftIO $ if (showOptions opts) then channelOutLn ch (Turtle.repr opts) else return ()-    Turtle.liftIO $ logVerbose opts ch "Starting import"-    (journals, diff) <- Turtle.time $ Turtle.liftIO $ importCSVs' opts ch-    let generatedJournals = filter snd journals-    Turtle.liftIO $ channelOutLn ch $ Turtle.format ("Imported "%Turtle.d%"/"%Turtle.d%" journals in "%Turtle.s) (length generatedJournals) (length journals) $ Turtle.repr diff-    Turtle.liftIO $ terminateChannelLoop ch-    Turtle.wait logHandle-  )--pathSeparators :: [Char]-pathSeparators = ['/', '\\', ':']--inputFilePattern :: Turtle.Pattern T.Text-inputFilePattern = Turtle.contains (Turtle.once (Turtle.oneOf pathSeparators) <> Turtle.asciiCI "1-in" <> Turtle.once (Turtle.oneOf pathSeparators) <> Turtle.plus Turtle.digit <> Turtle.once (Turtle.oneOf pathSeparators))--importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [(TurtlePath, FileWasGenerated)]-importCSVs' opts ch = do-  let effectiveDir = effectiveRunDir (baseDir opts) (importRunDir opts)-  channelOutLn ch $ Turtle.format ("Collecting input files from "%Turtle.fp) $ pathToTurtle effectiveDir-  (inputFiles, diff) <- Turtle.time $ Turtle.single . shellToList . onlyFiles $ Turtle.find inputFilePattern (pathToTurtle effectiveDir)-  let fileCount = length inputFiles-  if (fileCount == 0) then-    do-      let msg = Turtle.format ("I couldn't find any input files underneath "%Turtle.fp-                        %"\n\nhledger-flow expects to find its input files in specifically\nnamed directories.\n\n"%-                        "Have a look at the documentation for a detailed explanation:\n"%Turtle.s) (pathToTurtle effectiveDir) (docURL "input-files")-      errExit 1 ch msg []-    else-    do-      channelOutLn ch $ Turtle.format ("Found "%Turtle.d%" input files in "%Turtle.s%". Proceeding with import...") fileCount (Turtle.repr diff)-      let actions = map (extractAndImport opts ch) inputFiles :: [IO (TurtlePath, FileWasGenerated)]-      importedJournals <- parAwareActions opts actions-      _ <- writeIncludesUpTo opts ch (pathToTurtle effectiveDir) $ fmap fst importedJournals-      _ <- writeToplevelAllYearsInclude opts-      return importedJournals--extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> IO (TurtlePath, FileWasGenerated)-extractAndImport opts ch inputFile = do-  case extractImportDirs inputFile of-    Right importDirs -> importCSV opts ch importDirs inputFile-    Left errorMessage -> do-      errExit 1 ch errorMessage (inputFile, False)--importCSV :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> IO (TurtlePath, FileWasGenerated)-importCSV opts ch importDirs srcFile = do-  let preprocessScript = accountDir importDirs </> "preprocess"-  let constructScript = accountDir importDirs </> "construct"-  let bankName = importDirLine bankDir importDirs-  let accountName = importDirLine accountDir importDirs-  let ownerName = importDirLine ownerDir importDirs-  (csvFile, preprocessHappened) <- preprocessIfNeeded opts ch preprocessScript bankName accountName ownerName srcFile-  let journalOut = changePathAndExtension "3-journal" "journal" csvFile-  shouldImport <- if onlyNewFiles opts && not preprocessHappened-    then not <$> verboseTestFile opts ch journalOut-    else return True--  importFun <- if shouldImport-    then constructOrImport opts ch constructScript bankName accountName ownerName-    else do-      _ <- logNewFileSkip opts ch "import" journalOut-      return $ \_p1 _p2 -> return journalOut-  Turtle.mktree $ Turtle.directory journalOut-  out <- importFun csvFile journalOut-  return (out, shouldImport)--constructOrImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> IO (TurtlePath -> TurtlePath -> IO TurtlePath)-constructOrImport opts ch constructScript bankName accountName ownerName = do-  constructScriptExists <- verboseTestFile opts ch constructScript-  if constructScriptExists-    then return $ customConstruct opts ch constructScript bankName accountName ownerName-    else return $ hledgerImport opts ch--preprocessIfNeeded :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> IO (TurtlePath, Bool)-preprocessIfNeeded opts ch script bank account owner src = do-  let csvOut = changePathAndExtension "2-preprocessed" "csv" src-  scriptExists <- verboseTestFile opts ch script-  shouldProceed <- if onlyNewFiles opts -    then do-      targetExists <- verboseTestFile opts ch csvOut-      return $ scriptExists && not targetExists-    else return scriptExists-  if shouldProceed-    then do-     out <- preprocess opts ch script bank account owner src csvOut-     return (out, True)-    else do-      _ <- logNewFileSkip opts ch "preprocess" csvOut-      return (src, False)--logNewFileSkip :: RuntimeOptions -> TChan FlowTypes.LogMessage -> T.Text -> TurtlePath -> IO ()-logNewFileSkip opts ch logIdentifier absTarget =-  Control.Monad.when (onlyNewFiles opts) $ do-   let relativeTarget = relativeToBase opts absTarget-   logVerbose opts ch-     $ Turtle.format-        ("Skipping " % Turtle.s-         % " - only creating new files and this output file already exists: '"-         % Turtle.fp-         % "'") logIdentifier relativeTarget--preprocess :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath-preprocess opts ch script bank account owner src csvOut = do-  Turtle.mktree $ Turtle.directory csvOut-  let args = [Turtle.format Turtle.fp src, Turtle.format Turtle.fp csvOut, Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner]-  let relScript = relativeToBase opts script-  let relSrc = relativeToBase opts src-  let cmdLabel = Turtle.format ("executing '"%Turtle.fp%"' on '"%Turtle.fp%"'") relScript relSrc-  _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (Turtle.format Turtle.fp script, args, Turtle.empty)-  return csvOut--hledgerImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> TurtlePath -> IO TurtlePath-hledgerImport opts ch csvSrc journalOut = do-  case extractImportDirs csvSrc of-    Right importDirs -> hledgerImport' opts ch importDirs csvSrc journalOut-    Left errorMessage -> do-      errExit 1 ch errorMessage csvSrc--hledgerImport' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> TurtlePath -> IO TurtlePath-hledgerImport' opts ch importDirs csvSrc journalOut = do-  let candidates = rulesFileCandidates csvSrc importDirs-  maybeRulesFile <- firstExistingFile candidates-  let relCSV = relativeToBase opts csvSrc-  case maybeRulesFile of-    Just rf -> do-      let relRules = relativeToBase opts rf-      let hledger = Turtle.format Turtle.fp $ FlowTypes.hlPath . hledgerInfo $ opts :: T.Text-      let args = ["print", "--rules-file", Turtle.format Turtle.fp rf, "--file", Turtle.format Turtle.fp csvSrc, "--output-file", Turtle.format Turtle.fp journalOut]-      let cmdLabel = Turtle.format ("importing '"%Turtle.fp%"' using rules file '"%Turtle.fp%"'") relCSV relRules-      _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (hledger, args, Turtle.empty)-      return journalOut-    Nothing ->-      do-        let relativeCandidates = map (relativeToBase opts) candidates-        let candidatesTxt = T.intercalate "\n" $ map (Turtle.format Turtle.fp) relativeCandidates-        let msg = Turtle.format ("I couldn't find an hledger rules file while trying to import\n"%Turtle.fp-                          %"\n\nI will happily use the first rules file I can find from any one of these "%Turtle.d%" files:\n"%Turtle.s-                          %"\n\nHere is a bit of documentation about rules files that you may find helpful:\n"%Turtle.s)-                  relCSV (length candidates) candidatesTxt (docURL "rules-files")-        errExit 1 ch msg csvSrc--rulesFileCandidates :: TurtlePath -> ImportDirs -> [TurtlePath]-rulesFileCandidates csvSrc importDirs = statementSpecificRulesFiles csvSrc importDirs ++ generalRulesFiles importDirs--importDirLines :: (ImportDirs -> TurtlePath) -> ImportDirs -> [Turtle.Line]-importDirLines dirFun importDirs = NonEmpty.toList $ Turtle.textToLines $ Turtle.format Turtle.fp $ Turtle.dirname $ dirFun importDirs--importDirLine :: (ImportDirs -> TurtlePath) -> ImportDirs -> Turtle.Line-importDirLine dirFun importDirs = foldl (<>) "" $ importDirLines dirFun importDirs--generalRulesFiles :: ImportDirs -> [TurtlePath]-generalRulesFiles importDirs = do-  let bank = importDirLines bankDir importDirs-  let account = importDirLines accountDir importDirs-  let accountRulesFile = accountDir importDirs </> buildFilename (bank ++ account) "rules"--  let bankRulesFile = importDir importDirs </> buildFilename bank "rules"-  [accountRulesFile, bankRulesFile]--statementSpecificRulesFiles :: TurtlePath -> ImportDirs -> [TurtlePath]-statementSpecificRulesFiles csvSrc importDirs = do-  let srcSuffix = snd $ T.breakOnEnd "_" (Turtle.format Turtle.fp (Turtle.basename csvSrc))--  if ((T.take 3 srcSuffix) == "rfo")-    then-    do-      let srcSpecificFilename = Turtle.fromText srcSuffix <.> "rules"-      map (</> srcSpecificFilename) [accountDir importDirs, bankDir importDirs, importDir importDirs]-    else []--customConstruct :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath-customConstruct opts ch constructScript bank account owner csvSrc journalOut = do-  let script = Turtle.format Turtle.fp constructScript :: T.Text-  let relScript = relativeToBase opts constructScript-  let constructArgs = [Turtle.format Turtle.fp csvSrc, "-", Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner]-  let constructCmdText = Turtle.format ("Running: "%Turtle.fp%" "%Turtle.s) relScript (showCmdArgs constructArgs)-  let stdLines = inprocWithErrFun (channelErrLn ch) (script, constructArgs, Turtle.empty)-  let hledger = Turtle.format Turtle.fp $ FlowTypes.hlPath . hledgerInfo $ opts :: T.Text-  let args = ["print", "--ignore-assertions", "--file", "-", "--output-file", Turtle.format Turtle.fp journalOut]-  let relSrc = relativeToBase opts csvSrc-  let cmdLabel = Turtle.format ("executing '"%Turtle.fp%"' on '"%Turtle.fp%"'") relScript relSrc-  _ <- timeAndExitOnErr' opts ch cmdLabel [constructCmdText] channelOut channelErr (parAwareProc opts) (hledger, args, stdLines)-  return journalOut

@@ -2,7 +2,7 @@  module Hledger.Flow.Common where -import qualified Turtle as Turtle+import qualified Turtle import Turtle ((%), (</>), (<.>))  import Prelude hiding (putStrLn)@@ -17,7 +17,6 @@  import qualified Control.Foldl as Fold import qualified Data.Map.Strict as Map-import Data.Time.LocalTime  import Data.Function (on) import qualified Data.List as List (nub, null, sort, sortBy, groupBy)@@ -26,6 +25,7 @@ import Hledger.Flow.Types import qualified Hledger.Flow.Import.Types as IT +import Hledger.Flow.Logging import Hledger.Flow.PathHelpers (TurtlePath) import Hledger.Flow.BaseDir (turtleBaseDir, relativeToBase, relativeToBase') import Hledger.Flow.DocHelpers (docURL)@@ -86,22 +86,7 @@ showCmdArgs args = T.intercalate " " (map escapeArg args)  escapeArg :: T.Text -> T.Text-escapeArg a = if (T.count " " a > 0) then "'" <> a <> "'" else a--dummyLogger :: TChan LogMessage -> T.Text -> IO ()-dummyLogger _ _ = return ()--channelOut :: TChan LogMessage -> T.Text -> IO ()-channelOut ch txt = atomically $ writeTChan ch $ StdOut txt--channelOutLn :: TChan LogMessage -> T.Text -> IO ()-channelOutLn ch txt = channelOut ch (txt <> "\n")--channelErr :: TChan LogMessage -> T.Text -> IO ()-channelErr ch txt = atomically $ writeTChan ch $ StdErr txt--channelErrLn :: TChan LogMessage -> T.Text -> IO ()-channelErrLn ch txt = channelErr ch (txt <> "\n")+escapeArg a = if T.count " " a > 0 then "'" <> a <> "'" else a  errExit :: Int -> TChan LogMessage -> T.Text -> a -> IO a errExit exitStatus ch = errExit' exitStatus (channelErrLn ch)@@ -113,34 +98,6 @@   _ <- Turtle.exit $ Turtle.ExitFailure exitStatus   return dummyReturnValue -timestampPrefix :: T.Text -> IO T.Text-timestampPrefix txt = do-  t <- getZonedTime-  return $ Turtle.format (Turtle.s%"\thledger-flow "%Turtle.s) (Turtle.repr t) txt--logToChannel :: TChan LogMessage -> T.Text -> IO ()-logToChannel ch msg = do-  ts <- timestampPrefix msg-  channelErrLn ch ts--consoleChannelLoop :: TChan LogMessage -> IO ()-consoleChannelLoop ch = do-  logMsg <- atomically $ readTChan ch-  case logMsg of-    StdOut msg -> do-      T.hPutStr H.stdout msg-      consoleChannelLoop ch-    StdErr msg -> do-      T.hPutStr H.stderr msg-      consoleChannelLoop ch-    Terminate  -> return ()--terminateChannelLoop :: TChan LogMessage -> IO ()-terminateChannelLoop ch = atomically $ writeTChan ch Terminate--logVerbose :: HasVerbosity o => o -> TChan LogMessage -> T.Text -> IO ()-logVerbose opts ch msg = if (verbose opts) then logToChannel ch msg else return ()- descriptiveOutput :: T.Text -> T.Text -> T.Text descriptiveOutput outputLabel outTxt = do   if not (T.null outTxt)@@ -419,7 +376,7 @@  changeOutputPath :: TurtlePath -> TurtlePath -> TurtlePath changeOutputPath newOutputLocation srcFile = mconcat $ map changeSrcDir $ Turtle.splitDirectories srcFile-  where changeSrcDir file = if (file == "1-in/" || file == "2-preprocessed/") then newOutputLocation else file+  where changeSrcDir file = if file == "1-in/" || file == "2-preprocessed/" then newOutputLocation else file  importDirBreakdown ::  TurtlePath -> [TurtlePath] importDirBreakdown = importDirBreakdown' []@@ -427,7 +384,7 @@ importDirBreakdown' :: [TurtlePath] -> TurtlePath -> [TurtlePath] importDirBreakdown' acc path = do   let dir = Turtle.directory path-  if (Turtle.dirname dir == "import" || (Turtle.dirname dir == ""))+  if Turtle.dirname dir == "import" || (Turtle.dirname dir == "")     then dir:acc     else importDirBreakdown' (dir:acc) $ Turtle.parent dir 

@@ -0,0 +1,12 @@+module Hledger.Flow.DateTime where++import Data.Time.Clock+import Data.Time.Calendar++currentDate :: IO (Integer,Int,Int) -- :: (year,month,day)+currentDate = toGregorian . utctDay <$> getCurrentTime++currentYear :: IO Integer+currentYear = do+  (y, _, _) <- currentDate+  return y

@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Flow.Import.CSVImport+    ( importCSVs+    ) where++import qualified Turtle hiding (stdout, stderr, proc, procStrictWithErr)+import Turtle ((%), (</>), (<.>))+import Prelude hiding (putStrLn, take)+import qualified Data.Text as T+import qualified Data.List.NonEmpty as NonEmpty+import qualified Hledger.Flow.Types as FlowTypes+import Hledger.Flow.Import.Types+import Hledger.Flow.BaseDir (relativeToBase, effectiveRunDir)+import Hledger.Flow.Import.ImportHelpers+import Hledger.Flow.PathHelpers (TurtlePath, pathToTurtle)+import Hledger.Flow.DocHelpers (docURL)+import Hledger.Flow.Common+import Hledger.Flow.Logging+import Hledger.Flow.RuntimeOptions+import Control.Concurrent.STM+import Control.Monad+import Data.Maybe (fromMaybe, isNothing)++type FileWasGenerated = Bool++importCSVs :: RuntimeOptions -> IO ()+importCSVs opts = Turtle.sh (+  do+    ch <- Turtle.liftIO newTChanIO+    logHandle <- Turtle.fork $ consoleChannelLoop ch+    Turtle.liftIO $ when (showOptions opts) (channelOutLn ch (Turtle.repr opts))+    Turtle.liftIO $ logVerbose opts ch "Starting import"+    (journals, diff) <- Turtle.time $ Turtle.liftIO $ importCSVs' opts ch+    let generatedJournals = filter snd journals+    Turtle.liftIO $ channelOutLn ch $ Turtle.format ("Imported "%Turtle.d%"/"%Turtle.d%" journals in "%Turtle.s) (length generatedJournals) (length journals) $ Turtle.repr diff+    Turtle.liftIO $ terminateChannelLoop ch+    Turtle.wait logHandle+  )++importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [(TurtlePath, FileWasGenerated)]+importCSVs' opts ch = do+  let effectiveDir = effectiveRunDir (baseDir opts) (importRunDir opts)+  let startYearMsg = maybe " " (Turtle.format (" (for the year " % Turtle.d % " and onwards) ")) (importStartYear opts)+  channelOutLn ch $ Turtle.format ("Collecting input files"%Turtle.s%"from "%Turtle.fp) startYearMsg (pathToTurtle effectiveDir)+  (inputFiles, diff) <- Turtle.time $ findInputFiles (fromMaybe 0 $ importStartYear opts) effectiveDir++  let fileCount = length inputFiles+  if fileCount == 0 && isNothing (importStartYear opts) then+    do+      let msg = Turtle.format ("I couldn't find any input files underneath "%Turtle.fp+                        %"\n\nhledger-flow expects to find its input files in specifically\nnamed directories.\n\n"%+                        "Have a look at the documentation for a detailed explanation:\n"%Turtle.s) (pathToTurtle effectiveDir) (docURL "input-files")+      errExit 1 ch msg []+    else+    do+      channelOutLn ch $ Turtle.format ("Found "%Turtle.d%" input files"%Turtle.s%"in "%Turtle.s%". Proceeding with import...") fileCount startYearMsg (Turtle.repr diff)+      let actions = map (extractAndImport opts ch . pathToTurtle) inputFiles :: [IO (TurtlePath, FileWasGenerated)]+      importedJournals <- parAwareActions opts actions+      (journalsOnDisk, journalFindTime) <- Turtle.time $ findJournalFiles effectiveDir+      (_, writeIncludeTime1) <- Turtle.time $ writeIncludesUpTo opts ch (pathToTurtle effectiveDir) $ fmap pathToTurtle journalsOnDisk+      (_, writeIncludeTime2) <- Turtle.time $ writeToplevelAllYearsInclude opts+      let includeGenTime = journalFindTime + writeIncludeTime1 + writeIncludeTime2+      channelOutLn ch $ Turtle.format ("Wrote include files for "%Turtle.d%" journals in "%Turtle.s) (length journalsOnDisk) (Turtle.repr includeGenTime)+      return importedJournals++extractAndImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> IO (TurtlePath, FileWasGenerated)+extractAndImport opts ch inputFile = do+  case extractImportDirs inputFile of+    Right importDirs -> importCSV opts ch importDirs inputFile+    Left errorMessage -> do+      errExit 1 ch errorMessage (inputFile, False)++importCSV :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> IO (TurtlePath, FileWasGenerated)+importCSV opts ch importDirs srcFile = do+  let preprocessScript = accountDir importDirs </> "preprocess"+  let constructScript = accountDir importDirs </> "construct"+  let bankName = importDirLine bankDir importDirs+  let accountName = importDirLine accountDir importDirs+  let ownerName = importDirLine ownerDir importDirs+  (csvFile, preprocessHappened) <- preprocessIfNeeded opts ch preprocessScript bankName accountName ownerName srcFile+  let journalOut = changePathAndExtension "3-journal" "journal" csvFile+  shouldImport <- if onlyNewFiles opts && not preprocessHappened+    then not <$> verboseTestFile opts ch journalOut+    else return True++  importFun <- if shouldImport+    then constructOrImport opts ch constructScript bankName accountName ownerName+    else do+      _ <- logNewFileSkip opts ch "import" journalOut+      return $ \_p1 _p2 -> return journalOut+  Turtle.mktree $ Turtle.directory journalOut+  out <- importFun csvFile journalOut+  return (out, shouldImport)++constructOrImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> IO (TurtlePath -> TurtlePath -> IO TurtlePath)+constructOrImport opts ch constructScript bankName accountName ownerName = do+  constructScriptExists <- verboseTestFile opts ch constructScript+  if constructScriptExists+    then return $ customConstruct opts ch constructScript bankName accountName ownerName+    else return $ hledgerImport opts ch++preprocessIfNeeded :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> IO (TurtlePath, Bool)+preprocessIfNeeded opts ch script bank account owner src = do+  let csvOut = changePathAndExtension "2-preprocessed" "csv" src+  scriptExists <- verboseTestFile opts ch script+  shouldProceed <- if onlyNewFiles opts +    then do+      targetExists <- verboseTestFile opts ch csvOut+      return $ scriptExists && not targetExists+    else return scriptExists+  if shouldProceed+    then do+     out <- preprocess opts ch script bank account owner src csvOut+     return (out, True)+    else do+      _ <- logNewFileSkip opts ch "preprocess" csvOut+      return (src, False)++logNewFileSkip :: RuntimeOptions -> TChan FlowTypes.LogMessage -> T.Text -> TurtlePath -> IO ()+logNewFileSkip opts ch logIdentifier absTarget =+  Control.Monad.when (onlyNewFiles opts) $ do+   let relativeTarget = relativeToBase opts absTarget+   logVerbose opts ch+     $ Turtle.format+        ("Skipping " % Turtle.s+         % " - only creating new files and this output file already exists: '"+         % Turtle.fp+         % "'") logIdentifier relativeTarget++preprocess :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath+preprocess opts ch script bank account owner src csvOut = do+  Turtle.mktree $ Turtle.directory csvOut+  let args = [Turtle.format Turtle.fp src, Turtle.format Turtle.fp csvOut, Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner]+  let relScript = relativeToBase opts script+  let relSrc = relativeToBase opts src+  let cmdLabel = Turtle.format ("executing '"%Turtle.fp%"' on '"%Turtle.fp%"'") relScript relSrc+  _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (Turtle.format Turtle.fp script, args, Turtle.empty)+  return csvOut++hledgerImport :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> TurtlePath -> IO TurtlePath+hledgerImport opts ch csvSrc journalOut = do+  case extractImportDirs csvSrc of+    Right importDirs -> hledgerImport' opts ch importDirs csvSrc journalOut+    Left errorMessage -> do+      errExit 1 ch errorMessage csvSrc++hledgerImport' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> TurtlePath -> TurtlePath -> IO TurtlePath+hledgerImport' opts ch importDirs csvSrc journalOut = do+  let candidates = rulesFileCandidates csvSrc importDirs+  maybeRulesFile <- firstExistingFile candidates+  let relCSV = relativeToBase opts csvSrc+  case maybeRulesFile of+    Just rf -> do+      let relRules = relativeToBase opts rf+      let hledger = Turtle.format Turtle.fp $ FlowTypes.hlPath . hledgerInfo $ opts :: T.Text+      let args = ["print", "--rules-file", Turtle.format Turtle.fp rf, "--file", Turtle.format Turtle.fp csvSrc, "--output-file", Turtle.format Turtle.fp journalOut]+      let cmdLabel = Turtle.format ("importing '"%Turtle.fp%"' using rules file '"%Turtle.fp%"'") relCSV relRules+      _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (hledger, args, Turtle.empty)+      return journalOut+    Nothing ->+      do+        let relativeCandidates = map (relativeToBase opts) candidates+        let candidatesTxt = T.intercalate "\n" $ map (Turtle.format Turtle.fp) relativeCandidates+        let msg = Turtle.format ("I couldn't find an hledger rules file while trying to import\n"%Turtle.fp+                          %"\n\nI will happily use the first rules file I can find from any one of these "%Turtle.d%" files:\n"%Turtle.s+                          %"\n\nHere is a bit of documentation about rules files that you may find helpful:\n"%Turtle.s)+                  relCSV (length candidates) candidatesTxt (docURL "rules-files")+        errExit 1 ch msg csvSrc++rulesFileCandidates :: TurtlePath -> ImportDirs -> [TurtlePath]+rulesFileCandidates csvSrc importDirs = statementSpecificRulesFiles csvSrc importDirs ++ generalRulesFiles importDirs++importDirLines :: (ImportDirs -> TurtlePath) -> ImportDirs -> [Turtle.Line]+importDirLines dirFun importDirs = NonEmpty.toList $ Turtle.textToLines $ Turtle.format Turtle.fp $ Turtle.dirname $ dirFun importDirs++importDirLine :: (ImportDirs -> TurtlePath) -> ImportDirs -> Turtle.Line+importDirLine dirFun importDirs = foldl (<>) "" $ importDirLines dirFun importDirs++generalRulesFiles :: ImportDirs -> [TurtlePath]+generalRulesFiles importDirs = do+  let bank = importDirLines bankDir importDirs+  let account = importDirLines accountDir importDirs+  let accountRulesFile = accountDir importDirs </> buildFilename (bank ++ account) "rules"++  let bankRulesFile = importDir importDirs </> buildFilename bank "rules"+  [accountRulesFile, bankRulesFile]++statementSpecificRulesFiles :: TurtlePath -> ImportDirs -> [TurtlePath]+statementSpecificRulesFiles csvSrc importDirs = do+  let srcSuffix = snd $ T.breakOnEnd "_" (Turtle.format Turtle.fp (Turtle.basename csvSrc))++  if ((T.take 3 srcSuffix) == "rfo")+    then+    do+      let srcSpecificFilename = Turtle.fromText srcSuffix <.> "rules"+      map (</> srcSpecificFilename) [accountDir importDirs, bankDir importDirs, importDir importDirs]+    else []++customConstruct :: RuntimeOptions -> TChan FlowTypes.LogMessage -> TurtlePath -> Turtle.Line -> Turtle.Line -> Turtle.Line -> TurtlePath -> TurtlePath -> IO TurtlePath+customConstruct opts ch constructScript bank account owner csvSrc journalOut = do+  let script = Turtle.format Turtle.fp constructScript :: T.Text+  let relScript = relativeToBase opts constructScript+  let constructArgs = [Turtle.format Turtle.fp csvSrc, "-", Turtle.lineToText bank, Turtle.lineToText account, Turtle.lineToText owner]+  let constructCmdText = Turtle.format ("Running: "%Turtle.fp%" "%Turtle.s) relScript (showCmdArgs constructArgs)+  let stdLines = inprocWithErrFun (channelErrLn ch) (script, constructArgs, Turtle.empty)+  let hledger = Turtle.format Turtle.fp $ FlowTypes.hlPath . hledgerInfo $ opts :: T.Text+  let args = ["print", "--ignore-assertions", "--file", "-", "--output-file", Turtle.format Turtle.fp journalOut]+  let relSrc = relativeToBase opts csvSrc+  let cmdLabel = Turtle.format ("executing '"%Turtle.fp%"' on '"%Turtle.fp%"'") relScript relSrc+  _ <- timeAndExitOnErr' opts ch cmdLabel [constructCmdText] channelOut channelErr (parAwareProc opts) (hledger, args, stdLines)+  return journalOut

@@ -0,0 +1,32 @@+{-# LANGUAGE QuasiQuotes #-}++module Hledger.Flow.Import.ImportHelpers (findInputFiles, findJournalFiles) where++import Path+import Data.Char (isDigit)++import Hledger.Flow.PathHelpers (AbsDir, AbsFile, RelDir, findFilesIn)++findInputFiles :: Integer -> AbsDir -> IO [AbsFile]+findInputFiles startYear = do+  let excludeDirs = [[Path.reldir|2-preprocessed|], [Path.reldir|3-journal|]] ++ commonExcludeDirs+  findFilesIn (includeYearFilesForParent [Path.reldir|1-in|] startYear) excludeDirs++findJournalFiles :: AbsDir -> IO [AbsFile]+findJournalFiles = do+  let excludeDirs = [[Path.reldir|1-in|], [Path.reldir|2-preprocessed|]] ++ commonExcludeDirs+  findFilesIn (includeYearFilesForParent [Path.reldir|3-journal|] 0) excludeDirs++-- | Include only files directly underneath parentDir/yearDir, e.g. 1-in/2020/* or 3-journal/2020/*+includeYearFilesForParent :: RelDir -> Integer -> AbsDir -> Bool+includeYearFilesForParent parentDir startYear d = (dirname . parent) d == parentDir+  && length shortDirName == 4+  && all isDigit shortDirName+  && read shortDirName >= startYear+    where shortDirName = dirToStringNoSlash d++dirToStringNoSlash :: AbsDir -> String+dirToStringNoSlash = init . Path.toFilePath . Path.dirname++commonExcludeDirs :: [RelDir]+commonExcludeDirs = [[Path.reldir|_manual_|], [Path.reldir|__pycache__|]]

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Flow.Logging where++import Hledger.Flow.Types+import Control.Concurrent.STM+import Control.Monad (when)++import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.LocalTime (getZonedTime)++import qualified GHC.IO.Handle.FD as H+import qualified Turtle+import Turtle ((%))++dummyLogger :: TChan LogMessage -> T.Text -> IO ()+dummyLogger _ _ = return ()++channelOut :: TChan LogMessage -> T.Text -> IO ()+channelOut ch txt = atomically $ writeTChan ch $ StdOut txt++channelOutLn :: TChan LogMessage -> T.Text -> IO ()+channelOutLn ch txt = channelOut ch (txt <> "\n")++channelErr :: TChan LogMessage -> T.Text -> IO ()+channelErr ch txt = atomically $ writeTChan ch $ StdErr txt++channelErrLn :: TChan LogMessage -> T.Text -> IO ()+channelErrLn ch txt = channelErr ch (txt <> "\n")++logToChannel :: TChan LogMessage -> T.Text -> IO ()+logToChannel ch msg = do+  ts <- timestampPrefix msg+  channelErrLn ch ts++timestampPrefix :: T.Text -> IO T.Text+timestampPrefix txt = do+  t <- getZonedTime+  return $ Turtle.format (Turtle.s%"\thledger-flow "%Turtle.s) (Turtle.repr t) txt++consoleChannelLoop :: TChan LogMessage -> IO ()+consoleChannelLoop ch = do+  logMsg <- atomically $ readTChan ch+  case logMsg of+    StdOut msg -> do+      T.hPutStr H.stdout msg+      consoleChannelLoop ch+    StdErr msg -> do+      T.hPutStr H.stderr msg+      consoleChannelLoop ch+    Terminate  -> return ()++terminateChannelLoop :: TChan LogMessage -> IO ()+terminateChannelLoop ch = atomically $ writeTChan ch Terminate++logVerbose :: HasVerbosity o => o -> TChan LogMessage -> T.Text -> IO ()+logVerbose opts ch msg = when (verbose opts) $ logToChannel ch msg

@@ -6,6 +6,8 @@ import Control.Monad.IO.Class (MonadIO)  import qualified Data.Text as T++import Path ((</>)) import qualified Path import qualified Path.IO as Path import qualified Turtle@@ -61,3 +63,20 @@  pathSize' :: Path.Path b Path.Dir -> Int -> Int pathSize' p count = if Path.parent p == p then count else pathSize' (Path.parent p) (count+1)++-- | Do a recursive search starting from the given directory.+-- Return all files contained in each directory which matches the given predicate.+findFilesIn :: MonadIO m+  => (AbsDir -> Bool) -- ^ Do we want the files in this directory?+  -> [RelDir]         -- ^ Exclude these directory names+  -> AbsDir           -- ^ Top of the search tree+  -> m [AbsFile]      -- ^ Absolute paths to all files in the directories which match the predicate+findFilesIn includePred excludeDirs = Path.walkDirAccum (Just excludeHandler) accumulator+  where excludeHandler currentDir _ _ = return $ Path.WalkExclude (map (currentDir </>) excludeDirs)+        accumulator currentDir _ files =+          if includePred currentDir+              then return $ excludeHiddenFiles files+              else return []++excludeHiddenFiles :: [AbsFile] -> [AbsFile]+excludeHiddenFiles = filter (\ f -> head (Path.toFilePath (Path.filename f)) /= '.')

@@ -19,6 +19,7 @@ import qualified Data.Text as T import qualified Hledger.Flow.Types as FlowTypes import Hledger.Flow.PathHelpers (TurtlePath)+import Hledger.Flow.Logging import qualified Data.List as List  data ReportParams = ReportParams { ledgerFile :: TurtlePath

@@ -7,6 +7,7 @@  data RuntimeOptions = RuntimeOptions { baseDir :: BaseDir                                      , importRunDir :: RunDir+                                     , importStartYear :: Maybe Integer                                      , onlyNewFiles :: Bool                                      , hfVersion :: T.Text                                      , hledgerInfo :: HledgerInfo@@ -18,13 +19,13 @@   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  instance HasRunDir RuntimeOptions where-  importRunDir (RuntimeOptions _ rd _ _ _ _ _ _ _) = rd+  importRunDir (RuntimeOptions _ rd _ _ _ _ _ _ _ _) = rd

@@ -1,10 +1,9 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -module Hledger.Flow.Types-where+module Hledger.Flow.Types where -import qualified Turtle as Turtle (ExitCode, NominalDiffTime, Shell, Line)+import qualified Turtle (ExitCode, NominalDiffTime, Shell, Line) import qualified Data.Text as T import Data.Version 

@@ -64,6 +64,7 @@ defaultOpts bd = RuntimeOptions {     baseDir = bd   , importRunDir = [reldir|./|]+  , importStartYear = Nothing   , onlyNewFiles = False   , hfVersion = versionInfo'   , hledgerInfo = defaultHlInfo