module Unison.Codebase.Editor.HandleInput.HistoryComment (handleHistoryComment) where

import Control.Monad.Reader
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Time.Clock.POSIX qualified as Time
import Text.RawString.QQ (r)
import U.Codebase.Config qualified as Config
import U.Codebase.HashTags
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Auth.CredentialManager qualified as CredMan
import Unison.Auth.PersonalKey qualified as PK
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Input (BranchId2)
import Unison.Codebase.Editor.Output (Output (..))
import Unison.Codebase.Path qualified as Path
import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..))
import Unison.Core.Project (ProjectAndBranch (..))
import Unison.Hash qualified as Hash
import Unison.Hashing.V2
  ( hashHistoryComment,
    hashHistoryCommentRevision,
  )
import Unison.HistoryComment (HistoryComment (..), HistoryCommentRevision (..))
import Unison.Prelude
import UnliftIO qualified
import UnliftIO.Directory (findExecutable)
import UnliftIO.Environment qualified as Env
import UnliftIO.Process qualified as Proc

handleHistoryComment :: Maybe BranchId2 -> Maybe Text -> Cli ()
handleHistoryComment :: Maybe BranchId2 -> Maybe Text -> Cli ()
handleHistoryComment Maybe BranchId2
mayThingToAnnotate Maybe Text
mayMessage = do
  Cli.Env {credentialManager} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  personalKey <- liftIO (CredMan.getOrCreatePersonalKey credentialManager)
  let authorThumbprint = PersonalPrivateKey -> KeyThumbprint
PK.personalKeyThumbprint PersonalPrivateKey
personalKey
  mayAuthorName <-
    Cli.runTransaction do
      authorName <- Q.getAuthorName
      pure (authorName)
  authorName <- case mayAuthorName of
    Maybe AuthorName
Nothing -> Output -> Cli AuthorName
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli AuthorName) -> Output -> Cli AuthorName
forall a b. (a -> b) -> a -> b
$ Output
AuthorNameRequired
    Just AuthorName
authorName -> AuthorName -> Cli AuthorName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthorName
authorName
  causalHash <- case mayThingToAnnotate of
    Maybe BranchId2
Nothing -> do
      Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash (Branch IO -> CausalHash) -> Cli (Branch IO) -> Cli CausalHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli (Branch IO)
Cli.getCurrentProjectRoot
    Just (Left ShortCausalHash
sch) -> do
      ((forall void. Output -> Transaction void)
 -> Transaction CausalHash)
-> Cli CausalHash
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> (forall void. Output -> Transaction void)
-> ShortCausalHash -> Transaction CausalHash
Cli.resolveShortCausalHashToCausalHash Output -> Transaction void
forall void. Output -> Transaction void
rollback ShortCausalHash
sch
    Just (Right BranchRelativePath
brp) -> case BranchRelativePath
brp of
      BranchPathInCurrentProject ProjectBranchName
projectBranchName Absolute
path
        | Absolute
path Absolute -> Absolute -> Bool
forall a. Eq a => a -> a -> Bool
== Absolute
Path.Root -> do
            pab <- ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.resolveProjectBranch (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Maybe ProjectName
forall a. Maybe a
Nothing (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
projectBranchName))
            Cli.runTransaction $ ProjectUtils.getProjectBranchCausalHash pab.branch
        | Bool
otherwise -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
      QualifiedBranchPath ProjectName
projectName ProjectBranchName
projectBranchName Absolute
path
        | Absolute
path Absolute -> Absolute -> Bool
forall a. Eq a => a -> a -> Bool
== Absolute
Path.Root -> do
            pab <- ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.resolveProjectBranch (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
projectName) (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
projectBranchName))
            Cli.runTransaction $ ProjectUtils.getProjectBranchCausalHash pab.branch
        | Bool
otherwise -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
      UnqualifiedPath {} -> Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash) -> Output -> Cli CausalHash
forall a b. (a -> b) -> a -> b
$ Text -> Output
InvalidCommentTarget Text
"commenting on paths is currently unsupported."
  (causalHashId, mayHistoryComment) <- Cli.runTransaction $ do
    causalHashId <- Q.expectCausalHashIdByCausalHash causalHash
    mayExistingCommentInfo <- Q.getLatestCausalComment causalHashId
    pure (causalHashId, mayExistingCommentInfo)
  maySubjectContent <- case mayMessage of
    Just Text
msg -> do
      let (Text
subject, Text
content) = Text -> (Text, Text)
cleanComment Text
msg
      Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> Cli (Maybe (Text, Text)))
-> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
subject, Text
content)
    Maybe Text
Nothing -> do
      let populatedMsg :: Text
populatedMsg = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
commentInstructions (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
            HistoryCommentRevision {subject, content} <- Maybe
  (LatestHistoryComment
     KeyThumbprintId
     CausalHash
     HistoryCommentRevisionId
     HistoryCommentHash)
mayHistoryComment
            pure $ Text.unlines [subject, "", content, commentInstructions]
      mayNewMessage <- IO (Maybe (Text, Text)) -> Cli (Maybe (Text, Text))
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Text -> IO (Maybe (Text, Text))
forall (m :: * -> *).
MonadUnliftIO m =>
Maybe Text -> m (Maybe (Text, Text))
editMessage (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
populatedMsg))
      case mayNewMessage of
        Maybe (Text, Text)
Nothing -> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
        Just (Text
subject, Text
content) -> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> Cli (Maybe (Text, Text)))
-> Maybe (Text, Text) -> Cli (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
subject, Text
content)
  case maySubjectContent of
    Just (Text
subject, Text
content) -> do
      createdAt <- IO UTCTime -> Cli UTCTime
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Cli UTCTime) -> IO UTCTime -> Cli UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
Time.getCurrentTime
      let historyComment =
            HistoryComment UTCTime KeyThumbprint CausalHash ()
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
forall any.
HistoryComment UTCTime KeyThumbprint CausalHash any
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
hashHistoryComment (HistoryComment UTCTime KeyThumbprint CausalHash ()
 -> HistoryComment
      UTCTime KeyThumbprint CausalHash HistoryCommentHash)
-> HistoryComment UTCTime KeyThumbprint CausalHash ()
-> HistoryComment
     UTCTime KeyThumbprint CausalHash HistoryCommentHash
forall a b. (a -> b) -> a -> b
$
              HistoryComment
                { author :: Text
author =
                    AuthorName -> Text
Config.unAuthorName AuthorName
authorName,
                  commentId :: ()
commentId = (),
                  causal :: CausalHash
causal = CausalHash
causalHash,
                  UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt,
                  KeyThumbprint
authorThumbprint :: KeyThumbprint
authorThumbprint :: KeyThumbprint
authorThumbprint
                }
      let historyCommentRevision =
            HistoryCommentRevision () UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
forall any.
HistoryCommentRevision any UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
hashHistoryCommentRevision (HistoryCommentRevision () UTCTime HistoryCommentHash
 -> HistoryCommentRevision
      HistoryCommentRevisionHash UTCTime HistoryCommentHash)
-> HistoryCommentRevision () UTCTime HistoryCommentHash
-> HistoryCommentRevision
     HistoryCommentRevisionHash UTCTime HistoryCommentHash
forall a b. (a -> b) -> a -> b
$
              HistoryCommentRevision
                { revisionId :: ()
revisionId = (),
                  Text
subject :: Text
subject :: Text
subject,
                  Text
content :: Text
content :: Text
content,
                  UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt,
                  -- Hard coded for now, we can change this later if we want to support hiding comments
                  isHidden :: Bool
isHidden = Bool
False,
                  authorSignature :: ByteString
authorSignature = ByteString
"",
                  comment :: HistoryCommentHash
comment = HistoryComment UTCTime KeyThumbprint CausalHash HistoryCommentHash
historyComment.commentId
                }
      let historyComment' = HistoryComment UTCTime KeyThumbprint CausalHash HistoryCommentHash
historyComment {causal = causalHashId}
      let historyCommentRevisionHashBytes =
            HistoryCommentRevision
  HistoryCommentRevisionHash UTCTime HistoryCommentHash
historyCommentRevision.revisionId
              HistoryCommentRevisionHash
-> (HistoryCommentRevisionHash -> Hash) -> Hash
forall a b. a -> (a -> b) -> b
& HistoryCommentRevisionHash -> Hash
unHistoryCommentRevisionHash
              Hash -> (Hash -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Hash -> ByteString
Hash.toByteString
      PK.PersonalKeySignature authorSignature <-
        PK.signWithPersonalKey personalKey historyCommentRevisionHashBytes >>= \case
          Left Error
err -> Output -> Cli PersonalKeySignature
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli PersonalKeySignature)
-> Output -> Cli PersonalKeySignature
forall a b. (a -> b) -> a -> b
$ Text -> Output
CommentFailed (String -> Text
Text.pack (Error -> String
forall a. Show a => a -> String
show Error
err))
          Right PersonalKeySignature
sig -> PersonalKeySignature -> Cli PersonalKeySignature
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PersonalKeySignature
sig
      Cli.runTransaction $ Q.commentOnCausal $ historyCommentRevision {comment = historyComment', authorSignature = authorSignature}
      Cli.respond $ CommentedSuccessfully
    Maybe (Text, Text)
Nothing -> Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ Output
CommentAborted
  where
    commentInstructions :: Text
commentInstructions =
      Text
[r|
-- Enter your comment, then save and quit your editor to continue.
-- Lines that start with '--' will be ignored.|]

unisonEditorEnvVar :: String
unisonEditorEnvVar :: String
unisonEditorEnvVar = String
"UNISON_EDITOR"

editorEnvVar :: String
editorEnvVar :: String
editorEnvVar = String
"EDITOR"

getEditorProgram :: (MonadIO m) => m (Maybe FilePath)
getEditorProgram :: forall (m :: * -> *). MonadIO m => m (Maybe String)
getEditorProgram = MaybeT m String -> m (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m String -> m (Maybe String))
-> MaybeT m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
  String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
unisonEditorEnvVar
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
editorEnvVar
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT m String
forall {m :: * -> *}. MonadIO m => String -> MaybeT m String
fromEnvVar String
"VISUAL"
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"nano")
    MaybeT m String -> MaybeT m String -> MaybeT m String
forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
findExecutable String
"vi")
  where
    fromEnvVar :: String -> MaybeT m String
fromEnvVar String
var = do
      progName <- m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe String) -> MaybeT m String)
-> m (Maybe String) -> MaybeT m String
forall a b. (a -> b) -> a -> b
$ String -> m (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
Env.lookupEnv String
var
      guard (not (null progName))
      MaybeT $ findExecutable progName

-- | Trigger the user's preferred editing workflow to edit a message, using the provided message to pre-populate the editor.
-- Returns Nothing if the editor was closed with a non-zero exit code, or the message is empty.
editMessage :: (MonadUnliftIO m) => Maybe Text -> m (Maybe (Text, Text))
editMessage :: forall (m :: * -> *).
MonadUnliftIO m =>
Maybe Text -> m (Maybe (Text, Text))
editMessage Maybe Text
initialMessage = MaybeT m (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  editorProg <- m (Maybe String) -> MaybeT m String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe String)
forall (m :: * -> *). MonadIO m => m (Maybe String)
getEditorProgram
  MaybeT $ UnliftIO.withSystemTempFile "ucm-history-comment" $ \String
tempFilePath Handle
tempHandle -> MaybeT m (Text, Text) -> m (Maybe (Text, Text))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    -- Write the initial message to the temp file, if any
    IO () -> MaybeT m ()
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT m ()) -> IO () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
initialMessage ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
msg -> Handle -> Text -> IO ()
Text.hPutStrLn Handle
tempHandle Text
msg
    Handle -> MaybeT m ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
UnliftIO.hClose Handle
tempHandle
    -- Launch the editor on the temp file
    IO (Either SomeException ()) -> MaybeT m (Either SomeException ())
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (String -> [String] -> IO ()
forall (m :: * -> *). MonadIO m => String -> [String] -> m ()
Proc.callProcess String
editorProg [String
tempFilePath])) MaybeT m (Either SomeException ())
-> (Either SomeException () -> MaybeT m ()) -> MaybeT m ()
forall a b. MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left SomeException
_ -> MaybeT m ()
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty
      Right () -> () -> MaybeT m ()
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    result <- IO Text -> MaybeT m Text
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
readUtf8 String
tempFilePath)
    let (subject, contents) = cleanComment result
    guard $ not (Text.null subject)
    pure (subject, contents)

cleanComment :: Text -> (Text, Text)
cleanComment :: Text -> (Text, Text)
cleanComment Text
txt =
  Text
txt
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
Text.lines
    [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
Text.isPrefixOf Text
"--")
    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
Text.unlines
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
Text.strip
    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
Text.lines
    [Text] -> ([Text] -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& \case
      [] -> (Text
"", Text
"")
      (Text
s : [Text]
rest) -> (Text -> Text
Text.strip Text
s, Text -> Text
Text.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text]
rest)