path: root/app/History.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module History (getIssues, listIssues) where

import Control.Exception (Exception, catch, handle, throw)
import Data.Aeson (eitherDecode)
import Data.Binary (Binary, decodeFileOrFail, encodeFile)
import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Function ((&))
import Data.List (foldl', intercalate)
import Data.Maybe (catMaybes, mapMaybe)
import Data.String (fromString)
import Data.Text (Text, append, isPrefixOf, lines, pack, unpack)
import Data.Text.Encoding (decodeUtf8)
import GHC.Generics (Generic)
import Issue (Issue (..), fromMatch, id)
import Issue.Filter (Filter, applyFilter)
import Parallel (parMapM)
import Process (quote, sh, sh_)
import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath (takeExtension, (</>))
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Typed (setWorkingDir)
import Text.Printf (printf)
import TreeGrepper.Match qualified as G
import TreeGrepper.Result qualified as G
import Prelude hiding (id, lines)
import Prelude qualified as Prelude

listIssues :: [Filter] -> [FilePath] -> IO [Issue]
listIssues filters paths = do
  commitHashes <- fmap reverse getCommitHashes
  case commitHashes of
    [] ->
      pure []
    hashFirst : hashesRest -> do
      -- TODO Reduce cached data size
      --
      -- Right now we are caching complete `Issue` instances, which
      -- contain the full issue title and description.  For a fast
      -- lookup it may already be enough to only store the issue's
      --
      -- * filename
      -- * start position
      -- * end position
      --
      -- With this information we can use git to quickly look up the
      -- complete issue text and parse it.
      --
      -- @topic caching
      issuesInitial <- cached (append hashFirst (pack ".all")) (\_ -> getIssuesCommitAll hashFirst)
      commitInfos <- mapM (\hash -> cached (append hash (pack ".changed")) (\_ -> getCommitInfo hash)) hashesRest
      commitInfoWorkingTree <- getCommitInfoWorkingTree paths
      let eventses = getEvents hashFirst issuesInitial (commitInfos ++ [commitInfoWorkingTree])
      let issues = mapMaybe issueFromIssueEvents eventses
          issuesFiltered = filter (applyFilter filters) issues
          issuesWithinPaths =
            case paths of
              [] ->
                issuesFiltered
              _ ->
                filter withinPaths issuesFiltered
      pure issuesWithinPaths
      where
        withinPaths issue =
          any (\path -> isPrefixOf (pack path) (pack issue.file)) paths

getCommitHashes :: IO [Text]
getCommitHashes =
  fmap (lines . decodeUtf8 . L8.toStrict) $ sh "git log --format=%H"

data IssueEvent
  = IssueCreated
      { hash :: Maybe Text,
        issue :: Issue
      }
  | IssueChanged
      { hash :: Maybe Text,
        issue :: Issue
      }
  | IssueDeleted
      { hash :: Maybe Text
      }
  deriving (Show)

issueFromIssueEvent :: IssueEvent -> Maybe Issue
issueFromIssueEvent issueEvent =
  case issueEvent of
    IssueCreated {issue} ->
      Just issue
    IssueChanged {issue} ->
      Just issue
    IssueDeleted _ ->
      Nothing

data CommitInfo = CommitInfo
  -- TODO Extract CommitInfo so we can change hash' -> hash
  --
  -- @topic refactoring
  { hash' :: Maybe Text,
    filesChanged :: [FilePath],
    issues :: [Issue]
  }
  deriving (Show, Binary, Generic)

getCommitInfo :: Text -> IO CommitInfo
getCommitInfo hash = do
  (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash
  pure $
    CommitInfo
      { hash' = Just hash,
        filesChanged = filesChanged,
        issues = issuesCommitChanged
      }

getCommitInfoWorkingTree :: [FilePath] -> IO CommitInfo
getCommitInfoWorkingTree paths = do
  (issuesWorkingTreeChanged, filesChanged) <- getIssuesAndFilesWorkingTreeChanged paths
  pure $
    CommitInfo
      { hash' = Nothing,
        filesChanged = filesChanged,
        issues = issuesWorkingTreeChanged
      }

getEvents :: Text -> [Issue] -> [CommitInfo] -> [[IssueEvent]]
getEvents hashInitial issuesInitial commitInfos =
  let issueEventsesInitial =
        map
          ( \issueInitial ->
              [ IssueCreated
                  { hash = Just hashInitial,
                    issue = issueInitial
                  }
              ]
          )
          issuesInitial
      addIssueEventsFromCommitInfo issueEventses commitInfo =
        let issuesCreated =
              map
                ( \issue ->
                    [ IssueCreated
                        { hash = commitInfo.hash',
                          issue = issue
                        }
                    ]
                )
                $ filter isNewIssue commitInfo.issues
            isNewIssue issue =
              all
                (\issueOther -> id issueOther /= id issue)
                (mapMaybe issueFromIssueEvents $ issueEventses)
            addIssueChangedOrDeleted issueEventses' =
              map
                ( \issueEvents ->
                    case issueFromIssueEvent $ head issueEvents of
                      Nothing ->
                        issueEvents
                      Just issue ->
                        case filter isSameIssue commitInfo.issues of
                          [] ->
                            if any isSameFile commitInfo.filesChanged
                              then
                                IssueDeleted
                                  { hash = commitInfo.hash'
                                  }
                                  : issueEvents
                              else issueEvents
                          issueCommit : _ ->
                            IssueChanged
                              { hash = commitInfo.hash',
                                issue = issueCommit
                              }
                              : issueEvents
                        where
                          isSameIssue issueCommit =
                            id issueCommit == id issue
                          isSameFile fileChanged =
                            fileChanged == issue.file
                )
                issueEventses'
         in issuesCreated ++ addIssueChangedOrDeleted issueEventses
   in foldl'
        ( addIssueEventsFromCommitInfo
        )
        issueEventsesInitial
        commitInfos

issueFromIssueEvents :: [IssueEvent] -> Maybe Issue
issueFromIssueEvents issueEvents =
  case issueEvents of
    IssueCreated {issue} : [] ->
      Just issue
    IssueChanged {issue} : _ -> do
      issueFirst <- issueFromIssueEvent $ head $ reverse issueEvents
      pure $ issue {provenance = issueFirst.provenance}
    IssueDeleted _ : _ ->
      Nothing
    _ ->
      Nothing

-- | Gets issues in all files which have been changed in your current
-- [working
-- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree)
getIssuesAndFilesWorkingTreeChanged :: [FilePath] -> IO ([Issue], [FilePath])
getIssuesAndFilesWorkingTreeChanged paths = do
  cwd <- getCurrentDirectory
  files <- gitLsFilesModifiedIn cwd paths
  issues <- concat <$> catch (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult
  pure (issues, files)

-- | Given the hash of a commit, get all issues in all files at the
-- [tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddeftreeatree)
-- of this commit.
getIssuesCommitAll :: Text -> IO [Issue]
getIssuesCommitAll hash = do
  withSystemTempDirectory "history" $ \tmp -> do
    cwd <- do
      let cwd = tmp </> unpack hash
      sh_ $ fromString $ printf "git worktree add --detach %s %s" (quote cwd) (quote $ unpack hash)
      pure cwd
    files <- gitLsFilesAll cwd
    concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)

-- | Given the hash of a commit, get all issues in the files which have
-- been changed by this commit, as well as all changed files.
getIssuesAndFilesCommitChanged :: Text -> IO ([Issue], [FilePath])
getIssuesAndFilesCommitChanged hash = do
  withSystemTempDirectory "history" $ \tmp -> do
    cwd <- do
      let cwd = tmp </> unpack hash
      sh_ $ fromString $ printf "git worktree add --detach %s %s" (quote cwd) (quote $ unpack hash)
      pure cwd
    files <- gitShowChanged cwd
    issues <- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
    pure (issues, files)

gitLsFilesAll :: FilePath -> IO [FilePath]
gitLsFilesAll cwd =
  Prelude.lines . L8.unpack
    <$> sh ("git ls-files --cached --exclude-standard --other" & setWorkingDir cwd)

gitShowChanged :: FilePath -> IO [FilePath]
gitShowChanged cwd =
  Prelude.lines . L8.unpack
    <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd)

gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath]
gitLsFilesModifiedIn cwd paths =
  Prelude.lines . L8.unpack
    <$> sh
      ( fromString
          ( (printf "git ls-files --modified%s")
              ( case paths of
                  [] -> ""
                  _ -> " -- " ++ intercalate " " (map quote paths)
              )
          )
          & setWorkingDir cwd
      )

-- | Get all issues in the given directory and files.  Runs
-- parallelized.
getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]]
getIssuesPar cwd files =
  parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files

data UnknownFileExtension = UnknownFileExtension
  { extension :: String
  }
  deriving (Show)

instance Exception UnknownFileExtension

forgetGetIssuesExceptions :: UnknownFileExtension -> IO [a]
forgetGetIssuesExceptions _ = pure []

data InvalidTreeGrepperResult = InvalidTreeGrepperResult
  { error :: String
  }
  deriving (Show)

instance Exception InvalidTreeGrepperResult

dieOfInvalidTreeGrepperResult :: InvalidTreeGrepperResult -> IO a
dieOfInvalidTreeGrepperResult (InvalidTreeGrepperResult e) =
  die e

-- | Get all issues in the given directory and file.
getIssues :: FilePath -> FilePath -> IO [Issue]
getIssues cwd filename = do
  let extension = takeExtension filename
      treeGrepperLanguage =
        -- TODO Add support for all tree-grepper supported files
        --
        -- tree-grepper supported files can be listed through `tree-grepper
        -- --languages`.
        case extension of
          ".elm" -> "elm"
          ".hs" -> "haskell"
          ".nix" -> "nix"
          ".sh" -> "sh"
          _ -> throw (UnknownFileExtension extension)
      treeGrepperQuery =
        case extension of
          ".elm" -> "([(line_comment) (block_comment)])"
          ".hs" -> "(comment)"
          ".nix" -> "(comment)"
          ".sh" -> "(comment)"
          _ -> throw (UnknownFileExtension extension)
      decode raw =
        case eitherDecode raw of
          Left e -> throw (InvalidTreeGrepperResult e)
          Right treeGrepperResult -> treeGrepperResult

  matches <-
    concatMap (\result -> map ((,) result) result.matches)
      . map fixTreeGrepper
      . decode
      <$> sh
        ( fromString
            ( printf
                "tree-grepper --query %s %s --format json %s"
                (quote treeGrepperLanguage)
                (quote treeGrepperQuery)
                (quote filename)
            )
            & setWorkingDir cwd
        )

  catMaybes <$> mapM (uncurry (fromMatch cwd)) matches

fixTreeGrepper :: G.Result -> G.Result
fixTreeGrepper treeGrepperResult =
  treeGrepperResult {G.matches = G.merge treeGrepperResult.matches}

cached :: Binary a => Text -> (Text -> IO a) -> IO a
cached hash func = do
  cwd <- getCurrentDirectory
  createDirectoryIfMissing True (cwd ++ "/.anissue")
  let file = (cwd ++ "/.anissue/" ++ unpack hash)
  fileExists <- doesFileExist file
  if fileExists
    then do
      result <- decodeFileOrFail file
      case result of
        Left _ -> do
          blob <- func hash
          encodeFile file blob
          pure blob
        Right blob ->
          pure blob
    else do
      blob <- func hash
      encodeFile file blob
      pure blob

die :: String -> IO a
die s = do
  printf "error: %s\n" s
  exitWith (ExitFailure 1)