Integration.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Common.Integration (tests) where

import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryTakeMVar)
import Control.Concurrent.STM (atomically, modifyTVar', newTChanIO, newTVarIO, readTVarIO, tryReadTChan)
import Control.Exception (bracket, bracket_, finally)
import Control.Monad (forM_, unless)
import qualified Data.List as List (intercalate, isInfixOf, isPrefixOf)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock (UTCTime(..), addUTCTime, secondsToDiffTime)
import Data.Time.Calendar (fromGregorian)
import Hledger.Flow.Common
import qualified Hledger.Flow.RuntimeOptions as RT
import Hledger.Flow.Types (HledgerConf (..), LogMessage (StdErr))
import qualified Path
import qualified Path.IO as PathIO
import System.Directory (doesFileExist)
import qualified System.Directory as Directory
import System.Environment (lookupEnv, setEnv, unsetEnv)
import System.IO.Error (tryIOError)
import qualified System.Info as Sys
import System.Timeout (timeout)
import Test.HUnit
import TestHelpers (defaultOpts, withTestDir, touchAll)
import System.FilePath ((</>), searchPathSeparator)

-- HUnit runs these cases sequentially; restore process-wide PATH even on failure.
withSearchPath :: [FilePath] -> IO a -> IO a
withSearchPath dirs action = bracket (lookupEnv "PATH") restore $ \_ -> do
  setEnv "PATH" (List.intercalate [searchPathSeparator] dirs)
  action
  where
    restore = maybe (unsetEnv "PATH") (setEnv "PATH")

testHledgerLookup :: Test
testHledgerLookup = TestLabel "hledger executable lookup" $ TestCase $ withTestDir $ \base -> do
  let root = Path.toFilePath base
      name = "hledger" ++ Directory.exeExtension
      first = root </> "first bin" </> name
      second = root </> "second" </> name
      check dirs expected = withSearchPath dirs $ do
        result <- tryIOError (hledgerPathFromOption Nothing)
        case result of
          Left err -> assertFailure ("lookup in " ++ show dirs ++ ": " ++ show err)
          Right actual -> do
            expectedPath <- Directory.canonicalizePath expected
            assertEqual ("lookup in " ++ show dirs) expectedPath (Path.toFilePath actual)
  forM_ (["first bin", "second", "work", "empty"] :: [FilePath]) $ \dir ->
    Directory.createDirectory (root </> dir)
  forM_ ([first, second] :: [FilePath]) $ \file -> do
    writeFile file ""
    perms <- Directory.getPermissions file
    Directory.setPermissions file (Directory.setOwnerExecutable True perms)
  Directory.withCurrentDirectory root $ do
    check ["first bin"] first
    check [root </> "first bin"] first
    check ["first bin", root </> "second"] first
    check ["second", "first bin"] second
    Directory.withCurrentDirectory (root </> "first bin") $ check ["."] first
    Directory.withCurrentDirectory (root </> "work") $ check [".." </> "first bin"] first
    withSearchPath ["second"] $ do
      actual <- hledgerPathFromOption (Just first)
      assertEqual "explicit path overrides PATH" first (Path.toFilePath actual)
    withSearchPath ["empty"] $ do
      result <- tryIOError (hledgerPathFromOption Nothing)
      case result of
        Left err -> assertBool "missing executable diagnostic"
          ("Unable to find hledger" `List.isInfixOf` show err)
        Right actual -> assertFailure ("unexpected executable: " ++ show actual)
    -- Windows symlinks require privileges; .exe lookup above runs on every OS.
    unless (Sys.os == "mingw32") $ do
      Directory.createFileLink ("first bin" </> name) (root </> name)
      check ["."] first

testFilterPaths :: Test
testFilterPaths = TestCase $ withTestDir $ \base -> do
  let onDisk = map (Path.toFilePath base </>) (["first.journal", "nested/second.journal"] :: [FilePath])
      missing = map (Path.toFilePath base </>) ["where", "is", "my", "mind"]
  touchAll onDisk
  filtered <- filterPaths doesFileExist (missing ++ onDisk)
  assertEqual "Keep existing include files in reverse candidate order" (reverse onDisk) filtered

testFirstExistingFile :: Test
testFirstExistingFile = TestCase $ withTestDir $ \base -> do
  let missing = base Path.</> [Path.relfile|missing.rules|]
      first = base Path.</> [Path.relfile|first.rules|]
      second = base Path.</> [Path.relfile|second.rules|]
  T.writeFile (Path.toFilePath first) ""
  T.writeFile (Path.toFilePath second) ""
  found <- firstExistingFile [missing, first, second]
  assertEqual "first existing file in candidate order" (Just first) found
  absent <- firstExistingFile [missing]
  assertEqual "no existing files" Nothing absent

testVerboseTestFile :: Test
testVerboseTestFile = TestCase $ withTestDir $ \base -> do
  let opts = (defaultOpts base) {RT.verbose = True}
      file = base Path.</> [Path.relfile|statement.csv|]
  ch <- newTChanIO
  let check expected message = do
        exists <- verboseTestFile opts ch file
        assertEqual "file existence" expected exists
        entry <- atomically (tryReadTChan ch)
        case entry of
          Just (StdErr txt) -> do
            let (timestamp, body) = T.breakOn "\t" txt
            assertBool "verbose log starts with a timestamp" (not (T.null timestamp))
            assertEqual "verbose log uses the relative path" ("\thledger-flow " <> message) body
          _ -> assertFailure "expected a verbose message on stderr"
  check False "Looked for but did not find 'statement.csv'\n"
  T.writeFile (Path.toFilePath file) ""
  check True "Found 'statement.csv'\n"
  _ <- verboseTestFile (defaultOpts base) ch file
  quietEntry <- atomically (tryReadTChan ch)
  case quietEntry of
    Nothing -> return ()
    Just msg -> assertFailure ("unexpected log with verbosity off: " ++ show msg)

testNeedsRegeneration :: Test
testNeedsRegeneration = TestCase $ withTestDir $ \base -> do
  let source = base Path.</> [Path.relfile|source.txt|]
      target = base Path.</> [Path.relfile|target.txt|]
      older = UTCTime (fromGregorian 2020 1 1) (secondsToDiffTime 0)
      newer = addUTCTime 1 older
      check message expected = needsRegeneration source target >>= assertEqual message expected

  T.writeFile (Path.toFilePath source) ""
  check "missing target" True

  T.writeFile (Path.toFilePath target) ""
  PathIO.setModificationTime target older
  PathIO.setModificationTime source newer
  check "newer source" True

  PathIO.setModificationTime source older
  PathIO.setModificationTime target newer
  check "newer target" False

  PathIO.setModificationTime target older
  check "equal timestamps" False
  PathIO.setModificationTime source (addUTCTime 0.75 older)
  check "source newer within the same second" True

  PathIO.removeFile source
  check "source timestamp no longer available" True

testBatchOrder :: Test
testBatchOrder = TestCase $ do
  firstStarted <- newEmptyMVar
  thirdStarted <- newEmptyMVar
  concurrency <- newTVarIO (0, 0 :: Int)
  let track = bracket_
        (atomically $ modifyTVar' concurrency $ \(active, peak) -> (active + 1, max peak (active + 1)))
        (atomically $ modifyTVar' concurrency $ \(active, peak) -> (active - 1, peak))
      first = putMVar firstStarted () >> takeMVar thirdStarted >> return (1 :: Int)
      second = takeMVar firstStarted >> return 2
      third = putMVar thirdStarted () >> return 3
  result <- timeout 10000000 (parBatchedActions 2 [0] (map track [first, second, third]))
  readTVarIO concurrency >>= assertEqual "two simultaneous workers, both joined" (0, 2)
  assertEqual "refill a free worker while preserving input order" (Just [0, 1, 2, 3]) result

testBatchFailure :: Test
testBatchFailure = TestLabel "batch failure cancels siblings and stops later batches" $
  TestList [TestCase (checkBatchFailure id), TestCase (checkBatchFailure reverse)]

checkBatchFailure :: ([IO ()] -> [IO ()]) -> Assertion
checkBatchFailure order = do
  started <- newEmptyMVar
  stopped <- newEmptyMVar
  never <- newEmptyMVar
  later <- newEmptyMVar
  let failing = takeMVar started >> ioError (userError "conversion failed")
      running = (putMVar started () >> takeMVar never) `finally` putMVar stopped ()
      nextBatch = putMVar later ()
  result <- timeout 10000000 (tryIOError (parBatchedActions 2 [] (order [failing, running] ++ [nextBatch])))
  case result of
    Just (Left err) -> assertBool "propagate the original failure" ("conversion failed" `List.isInfixOf` show err)
    _ -> assertFailure ("expected a prompt batch failure, got " ++ show result)
  tryTakeMVar stopped >>= assertEqual "cancel and join the running sibling" (Just ())
  tryTakeMVar later >>= assertEqual "never start the next batch" Nothing

-- Status must name the config file hledger loads by itself, in hledger's search order.
testFindHledgerConf :: Test
testFindHledgerConf = TestLabel "hledger config lookup" $ TestCase $ withTestDir $ \base -> do
  let root = Path.toFilePath base
      found expected = do
        actual <- findHledgerConf Nothing
        expectedPath <- Directory.canonicalizePath expected
        assertEqual ("found " ++ expected) (Just (FoundConf expectedPath)) actual
  forM_ (["near/work", "home/work", "xdg/hledger"] :: [FilePath]) $ \dir ->
    Directory.createDirectoryIfMissing True (root </> dir)
  withEnv "HOME" (root </> "home") $ withEnv "XDG_CONFIG_HOME" (root </> "xdg") $ do
    writeFile (root </> "near" </> "hledger.conf") ""
    writeFile (root </> "home" </> "hledger.conf") ""
    writeFile (root </> "home" </> ".hledger.conf") ""
    writeFile (root </> "xdg" </> "hledger" </> "hledger.conf") ""
    Directory.withCurrentDirectory (root </> "near" </> "work") $ do
      found (root </> "near" </> "hledger.conf")
      given <- findHledgerConf (Just "other.conf")
      assertEqual "--hledger-conf wins" (Just (GivenConf "other.conf")) given
    unless (Sys.os == "mingw32") $ do
      Directory.withCurrentDirectory (root </> "home" </> "work") $ do
        found (root </> "home" </> ".hledger.conf")
        Directory.removeFile (root </> "home" </> ".hledger.conf")
        found (root </> "xdg" </> "hledger" </> "hledger.conf")

-- HUnit runs these cases sequentially; restore the variable even on failure.
withEnv :: String -> String -> IO a -> IO a
withEnv name value action = bracket (lookupEnv name) (maybe (unsetEnv name) (setEnv name)) $ \_ ->
  setEnv name value >> action

-- Paths come out resolved (macOS /private/var, symlinked homes), so match both spellings of HOME.
testHomeDirs :: Test
testHomeDirs = TestLabel "home folder spellings" $ TestCase $ unless (Sys.os == "mingw32") $ withTestDir $ \base -> do
  let root = Path.toFilePath base
  Directory.createDirectory (root </> "real")
  Directory.createDirectoryLink (root </> "real") (root </> "link")
  real <- Directory.canonicalizePath (root </> "real")
  forM_ ([root </> "link", root </> "link/", real ++ "/"] :: [FilePath]) $ \home -> withEnv "HOME" home $ do
    homes <- homeDirs
    assertEqual ("resolved path with HOME=" ++ home) ("~" </> "fin") (tildePath homes (real </> "fin"))
    assertEqual ("HOME's spelling with HOME=" ++ home) ("~" </> "fin") (tildePath homes (home </> "fin"))

testWriteGeneratedText :: Test
testWriteGeneratedText = TestLabel "write generated text" $ TestCase $ withTestDir $ \base -> do
  let dir = Path.toFilePath base </> "out"
      journal = dir </> "2024-include.journal"
  writeGeneratedText journal "first\n"
  T.readFile journal >>= assertEqual "create missing directory and file" "first\n"
  unless (Sys.os == "mingw32") $ do
    perms <- Directory.getPermissions journal
    Directory.setPermissions journal (Directory.setOwnerExecutable True perms)
    let real = dir </> "real.journal"
        link = dir </> "link.journal"
    T.writeFile real "old\n"
    Directory.createFileLink "real.journal" link
    writeGeneratedText link "through link\n"
    T.readFile real >>= assertEqual "replace the file behind a symlink" "through link\n"
    Directory.pathIsSymbolicLink link >>= assertBool "keep the symlink"
  writeGeneratedText journal "second\n"
  T.readFile journal >>= assertEqual "replace existing contents" "second\n"
  unless (Sys.os == "mingw32") $
    Directory.getPermissions journal >>= assertBool "keep existing permissions" . Directory.executable
  entries <- Directory.listDirectory dir
  assertBool ("no staged files left: " ++ show entries) (not (any (List.isPrefixOf ".") entries))

tests :: Test
tests = TestList [testWriteGeneratedText, testHledgerLookup, testFindHledgerConf, testHomeDirs, testFilterPaths, testFirstExistingFile, testVerboseTestFile, testNeedsRegeneration, testBatchOrder, testBatchFailure]