Use the Path package from FP Complete for determining basedir and rundir

https://github.com/commercialhaskell/path

Author: apauley

app/Main.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Main where
 
+import Path
 import Turtle hiding (switch)
 import Prelude hiding (FilePath, putStrLn)
 
 import Options.Applicative
 
 import Hledger.Flow.Common
+import Hledger.Flow.BaseDir
 import qualified Hledger.Flow.RuntimeOptions as RT
 import Hledger.Flow.Reports
 import Hledger.Flow.CSVImport
@@ -36,7 +39,8 @@ main = do
 
 toRuntimeOptionsImport :: MainParams -> ImportParams -> IO RT.RuntimeOptions
 toRuntimeOptionsImport mainParams' subParams' = do
-  (bd, runDir) <- determineBaseDir $ maybeImportBaseDir subParams'
+  let maybeBD = maybeImportBaseDir subParams' :: Maybe FilePath
+  (bd, runDir) <- determineBaseDir maybeBD
   hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams'
   return RT.RuntimeOptions { RT.baseDir = bd
                            , RT.importRunDir = runDir
@@ -50,10 +54,11 @@ toRuntimeOptionsImport mainParams' subParams' = do
 
 toRuntimeOptionsReport :: MainParams -> ReportParams -> IO RT.RuntimeOptions
 toRuntimeOptionsReport mainParams' subParams' = do
-  (bd, _) <- determineBaseDir $ maybeReportBaseDir subParams'
+  let maybeBD = maybeReportBaseDir subParams' :: Maybe FilePath
+  (bd, _) <- determineBaseDir maybeBD
   hli <- hledgerInfoFromPath $ hledgerPathOpt mainParams'
   return RT.RuntimeOptions { RT.baseDir = bd
-                           , RT.importRunDir = "./"
+                           , RT.importRunDir = [reldir|.|]
                            , RT.useRunDir = False
                            , RT.hfVersion = versionInfo'
                            , RT.hledgerInfo = hli

package.yaml

@@ -1,5 +1,5 @@
 name:                hledger-flow
-version:             0.13.2.0
+version:             0.14.0.0
 synopsis:            An hledger workflow focusing on automated statement import and classification.
 category:            Finance, Console
 license:             GPL-3
@@ -31,6 +31,9 @@ library:
   - -Wall
   dependencies:
   - turtle
+  - path
+  - path-io
+  - exceptions
   - text
   - foldl
   - containers
@@ -52,6 +55,7 @@ executables:
 
     dependencies:
     - hledger-flow
+    - path
     - turtle
     - text
     - optparse-applicative
@@ -66,6 +70,8 @@ tests:
     - -with-rtsopts=-N
     dependencies:
     - hledger-flow
+    - path
+    - path-io
     - turtle
     - HUnit
     - containers

src/Hledger/Flow/BaseDir.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Hledger.Flow.BaseDir where
+
+import Path
+import Path.IO
+import Hledger.Flow.Types (HasBaseDir, HasRunDir, BaseDir, RunDir, baseDir, importRunDir)
+import Hledger.Flow.PathHelpers
+
+import Data.Maybe
+
+import Control.Monad.Catch (MonadThrow, throwM)
+import Control.Monad.IO.Class (MonadIO)
+
+
+import qualified Turtle as Turtle (stripPrefix)
+
+determineBaseDir :: Maybe TurtlePath -> IO (BaseDir, RunDir)
+determineBaseDir suppliedDir = do
+  pwd <- getCurrentDir
+  determineBaseDir' pwd suppliedDir
+
+determineBaseDir' :: AbsDir -> Maybe TurtlePath -> IO (BaseDir, RunDir)
+determineBaseDir' pwd (Just suppliedDir) = do
+  absDir <- turtleToAbsDir pwd suppliedDir
+  determineBaseDirFromStartDir absDir
+determineBaseDir' pwd Nothing = determineBaseDirFromStartDir pwd
+
+determineBaseDirFromStartDir ::  AbsDir -> IO (BaseDir, RunDir)
+determineBaseDirFromStartDir startDir = determineBaseDirFromStartDir' startDir startDir
+
+determineBaseDirFromStartDir' :: (MonadIO m, MonadThrow m) => AbsDir -> AbsDir -> m (BaseDir, RunDir)
+determineBaseDirFromStartDir' startDir possibleBaseDir = do
+  _ <- if (parent possibleBaseDir == possibleBaseDir) then throwM (MissingBaseDir startDir) else return ()
+  foundBaseDir <- doesDirExist $ possibleBaseDir </> [reldir|import|]
+  if foundBaseDir then
+    do
+      runDir <- makeRelative possibleBaseDir startDir
+      return (possibleBaseDir, runDir)
+    else determineBaseDirFromStartDir' startDir $ parent possibleBaseDir
+
+relativeToBase :: HasBaseDir o => o -> TurtlePath -> TurtlePath
+relativeToBase opts = relativeToBase' $ pathToTurtle (baseDir opts)
+
+relativeToBase' :: TurtlePath -> TurtlePath -> TurtlePath
+relativeToBase' bd p = if forceTrailingSlash bd == forceTrailingSlash p then "./" else
+  fromMaybe p $ Turtle.stripPrefix (forceTrailingSlash bd) p
+
+turtleBaseDir :: HasBaseDir o => o -> TurtlePath
+turtleBaseDir opts = pathToTurtle $ baseDir opts
+
+turtleRunDir :: HasRunDir o => o -> TurtlePath
+turtleRunDir opts = pathToTurtle $ importRunDir opts

src/Hledger/Flow/CSVImport.hs

@@ -10,6 +10,9 @@ 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 (turtleBaseDir, turtleRunDir, relativeToBase)
+import Hledger.Flow.PathHelpers (forceTrailingSlash)
+import Hledger.Flow.DocHelpers (docURL)
 import Hledger.Flow.Common
 import Hledger.Flow.RuntimeOptions
 import Control.Concurrent.STM
@@ -35,8 +38,8 @@ inputFilePattern = contains (once (oneOf pathSeparators) <> asciiCI "1-in" <> on
 
 importCSVs' :: RuntimeOptions -> TChan FlowTypes.LogMessage -> IO [FilePath]
 importCSVs' opts ch = do
-  let baseImportDir = forceTrailingSlash $ (baseDir opts) </> "import"
-  let runDir = forceTrailingSlash $ collapse $ (baseDir opts) </> (importRunDir opts)
+  let baseImportDir = forceTrailingSlash $ (turtleBaseDir opts) </> "import"
+  let runDir = forceTrailingSlash $ collapse $ (turtleBaseDir opts) </> (turtleRunDir opts)
   let effectiveDir = if useRunDir opts
         then if (forceTrailingSlash $ runDir </> "import") == baseImportDir then baseImportDir else runDir
         else baseImportDir

src/Hledger/Flow/Common.hs

@@ -20,8 +20,12 @@ import Data.Time.LocalTime
 import Data.Function (on)
 import qualified Data.List as List (nub, null, sort, sortBy, groupBy)
 import Data.Ord (comparing)
+
 import Hledger.Flow.Types
 import qualified Hledger.Flow.Import.Types as IT
+import Hledger.Flow.BaseDir (turtleBaseDir, relativeToBase, relativeToBase')
+import Hledger.Flow.DocHelpers (docURL)
+
 import Control.Concurrent.STM
 
 import qualified Data.List.NonEmpty as NE
@@ -207,13 +211,6 @@ verboseTestFile opts ch p = do
     else logVerbose opts ch $ format ("Did not find a "%fp%" file at '"%fp%"'") (basename rel) rel
   return fileExists
 
-relativeToBase :: HasBaseDir o => o -> FilePath -> FilePath
-relativeToBase opts = relativeToBase' (baseDir opts)
-
-relativeToBase' :: FilePath -> FilePath -> FilePath
-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)
               . List.sortBy (comparing fst)
@@ -257,9 +254,6 @@ allYearIncludeFiles m = (m, yearsIncludeMap $ Map.keys m)
 yearsIncludeMap :: [FilePath] -> InputFileBundle
 yearsIncludeMap = groupValuesBy allYearsPath
 
-docURL :: Line -> Text
-docURL = format ("https://github.com/apauley/hledger-flow#"%l)
-
 lsDirs :: FilePath -> Shell FilePath
 lsDirs = onlyDirs . ls
 
@@ -410,7 +404,7 @@ writeIncludesUpTo opts ch stopAt journalFiles = do
 
 writeToplevelAllYearsInclude :: (HasBaseDir o, HasVerbosity o) => o -> IO [FilePath]
 writeToplevelAllYearsInclude opts = do
-  let allTop = Map.singleton (baseDir opts </> allYearsFileName) ["import" </> allYearsFileName]
+  let allTop = Map.singleton (turtleBaseDir opts </> allYearsFileName) ["import" </> allYearsFileName]
   writeFiles' $ (addPreamble . toIncludeFiles' Map.empty Map.empty) allTop
 
 changeExtension :: Text -> FilePath -> FilePath
@@ -423,55 +417,6 @@ changeOutputPath :: FilePath -> FilePath -> FilePath
 changeOutputPath newOutputLocation srcFile = mconcat $ map changeSrcDir $ splitDirectories srcFile
   where changeSrcDir file = if (file == "1-in/" || file == "2-preprocessed/") then newOutputLocation else file
 
-errorMessageBaseDir :: FilePath -> Text
-errorMessageBaseDir startDir = format ("\nUnable to find an hledger-flow import directory at '"%fp
-                                       %"' (or in any of its parent directories).\n\n"
-                                       %"Have a look at the documentation for more information:\n"%s%"\n")
-                               startDir (docURL "getting-started")
-
-determineBaseDir :: Maybe FilePath -> IO (FilePath, FilePath)
-determineBaseDir (Just suppliedDir) = determineBaseDir' suppliedDir
-determineBaseDir Nothing = pwd >>= determineBaseDir'
-
-determineBaseDir' :: FilePath -> IO (FilePath, FilePath)
-determineBaseDir' startDir = do
-  currentDir <- pwd
-  let absoluteStartDir = if relative startDir then collapse (currentDir </> startDir) else startDir
-  ebd <- determineBaseDirFromAbsoluteStartDir absoluteStartDir
-  case ebd of
-    Right bd -> return bd
-    Left  t  -> die t
-
-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
-    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 determineBaseDirFromAbsoluteStartDir' startDir $ parent possibleBaseDir
-
-
-dirOrPwd :: Maybe FilePath -> IO FilePath
-dirOrPwd maybeBaseDir = fmap forceTrailingSlash (fromMaybe pwd $ fmap realpath maybeBaseDir)
-
-forceTrailingSlash :: FilePath -> FilePath
-forceTrailingSlash p = directory (p </> "temp")
-
 importDirBreakdown ::  FilePath -> [FilePath]
 importDirBreakdown = importDirBreakdown' []
 
@@ -493,7 +438,7 @@ extractImportDirs inputFile = do
                       "Have a look at the documentation for a detailed explanation:\n"%s) inputFile (docURL "input-files")
 
 listOwners :: HasBaseDir o => o -> Shell FilePath
-listOwners opts = fmap basename $ lsDirs $ (baseDir opts) </> "import"
+listOwners opts = fmap basename $ lsDirs $ (turtleBaseDir opts) </> "import"
 
 intPath :: Integer -> FilePath
 intPath = fromText . (format d)

src/Hledger/Flow/DocHelpers.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hledger.Flow.DocHelpers where
+
+import Data.Text
+import Turtle
+
+docURL :: Line -> Text
+docURL = format ("https://github.com/apauley/hledger-flow#"%l)

src/Hledger/Flow/PathHelpers.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hledger.Flow.PathHelpers where
+
+import Control.Monad.Catch (MonadThrow, Exception, throwM)
+import Control.Monad.IO.Class (MonadIO)
+
+import qualified Data.Text as T
+import qualified Path as Path
+import qualified Path.IO as Path
+import qualified Turtle as Turtle
+
+import Hledger.Flow.DocHelpers (docURL)
+
+type TurtlePath = Turtle.FilePath
+
+type AbsFile = Path.Path Path.Abs Path.File
+type RelFile = Path.Path Path.Rel Path.File
+type AbsDir = Path.Path Path.Abs Path.Dir
+type RelDir = Path.Path Path.Rel Path.Dir
+
+data PathException = MissingBaseDir AbsDir | InvalidTurtleDir TurtlePath
+  deriving (Eq)
+
+instance Show PathException where
+  show (MissingBaseDir d) = "Unable to find an import directory at " ++ show d ++
+    " (or in any of its parent directories).\n\n" ++
+    "Have a look at the documentation for more information:\n" ++
+    T.unpack (docURL "getting-started")
+  show (InvalidTurtleDir  d) = "Expected a directory but got this instead: " ++ Turtle.encodeString d
+
+instance Exception PathException
+
+fromTurtleAbsFile :: MonadThrow m => TurtlePath -> m AbsFile
+fromTurtleAbsFile turtlePath = Path.parseAbsFile $ Turtle.encodeString turtlePath
+
+fromTurtleRelFile :: MonadThrow m => TurtlePath -> m RelFile
+fromTurtleRelFile turtlePath = Path.parseRelFile $ Turtle.encodeString turtlePath
+
+fromTurtleAbsDir :: MonadThrow m => TurtlePath -> m AbsDir
+fromTurtleAbsDir turtlePath = Path.parseAbsDir $ Turtle.encodeString turtlePath
+
+fromTurtleRelDir :: MonadThrow m => TurtlePath -> m RelDir
+fromTurtleRelDir turtlePath = Path.parseRelDir $ Turtle.encodeString turtlePath
+
+turtleToAbsDir :: (MonadIO m, MonadThrow m) => AbsDir -> TurtlePath -> m AbsDir
+turtleToAbsDir baseDir p = do
+  isDir <- Turtle.testdir p
+  if isDir
+    then Path.resolveDir baseDir $ Turtle.encodeString p
+    else throwM $ InvalidTurtleDir p
+
+pathToTurtle :: Path.Path b t -> TurtlePath
+pathToTurtle = Turtle.decodeString . Path.toFilePath
+
+forceTrailingSlash :: TurtlePath -> TurtlePath
+forceTrailingSlash p = Turtle.directory (p Turtle.</> "temp")

src/Hledger/Flow/Reports.hs

@@ -6,8 +6,11 @@ module Hledger.Flow.Reports
 
 import Turtle hiding (stdout, stderr, proc)
 import Prelude hiding (FilePath, putStrLn, writeFile)
+
 import Hledger.Flow.RuntimeOptions
 import Hledger.Flow.Common
+import Hledger.Flow.BaseDir (turtleBaseDir, relativeToBase)
+
 import Control.Concurrent.STM
 import Data.Either
 import Data.Maybe
@@ -46,7 +49,7 @@ generateReports' opts ch = do
   channelOutLn ch wipMsg
   owners <- single $ shellToList $ listOwners opts
   ledgerEnvValue <- need "LEDGER_FILE" :: IO (Maybe Text)
-  let hledgerJournal = fromMaybe (baseDir opts </> allYearsFileName) $ fmap fromText ledgerEnvValue
+  let hledgerJournal = fromMaybe (turtleBaseDir 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 []
@@ -119,10 +122,10 @@ generateReport opts ch journal baseOutDir year fileName args successCheck = do
       return $ Left outputFile
 
 journalFile :: RuntimeOptions -> [FilePath] -> FilePath
-journalFile opts dirs = (foldl (</>) (baseDir opts) ("import":dirs)) </> allYearsFileName
+journalFile opts dirs = (foldl (</>) (turtleBaseDir opts) ("import":dirs)) </> allYearsFileName
 
 outputReportDir :: RuntimeOptions -> [FilePath] -> FilePath
-outputReportDir opts dirs = foldl (</>) (baseDir opts) ("reports":dirs)
+outputReportDir opts dirs = foldl (</>) (turtleBaseDir opts) ("reports":dirs)
 
 ownerParameters :: RuntimeOptions -> TChan FlowTypes.LogMessage -> [FilePath] -> IO [ReportParams]
 ownerParameters opts ch owners = do

src/Hledger/Flow/RuntimeOptions.hs

@@ -5,8 +5,8 @@ import Turtle
 import Prelude hiding (FilePath, putStrLn)
 import Hledger.Flow.Types
 
-data RuntimeOptions = RuntimeOptions { baseDir :: FilePath
-                                     , importRunDir :: FilePath
+data RuntimeOptions = RuntimeOptions { baseDir :: BaseDir
+                                     , importRunDir :: RunDir
                                      , useRunDir :: Bool
                                      , hfVersion :: Text
                                      , hledgerInfo :: HledgerInfo
@@ -25,3 +25,6 @@ instance HasSequential RuntimeOptions where
 
 instance HasBaseDir RuntimeOptions where
   baseDir (RuntimeOptions bd _ _ _ _ _ _ _ _) = bd
+
+instance HasRunDir RuntimeOptions where
+  importRunDir (RuntimeOptions _ rd _ _ _ _ _ _ _) = rd