From a2397fb03758ed3d495ff6343a0ca6eecfabdb3c Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 25 Nov 2025 09:45:19 -0800 Subject: [PATCH 01/13] Working on github branches --- app/Main.hs | 2 + app/Sauron/Actions.hs | 8 + app/Sauron/Actions/Util.hs | 2 +- app/Sauron/Event.hs | 4 + app/Sauron/Event/Helpers.hs | 3 + app/Sauron/Event/Open.hs | 1 + app/Sauron/Expanding.hs | 4 + app/Sauron/Fetch.hs | 174 +++++++++++++++++- app/Sauron/Fix.hs | 4 + app/Sauron/GraphQL.hs | 293 ++++++++++++++++++++++++++++++ app/Sauron/Setup/Common.hs | 26 ++- app/Sauron/Types.hs | 37 ++++ app/Sauron/UI.hs | 8 + app/Sauron/UI/Branch.hs | 52 +++++- app/Sauron/UI/Modals/ZoomModal.hs | 8 + app/Sauron/UI/Pagination.hs | 52 +++++- app/Sauron/UI/TopBox.hs | 3 + package.yaml | 1 + sauron.cabal | 3 + 19 files changed, 676 insertions(+), 9 deletions(-) create mode 100644 app/Sauron/GraphQL.hs diff --git a/app/Main.hs b/app/Main.hs index 8de875d..c39cd1c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -135,6 +135,8 @@ main = do , _appColorMode = V.FullColor , _appLogs = mempty + + , _appBranchData = mempty } diff --git a/app/Sauron/Actions.hs b/app/Sauron/Actions.hs index 3514565..cb93a66 100644 --- a/app/Sauron/Actions.hs +++ b/app/Sauron/Actions.hs @@ -49,6 +49,14 @@ refresh bc item@(PaginatedWorkflowsNode _) (findRepoParent -> Just (RepoNode (En liftIO $ void $ async $ liftIO $ runReaderT (fetchWorkflows owner name item) bc refresh bc item@(PaginatedBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = liftIO $ void $ async $ liftIO $ runReaderT (fetchBranches owner name item) bc +refresh bc item@(OverallBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = + liftIO $ void $ async $ liftIO $ runReaderT (fetchOverallBranches owner name item) bc +refresh bc item@(PaginatedYourBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = + liftIO $ void $ async $ liftIO $ runReaderT (fetchYourBranches owner name item) bc +refresh bc item@(PaginatedActiveBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = + liftIO $ void $ async $ liftIO $ runReaderT (fetchActiveBranches owner name item) bc +refresh bc item@(PaginatedStaleBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = + liftIO $ void $ async $ liftIO $ runReaderT (fetchStaleBranches owner name item) bc refresh bc item@(PaginatedNotificationsNode _) _parents = liftIO $ void $ async $ liftIO $ runReaderT (fetchNotifications item) bc refresh bc item@(PaginatedReposNode (EntityData {})) _parents = diff --git a/app/Sauron/Actions/Util.hs b/app/Sauron/Actions/Util.hs index 1cac431..30110da 100644 --- a/app/Sauron/Actions/Util.hs +++ b/app/Sauron/Actions/Util.hs @@ -97,7 +97,7 @@ logResult eventChan request result = do Left err -> "Failed: " <> url <> " - " <> show err Right response -> let sizeInfo = case getResponseSize response of - Nothing -> " " <> show (responseHeaders response) + Nothing -> "" -- " " <> show (responseHeaders response) Just size -> " (" <> show size <> " bytes)" in (url <> sizeInfo) let logEntry = LogEntry now level msg diff --git a/app/Sauron/Event.hs b/app/Sauron/Event.hs index b18097f..fe321c8 100644 --- a/app/Sauron/Event.hs +++ b/app/Sauron/Event.hs @@ -45,6 +45,10 @@ appEvent _s (AppEvent (LogEntryAdded logEntry)) = do -- Add log entry to the logs sequence modify (appLogs %~ (Seq.|> logEntry)) +appEvent _s (AppEvent (BranchDataUpdated branchData)) = do + -- Update the branch data map + modify (appBranchData .~ branchData) + -- Handle modal events appEvent s@(_appModal -> Just modalState) e = case e of diff --git a/app/Sauron/Event/Helpers.hs b/app/Sauron/Event/Helpers.hs index 9d9b7ed..b71edb5 100644 --- a/app/Sauron/Event/Helpers.hs +++ b/app/Sauron/Event/Helpers.hs @@ -67,6 +67,9 @@ getPaginationInfo (SomeNode (PaginatedPullsNode (EntityData {..}))) = Just _page getPaginationInfo (SomeNode (PaginatedWorkflowsNode (EntityData {..}))) = Just _pageInfo getPaginationInfo (SomeNode (PaginatedReposNode (EntityData {..}))) = Just _pageInfo getPaginationInfo (SomeNode (PaginatedBranchesNode (EntityData {..}))) = Just _pageInfo +getPaginationInfo (SomeNode (PaginatedYourBranchesNode (EntityData {..}))) = Just _pageInfo +getPaginationInfo (SomeNode (PaginatedActiveBranchesNode (EntityData {..}))) = Just _pageInfo +getPaginationInfo (SomeNode (PaginatedStaleBranchesNode (EntityData {..}))) = Just _pageInfo getPaginationInfo (SomeNode (PaginatedNotificationsNode (EntityData {..}))) = Just _pageInfo getPaginationInfo _ = Nothing diff --git a/app/Sauron/Event/Open.hs b/app/Sauron/Event/Open.hs index b74bf74..d2c3652 100644 --- a/app/Sauron/Event/Open.hs +++ b/app/Sauron/Event/Open.hs @@ -33,6 +33,7 @@ getNodeUrl (PaginatedIssuesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just getNodeUrl (PaginatedPullsNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/pulls") getNodeUrl (PaginatedWorkflowsNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/actions") getNodeUrl (PaginatedBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches") +getNodeUrl (OverallBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches") getNodeUrl (PaginatedNotificationsNode _) _ = Just "https://github.com/notifications" getNodeUrl (SingleIssueNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) getNodeUrl (SinglePullNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) diff --git a/app/Sauron/Expanding.hs b/app/Sauron/Expanding.hs index c390e2e..671f76b 100644 --- a/app/Sauron/Expanding.hs +++ b/app/Sauron/Expanding.hs @@ -25,6 +25,10 @@ getExpandedList = V.fromList . concatMap expandNodes . V.toList PaginatedWorkflowsNode (EntityData {..}) -> expandTyped _children PaginatedReposNode (EntityData {..}) -> expandTyped _children PaginatedBranchesNode (EntityData {..}) -> expandTyped _children + OverallBranchesNode (EntityData {..}) -> expandWrapped _children + PaginatedYourBranchesNode (EntityData {..}) -> expandTyped _children + PaginatedActiveBranchesNode (EntityData {..}) -> expandTyped _children + PaginatedStaleBranchesNode (EntityData {..}) -> expandTyped _children PaginatedNotificationsNode (EntityData {..}) -> expandTyped _children SingleIssueNode (EntityData {..}) -> expandChildless _children SinglePullNode (EntityData {..}) -> expandChildless _children diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index 0ddb9bb..ad02f01 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -19,6 +19,10 @@ module Sauron.Fetch ( , fetchIssueCommentsAndEvents , fetchBranches + , fetchOverallBranches + , fetchYourBranches + , fetchActiveBranches + , fetchStaleBranches , fetchBranchCommits , fetchCommitDetails @@ -31,15 +35,17 @@ module Sauron.Fetch ( , makeEmptyElem ) where +import Brick.BChan (writeBChan) import Control.Exception.Safe (bracketOnError_) import Control.Monad (foldM) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class +import Control.Monad.Logger (LogLevel(..)) import qualified Data.Map.Strict as Map import Data.String.Interpolate import qualified Data.Text as T import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime(..)) +import Data.Time.Clock (UTCTime(..), getCurrentTime) import qualified Data.Vector as V import GitHub import Network.HTTP.Conduit hiding (Proxy) @@ -48,6 +54,7 @@ import Relude import Sauron.Actions.Util import Sauron.Fetch.Core import Sauron.Fetch.ParseJobLogs +import qualified Sauron.GraphQL as GraphQL import Sauron.Types import UnliftIO.Async @@ -142,6 +149,171 @@ fetchBranches owner name (PaginatedBranchesNode (EntityData {..})) = do (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) +fetchYourBranches :: ( + MonadReader BaseContext m, MonadIO m + ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () +fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do + bc <- ask + + -- Use GraphQL for efficient "Your branches" query + liftIO $ logToModal bc "fetchYourBranches: Starting GraphQL query" + case getAuthToken bc of + Nothing -> liftIO $ do + logToModal bc "fetchYourBranches: No auth token available" + atomically $ writeTVar _state (Errored "No auth token available for GraphQL query") + Just authToken -> do + liftIO $ logToModal bc $ "fetchYourBranches: Got auth token: " <> T.take 10 authToken <> "..." + currentUserName <- liftIO $ getUserName bc + case currentUserName of + Nothing -> liftIO $ do + logToModal bc "fetchYourBranches: Could not get current user name" + atomically $ writeTVar _state (Errored "Could not get current user name") + Just userName -> liftIO $ do + logToModal bc $ "fetchYourBranches: Got username: " <> userName + logToModal bc $ "fetchYourBranches: Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name + -- Fetch branches with commit info using GraphQL + result <- GraphQL.queryBranchesWithCommits (logToModal bc) authToken (toPathPart owner) (toPathPart name) 10 + case result of + Left err -> atomically $ do + writeTVar _state (Errored $ toText err) + writeTVar _children [] + Right branchesWithCommits -> do + -- Filter to only branches authored by current user and sort by date + let yourBranches = GraphQL.sortBranchesByDate $ GraphQL.filterBranchesByAuthor userName branchesWithCommits + -- Convert GraphQL results to sauron Branch format + let branches = V.fromList $ map graphqlBranchToGithubBranch yourBranches + -- Store the enhanced branch data in app state + let branchDataMap = Map.fromList [(GraphQL.branchName branch, branch) | branch <- yourBranches] + writeBChan (eventChan bc) (BranchDataUpdated branchDataMap) + atomically $ do + writeTVar _state (Fetched branches) + (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> + SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + logToModal bc $ "fetchYourBranches: Processing complete, found " <> show (case result of + Left _ -> 0 + Right branchesWithCommits -> length $ GraphQL.filterBranchesByAuthor userName branchesWithCommits) <> " your branches" + +fetchActiveBranches :: ( + MonadReader BaseContext m, MonadIO m, MonadMask m + ) => Name Owner -> Name Repo -> Node Variable PaginatedActiveBranchesT -> m () +fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = do + bc <- ask + _currentTime <- liftIO getCurrentTime + -- let threeMonthsAgo = addUTCTime (-90 * 24 * 60 * 60) currentTime -- 90 days + + -- For now, since filtering requires async IO, just fetch all branches + -- TODO: Implement efficient filtering with background worker or streaming approach + fetchPaginated'' (branchesForR owner name) _pageInfo _state $ \case + Left err -> do + writeTVar _state (Errored (show err)) + writeTVar _children [] + Right (branches, newPageInfo) -> do + writeTVar _pageInfo newPageInfo + -- For now, return all branches until we implement proper async filtering + writeTVar _state (Fetched branches) + (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> + SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + +fetchStaleBranches :: ( + MonadReader BaseContext m, MonadIO m, MonadMask m + ) => Name Owner -> Name Repo -> Node Variable PaginatedStaleBranchesT -> m () +fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = do + bc <- ask + _currentTime <- liftIO getCurrentTime + -- let threeMonthsAgo = addUTCTime (-90 * 24 * 60 * 60) currentTime -- 90 days + + -- For now, since filtering requires async IO, just fetch all branches + -- TODO: Implement efficient filtering with background worker or streaming approach + fetchPaginated'' (branchesForR owner name) _pageInfo _state $ \case + Left err -> do + writeTVar _state (Errored (show err)) + writeTVar _children [] + Right (branches, newPageInfo) -> do + writeTVar _pageInfo newPageInfo + -- For now, return all branches until we implement proper async filtering + writeTVar _state (Fetched branches) + (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> + SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + +fetchOverallBranches :: ( + MonadReader BaseContext m, MonadIO m + ) => Name Owner -> Name Repo -> Node Variable OverallBranchesT -> m () +fetchOverallBranches _owner _name (OverallBranchesNode (EntityData {..})) = do + bc <- ask + -- Create categorized branch sections similar to GitHub's interface + categorizedChildren <- atomically $ do + yourBranchesEd <- makeEmptyElem bc () "your-branches" (_depth + 1) + activeBranchesEd <- makeEmptyElem bc () "active-branches" (_depth + 1) + staleBranchesEd <- makeEmptyElem bc () "stale-branches" (_depth + 1) + let nodes = [ SomeNode (PaginatedYourBranchesNode yourBranchesEd) + , SomeNode (PaginatedActiveBranchesNode activeBranchesEd) + , SomeNode (PaginatedStaleBranchesNode staleBranchesEd) + ] + return nodes + + atomically $ do + writeTVar _state (Fetched ()) + writeTVar _children categorizedChildren + +-- Helper functions for branch categorization + +-- Helper function to log to the modal +logToModal :: BaseContext -> Text -> IO () +logToModal bc msg = do + now <- getCurrentTime + let logEntry = LogEntry now LevelInfo msg + writeBChan (eventChan bc) (LogEntryAdded logEntry) + +getUserName :: BaseContext -> IO (Maybe Text) +getUserName bc = do + -- Get the current authenticated user's name from GitHub API + result <- runReaderT (withGithubApiSemaphore (githubWithLogging userInfoCurrentR)) bc + case result of + Left _err -> return Nothing + Right user -> return $ Just $ toPathPart $ userLogin user + +-- Helper function to extract auth token for GraphQL queries +getAuthToken :: BaseContext -> Maybe Text +getAuthToken bc = case auth bc of + OAuth token -> Just $ decodeUtf8 token + _ -> Nothing -- Only OAuth tokens supported for now + +-- Convert GraphQL BranchWithCommit to GitHub Branch format +graphqlBranchToGithubBranch :: GraphQL.BranchWithCommit -> Branch +graphqlBranchToGithubBranch GraphQL.BranchWithCommit{..} = Branch + { branchName = branchName + , branchCommit = BranchCommit + { branchCommitSha = fromMaybe "unknown" commitOid + , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" commitOid + } + } + +-- TODO: Implement filtering functions using background processing or redesigned fetch approach +-- The current STM-based approach doesn't allow IO operations in the callback +-- filterBranchesByUser :: BaseContext -> Name Owner -> Name Repo -> Maybe Text -> V.Vector Branch -> IO (V.Vector Branch) +-- filterBranchesByUser _bc _owner _name _userName branches = return branches -- Return all branches for now + +-- filterBranchesByActivity :: BaseContext -> Name Owner -> Name Repo -> UTCTime -> V.Vector Branch -> Bool -> IO (V.Vector Branch) +-- filterBranchesByActivity _bc _owner _name _cutoffTime branches _includeRecent = return branches -- Return all branches for now + +-- Example of using the new branch filtering API for protected branches +-- fetchProtectedBranches :: ( +-- MonadReader BaseContext m, MonadIO m, MonadMask m +-- ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () +-- fetchProtectedBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do +-- bc <- ask +-- -- Use branchesWithOptionsForR to fetch only protected branches +-- let fetchWithProtectedFilter = \fetchCount -> branchesWithOptionsForR owner name fetchCount [BranchQueryProtected True] +-- fetchPaginated'' fetchWithProtectedFilter _pageInfo _state $ \case +-- Left err -> do +-- writeTVar _state (Errored (show err)) +-- writeTVar _children [] +-- Right (branches, newPageInfo) -> do +-- writeTVar _pageInfo newPageInfo +-- writeTVar _state (Fetched branches) +-- (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> +-- SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + fetchNotifications :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Node Variable PaginatedNotificationsT -> m () diff --git a/app/Sauron/Fix.hs b/app/Sauron/Fix.hs index b87b5a9..8e8caf0 100644 --- a/app/Sauron/Fix.hs +++ b/app/Sauron/Fix.hs @@ -40,6 +40,10 @@ fixNode item@(PaginatedPullsNode ed) = fixTypedNode item ed fixNode item@(PaginatedWorkflowsNode ed) = fixTypedNode item ed fixNode item@(PaginatedReposNode ed) = fixTypedNode item ed fixNode item@(PaginatedBranchesNode ed) = fixTypedNode item ed +fixNode item@(OverallBranchesNode ed) = fixWrappedNode item ed +fixNode item@(PaginatedYourBranchesNode ed) = fixTypedNode item ed +fixNode item@(PaginatedActiveBranchesNode ed) = fixTypedNode item ed +fixNode item@(PaginatedStaleBranchesNode ed) = fixTypedNode item ed fixNode item@(PaginatedNotificationsNode ed) = fixTypedNode item ed fixNode item@(SingleIssueNode ed) = fixChildlessNode item ed fixNode item@(SinglePullNode ed) = fixChildlessNode item ed diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs new file mode 100644 index 0000000..66c0679 --- /dev/null +++ b/app/Sauron/GraphQL.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Sauron.GraphQL ( + BranchWithCommit(..) + , queryBranchesWithCommits + , sortBranchesByDate + , filterBranchesByAuthor + , prNumber + ) where + +import Control.Exception.Safe (try) +import Data.Aeson +import Data.String.Interpolate +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Network.HTTP.Conduit (responseTimeoutMicro) +import Network.HTTP.Simple +import Relude + +-- GitHub GraphQL API endpoint +githubGraphQLEndpoint :: String +githubGraphQLEndpoint = "https://api.github.com/graphql" + +-- GraphQL query to get repository branches with commit information and associated pull requests +getBranchesQuery :: Text +getBranchesQuery = [i| + query GetBranchesWithCommits($owner: String!, $name: String!, $first: Int!) { + repository(owner: $owner, name: $name) { + defaultBranchRef { name } + refs(refPrefix: "refs/heads/", first: $first) { + nodes { + name + target { + ... on Commit { + oid + author { + name + email + date + user { + login + } + } + committedDate + statusCheckRollup { + state + } + } + } + associatedPullRequests(states: OPEN, first: 1) { + nodes { + number + title + url + } + } + } + pageInfo { + hasNextPage + endCursor + } + } + } + } + |] + +data BranchResponse = BranchResponse { + data' :: Maybe RepositoryData + , errors :: Maybe [GraphQLError] + } deriving (Show, Generic) + +instance FromJSON BranchResponse where + parseJSON = withObject "BranchResponse" $ \o -> BranchResponse + <$> o .:? "data" + <*> o .:? "errors" + +data RepositoryData = RepositoryData { + repository :: Maybe Repository + } deriving (Show, Generic) + +instance FromJSON RepositoryData + +data Repository = Repository { + refs :: Maybe Refs + , defaultBranchRef :: Maybe DefaultBranchRef + } deriving (Show, Generic) + +instance FromJSON Repository + +data DefaultBranchRef = DefaultBranchRef { + defaultBranchName :: Maybe Text + } deriving (Show, Generic) + +instance FromJSON DefaultBranchRef where + parseJSON = withObject "DefaultBranchRef" $ \o -> DefaultBranchRef <$> o .:? "name" + +data Refs = Refs { + nodes :: Maybe [RefNode] + , pageInfo :: Maybe PageInfo + } deriving (Show, Generic) + +instance FromJSON Refs + +data RefNode = RefNode { + name :: Text + , target :: Maybe Target + , associatedPullRequests :: Maybe AssociatedPRs + } deriving (Show, Generic) + +instance FromJSON RefNode + +data AssociatedPRs = AssociatedPRs { + prNodes :: Maybe [PullRequest] + } deriving (Show, Generic) + +instance FromJSON AssociatedPRs where + parseJSON = withObject "AssociatedPRs" $ \o -> AssociatedPRs <$> o .:? "nodes" + +data PullRequest = PullRequest { + prNumber :: Maybe Int + , prTitle :: Maybe Text + , prUrl :: Maybe Text + } deriving (Show, Eq, Generic) + +instance FromJSON PullRequest where + parseJSON = withObject "PullRequest" $ \o -> PullRequest + <$> o .:? "number" + <*> o .:? "title" + <*> o .:? "url" + +data Target = Target { + oid :: Maybe Text + , author :: Maybe Author + , committedDate :: Maybe Text + , statusCheckRollup :: Maybe StatusCheckRollup + } deriving (Show, Generic) + +instance FromJSON Target + +data StatusCheckRollup = StatusCheckRollup { + statusState :: Maybe Text + } deriving (Show, Generic) + +instance FromJSON StatusCheckRollup where + parseJSON = withObject "StatusCheckRollup" $ \o -> StatusCheckRollup <$> o .:? "state" + +data Author = Author { + authorName :: Maybe Text + , email :: Maybe Text + , date :: Maybe Text + , user :: Maybe User + } deriving (Show, Generic) +instance FromJSON Author where + parseJSON = withObject "Author" $ \o -> Author + <$> o .:? "name" + <*> o .:? "email" + <*> o .:? "date" + <*> o .:? "user" + +data User = User { login :: Maybe Text } + deriving (Show, Generic) +instance FromJSON User + +data PageInfo = PageInfo { + hasNextPage :: Maybe Bool + , endCursor :: Maybe Text + } deriving (Show, Generic) +instance FromJSON PageInfo + +data GraphQLError = GraphQLError { message :: Text } deriving (Show, Generic) +instance FromJSON GraphQLError + +-- GraphQL variables for the query +data BranchVariables = BranchVariables + { owner :: Text + , repositoryName :: Text -- 'name' is a reserved keyword + , first :: Int + } deriving (Show, Generic) +instance ToJSON BranchVariables where + toJSON (BranchVariables owner' name' first') = object [ + "owner" .= owner' + , "name" .= name' + , "first" .= first' + ] + +data GraphQLRequest = GraphQLRequest { + query :: Text + , variables :: BranchVariables + } deriving (Show, Generic) +instance ToJSON GraphQLRequest + +queryBranchesWithCommits :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Int -> m (Either Text [BranchWithCommit]) +queryBranchesWithCommits debugFn authToken owner' repoName first' = liftIO $ do + debugFn $ "GraphQL query for " <> owner' <> "/" <> repoName <> " (first " <> show first' <> ")" + let requestPayload = GraphQLRequest + { query = getBranchesQuery + , variables = BranchVariables owner' repoName first' + } + debugFn $ "GraphQL query: " <> T.take 200 getBranchesQuery + + result <- try $ do + debugFn "Creating HTTP request" + initialRequest <- parseRequest githubGraphQLEndpoint + let httpRequest = setRequestMethod "POST" + $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 authToken] + $ setRequestHeader "Content-Type" ["application/json"] + $ setRequestHeader "User-Agent" ["sauron-app"] + $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) -- 30 second timeout + $ setRequestBodyJSON requestPayload + $ initialRequest + + debugFn "Sending GraphQL HTTP request" + response <- httpJSON httpRequest + debugFn "HTTP response received, parsing JSON" + let body = getResponseBody response :: BranchResponse + debugFn "GraphQL response parsed successfully" + return body + + case result of + Left (ex :: SomeException) -> do + debugFn $ "GraphQL HTTP request failed: " <> T.pack (show ex) + return $ Left $ "HTTP request failed: " <> T.pack (show ex) + Right body -> do + debugFn "Processing GraphQL response body" + case (data' body, errors body) of + (Just repoData, Nothing) -> do + debugFn "GraphQL success, processing data" + case repository repoData >>= refs >>= nodes of + Just refNodes -> do + debugFn $ "Found " <> show (length refNodes) <> " branches" + return $ Right $ mapMaybe refNodeToBranch refNodes + Nothing -> do + debugFn "No branches found in response" + return $ Right [] + (_, Just errs) -> do + debugFn $ "GraphQL errors: " <> T.intercalate ", " (map message errs) + return $ Left $ T.intercalate ", " (map message errs) + (Nothing, Nothing) -> do + debugFn "No data returned from GitHub" + return $ Left "No data returned from GitHub" + +refNodeToBranch :: RefNode -> Maybe BranchWithCommit +refNodeToBranch refNode = do + let branchName = name refNode + target' <- target refNode + let prInfo = associatedPullRequests refNode >>= prNodes >>= viaNonEmpty head + return $ BranchWithCommit + { branchName = branchName + , commitOid = oid target' + , commitAuthor = author target' >>= user >>= login + , authorEmail = author target' >>= email + , commitDate = committedDate target' + , checkStatus = statusCheckRollup target' >>= statusState + , associatedPR = prInfo + } + +data BranchWithCommit = BranchWithCommit { + branchName :: Text + , commitOid :: Maybe Text + , commitAuthor :: Maybe Text + , authorEmail :: Maybe Text + , commitDate :: Maybe Text + , checkStatus :: Maybe Text + , associatedPR :: Maybe PullRequest + } deriving (Show, Eq) + +filterBranchesByAuthor :: Text -> [BranchWithCommit] -> [BranchWithCommit] +filterBranchesByAuthor currentUser branches = + filter (\branch -> commitAuthor branch == Just currentUser) branches + +sortBranchesByDate :: [BranchWithCommit] -> [BranchWithCommit] +sortBranchesByDate branches = sortBy (comparing (Down . commitDateUtc)) branches + where + commitDateUtc :: BranchWithCommit -> Maybe UTCTime + commitDateUtc branch = commitDate branch >>= parseISODate + + parseISODate :: Text -> Maybe UTCTime + parseISODate dateStr = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) + +filterBranchesByActivity :: UTCTime -> [BranchWithCommit] -> [BranchWithCommit] +filterBranchesByActivity cutoffTime branches = + filter (isBranchActive cutoffTime) branches + where + isBranchActive :: UTCTime -> BranchWithCommit -> Bool + isBranchActive cutoff branch = + case commitDate branch of + Nothing -> False + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of + Nothing -> False + Just commitTime -> commitTime > cutoff diff --git a/app/Sauron/Setup/Common.hs b/app/Sauron/Setup/Common.hs index b665179..54ba635 100644 --- a/app/Sauron/Setup/Common.hs +++ b/app/Sauron/Setup/Common.hs @@ -91,6 +91,7 @@ newRepoNode nsName repoVar healthCheckVar hcThread repoDepth getIdentifier = do , _ident = workflowsIdentifier } :: Node Variable PaginatedWorkflowsT + -- Traditional flat branches list branchesVar <- newTVarIO NotFetched branchesToggledVar <- newTVarIO False branchesChildrenVar <- newTVarIO [] @@ -113,8 +114,31 @@ newRepoNode nsName repoVar healthCheckVar hcThread repoDepth getIdentifier = do , _ident = branchesIdentifier } :: Node Variable PaginatedBranchesT + -- New GitHub-style categorized branches + categorizedBranchesStateVar <- newTVarIO NotFetched + categorizedBranchesToggledVar <- newTVarIO False + categorizedBranchesChildrenVar <- newTVarIO [] + categorizedBranchesSearchVar <- newTVarIO SearchNone + categorizedBranchesPageInfoVar <- newTVarIO $ PageInfo 1 Nothing Nothing Nothing Nothing + categorizedBranchesHealthCheckVar <- newTVarIO NotFetched + categorizedBranchesHealthCheckThreadVar <- newTVarIO Nothing + categorizedBranchesIdentifier <- liftIO getIdentifier + let categorizedBranchesChild = OverallBranchesNode $ EntityData { + _static = () + , _state = categorizedBranchesStateVar + , _urlSuffix = "branches/categorized" + , _toggled = categorizedBranchesToggledVar + , _children = categorizedBranchesChildrenVar + , _search = categorizedBranchesSearchVar + , _pageInfo = categorizedBranchesPageInfoVar + , _healthCheck = categorizedBranchesHealthCheckVar + , _healthCheckThread = categorizedBranchesHealthCheckThreadVar + , _depth = repoDepth + 1 + , _ident = categorizedBranchesIdentifier + } :: Node Variable OverallBranchesT + repoIdentifier <- liftIO getIdentifier - childrenVar <- newTVarIO [SomeNode issuesChild, SomeNode pullsChild, SomeNode workflowsChild, SomeNode branchesChild] + childrenVar <- newTVarIO [SomeNode issuesChild, SomeNode pullsChild, SomeNode workflowsChild, SomeNode branchesChild, SomeNode categorizedBranchesChild] searchVar <- newTVarIO SearchNone pageInfoVar <- newTVarIO emptyPageInfo repoHealthCheckThreadVar <- newTVarIO hcThread diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index b92a1e2..bfa5861 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -30,6 +30,7 @@ import Lens.Micro import Lens.Micro.TH import Network.HTTP.Client (Manager) import Relude +import qualified Sauron.GraphQL as GraphQL import qualified Text.Show import UnliftIO.Async @@ -57,6 +58,10 @@ data Node f (a :: NodeTyp) where PaginatedWorkflowsNode :: EntityData f 'PaginatedWorkflowsT -> Node f 'PaginatedWorkflowsT PaginatedReposNode :: EntityData f 'PaginatedReposT -> Node f 'PaginatedReposT PaginatedBranchesNode :: EntityData f 'PaginatedBranchesT -> Node f 'PaginatedBranchesT + OverallBranchesNode :: EntityData f 'OverallBranchesT -> Node f 'OverallBranchesT + PaginatedYourBranchesNode :: EntityData f 'PaginatedYourBranchesT -> Node f 'PaginatedYourBranchesT + PaginatedActiveBranchesNode :: EntityData f 'PaginatedActiveBranchesT -> Node f 'PaginatedActiveBranchesT + PaginatedStaleBranchesNode :: EntityData f 'PaginatedStaleBranchesT -> Node f 'PaginatedStaleBranchesT PaginatedNotificationsNode :: EntityData f 'PaginatedNotificationsT -> Node f 'PaginatedNotificationsT SingleIssueNode :: EntityData f 'SingleIssueT -> Node f 'SingleIssueT @@ -77,6 +82,10 @@ data NodeTyp = | PaginatedWorkflowsT | PaginatedReposT | PaginatedBranchesT + | OverallBranchesT + | PaginatedYourBranchesT + | PaginatedActiveBranchesT + | PaginatedStaleBranchesT | PaginatedNotificationsT | SingleIssueT @@ -99,6 +108,10 @@ instance Show (Node f a) where show (PaginatedWorkflowsNode (EntityData {..})) = [i|PaginatedWorkflowsNode<#{_ident}>|] show (PaginatedReposNode (EntityData {..})) = [i|PaginatedReposNode<#{_ident}>|] show (PaginatedBranchesNode (EntityData {..})) = [i|PaginatedBranchesNode<#{_ident}>|] + show (OverallBranchesNode (EntityData {..})) = [i|OverallBranchesNode<#{_ident}>|] + show (PaginatedYourBranchesNode (EntityData {..})) = [i|PaginatedYourBranchesNode<#{_ident}>|] + show (PaginatedActiveBranchesNode (EntityData {..})) = [i|PaginatedActiveBranchesNode<#{_ident}>|] + show (PaginatedStaleBranchesNode (EntityData {..})) = [i|PaginatedStaleBranchesNode<#{_ident}>|] show (PaginatedNotificationsNode (EntityData {..})) = [i|PaginatedNotificationsNode<#{_ident}>|] show (SingleIssueNode (EntityData {..})) = [i|SingleIssueNode<#{_ident}>|] @@ -142,6 +155,10 @@ type family NodeStatic a where NodeStatic PaginatedWorkflowsT = () NodeStatic PaginatedReposT = Name User NodeStatic PaginatedBranchesT = () + NodeStatic OverallBranchesT = () + NodeStatic PaginatedYourBranchesT = () + NodeStatic PaginatedActiveBranchesT = () + NodeStatic PaginatedStaleBranchesT = () NodeStatic PaginatedNotificationsT = () NodeStatic SingleIssueT = Issue NodeStatic SinglePullT = Issue @@ -160,6 +177,10 @@ type family NodeState a where NodeState PaginatedWorkflowsT = WithTotalCount WorkflowRun NodeState PaginatedReposT = SearchResult Repo NodeState PaginatedBranchesT = V.Vector Branch + NodeState OverallBranchesT = () + NodeState PaginatedYourBranchesT = V.Vector Branch + NodeState PaginatedActiveBranchesT = V.Vector Branch + NodeState PaginatedStaleBranchesT = V.Vector Branch NodeState PaginatedNotificationsT = V.Vector Notification NodeState SingleIssueT = V.Vector (Either IssueEvent IssueComment) NodeState SinglePullT = V.Vector (Either IssueEvent IssueComment) @@ -178,6 +199,10 @@ type family NodeChildType f a where NodeChildType f PaginatedWorkflowsT = Node f SingleWorkflowT NodeChildType f PaginatedReposT = Node f RepoT NodeChildType f PaginatedBranchesT = Node f SingleBranchT + NodeChildType f OverallBranchesT = SomeNode f + NodeChildType f PaginatedYourBranchesT = Node f SingleBranchT + NodeChildType f PaginatedActiveBranchesT = Node f SingleBranchT + NodeChildType f PaginatedStaleBranchesT = Node f SingleBranchT NodeChildType f PaginatedNotificationsT = Node f SingleNotificationT NodeChildType f SingleIssueT = () NodeChildType f SinglePullT = () @@ -218,6 +243,7 @@ getExistentialChildrenWrapped node = case node of -- These types have SomeNode children HeadingNode ed -> readTVar (_children ed) RepoNode ed -> readTVar (_children ed) + OverallBranchesNode ed -> readTVar (_children ed) -- These types have specific GADT constructor children, so wrap them PaginatedIssuesNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) @@ -225,6 +251,9 @@ getExistentialChildrenWrapped node = case node of PaginatedWorkflowsNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) PaginatedReposNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) PaginatedBranchesNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) + PaginatedYourBranchesNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) + PaginatedActiveBranchesNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) + PaginatedStaleBranchesNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) PaginatedNotificationsNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) SingleWorkflowNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) SingleJobNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) @@ -249,6 +278,10 @@ entityDataL f (PaginatedPullsNode ed) = PaginatedPullsNode <$> f ed entityDataL f (PaginatedWorkflowsNode ed) = PaginatedWorkflowsNode <$> f ed entityDataL f (PaginatedReposNode ed) = PaginatedReposNode <$> f ed entityDataL f (PaginatedBranchesNode ed) = PaginatedBranchesNode <$> f ed +entityDataL f (OverallBranchesNode ed) = OverallBranchesNode <$> f ed +entityDataL f (PaginatedYourBranchesNode ed) = PaginatedYourBranchesNode <$> f ed +entityDataL f (PaginatedActiveBranchesNode ed) = PaginatedActiveBranchesNode <$> f ed +entityDataL f (PaginatedStaleBranchesNode ed) = PaginatedStaleBranchesNode <$> f ed entityDataL f (PaginatedNotificationsNode ed) = PaginatedNotificationsNode <$> f ed entityDataL f (SingleIssueNode ed) = SingleIssueNode <$> f ed entityDataL f (SinglePullNode ed) = SinglePullNode <$> f ed @@ -380,6 +413,7 @@ data AppEvent = | TimeUpdated UTCTime | CommentModalEvent CommentModalEvent | LogEntryAdded LogEntry + | BranchDataUpdated (Map Text GraphQL.BranchWithCommit) data CommentModalEvent = CommentSubmitted (Either Error Comment) @@ -437,6 +471,9 @@ data AppState = AppState { , _appColorMode :: V.ColorMode , _appLogs :: Seq LogEntry + + -- Enhanced branch data from GraphQL queries + , _appBranchData :: Map Text GraphQL.BranchWithCommit } diff --git a/app/Sauron/UI.hs b/app/Sauron/UI.hs index 1ec494f..8205951 100644 --- a/app/Sauron/UI.hs +++ b/app/Sauron/UI.hs @@ -53,6 +53,10 @@ drawNodeLine appState node = case node of PaginatedWorkflowsNode ed -> drawLine appState ed PaginatedReposNode ed -> drawLine appState ed PaginatedBranchesNode ed -> drawLine appState ed + OverallBranchesNode ed -> drawLine appState ed + PaginatedYourBranchesNode ed -> drawLine appState ed + PaginatedActiveBranchesNode ed -> drawLine appState ed + PaginatedStaleBranchesNode ed -> drawLine appState ed PaginatedNotificationsNode ed -> drawLine appState ed SingleIssueNode ed -> drawLine appState ed SinglePullNode ed -> drawLine appState ed @@ -72,6 +76,10 @@ drawNodeInner appState node = case node of PaginatedWorkflowsNode ed -> drawInner appState ed PaginatedReposNode ed -> drawInner appState ed PaginatedBranchesNode ed -> drawInner appState ed + OverallBranchesNode ed -> drawInner appState ed + PaginatedYourBranchesNode ed -> drawInner appState ed + PaginatedActiveBranchesNode ed -> drawInner appState ed + PaginatedStaleBranchesNode ed -> drawInner appState ed PaginatedNotificationsNode ed -> drawInner appState ed SingleIssueNode ed -> drawInner appState ed SinglePullNode ed -> drawInner appState ed diff --git a/app/Sauron/UI/Branch.hs b/app/Sauron/UI/Branch.hs index 2f447c5..27c9670 100644 --- a/app/Sauron/UI/Branch.hs +++ b/app/Sauron/UI/Branch.hs @@ -7,13 +7,19 @@ module Sauron.UI.Branch ( ) where import Brick +import qualified Data.Map as Map import Data.String.Interpolate +import qualified Data.Text as T +import Data.Time.Clock (UTCTime, diffUTCTime) +import Data.Time.Format (parseTimeM, defaultTimeLocale) import qualified Data.Vector as V import GitHub import Relude +import qualified Sauron.GraphQL as GraphQL import Sauron.Types import Sauron.UI.AttrMap import Sauron.UI.Statuses (fetchableQuarterCircleSpinner) +import Sauron.UI.Util.TimeDiff (timeFromNow) instance ListDrawable Fixed 'SingleBranchT where @@ -25,9 +31,21 @@ instance ListDrawable Fixed 'SingleBranchT where branchLine :: Bool -> Branch -> AppState -> Fetchable (V.Vector Commit) -> Widget n branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState = vBox [line1, line2] where + -- Get enhanced branch data from the app state + maybeBranchData = Map.lookup branchName (_appBranchData appState) + line1 = hBox [ withAttr openMarkerAttr $ str (if toggled' then "[-] " else "[+] ") - , withAttr branchAttr $ str $ toString branchName + , hLimitPercent 30 $ withAttr branchAttr $ + padRight Max $ txt branchName + , hLimitPercent 15 $ + padRight Max $ str $ formatCommitTime maybeBranchData + , hLimitPercent 12 $ + padRight Max $ str $ formatCheckStatus maybeBranchData + , hLimitPercent 10 $ + padRight Max $ str "↑0 ↓0" -- Placeholder for ahead/behind + , hLimitPercent 15 $ + padRight Max $ str $ formatPRInfo maybeBranchData , fetchableQuarterCircleSpinner (_appAnimationCounter appState) fetchableState , padLeft Max $ case fetchableState of Fetched commits -> str [i|(#{V.length commits} commits)|] @@ -38,3 +56,35 @@ branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState str "Latest commit " , withAttr hashAttr $ str $ take 7 $ toString $ branchCommitSha branchCommit ] + + -- Helper function to format commit time from GraphQL data using timeFromNow + formatCommitTime :: Maybe GraphQL.BranchWithCommit -> String + formatCommitTime Nothing = "Unknown" + formatCommitTime (Just branchData) = + case GraphQL.commitDate branchData of + Nothing -> "Unknown" + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of + Nothing -> toString $ T.take 10 dateStr -- Fallback to raw date + Just commitTime -> timeFromNow (diffUTCTime (_appNow appState) commitTime) + + -- Helper function to format check status + formatCheckStatus :: Maybe GraphQL.BranchWithCommit -> String + formatCheckStatus Nothing = "No checks" + formatCheckStatus (Just branchData) = + case GraphQL.checkStatus branchData of + Nothing -> "No checks" + Just "SUCCESS" -> "✓ Checks" + Just "FAILURE" -> "✗ Failed" + Just "PENDING" -> "⏳ Running" + Just status -> toString status + + -- Helper function to format PR info + formatPRInfo :: Maybe GraphQL.BranchWithCommit -> String + formatPRInfo Nothing = "No PR" + formatPRInfo (Just branchData) = + case GraphQL.associatedPR branchData of + Nothing -> "No PR" + Just pr -> case GraphQL.prNumber pr of + Nothing -> "PR: Unknown" + Just num -> "PR #" <> show num diff --git a/app/Sauron/UI/Modals/ZoomModal.hs b/app/Sauron/UI/Modals/ZoomModal.hs index 75fb4fe..eed6c12 100644 --- a/app/Sauron/UI/Modals/ZoomModal.hs +++ b/app/Sauron/UI/Modals/ZoomModal.hs @@ -70,6 +70,14 @@ generateModalTitle (SomeNode inner) = "Workflow Runs" PaginatedBranchesNode _ -> "Branches" + OverallBranchesNode _ -> + "Branches" + PaginatedYourBranchesNode _ -> + "Your Branches" + PaginatedActiveBranchesNode _ -> + "Active Branches" + PaginatedStaleBranchesNode _ -> + "Stale Branches" PaginatedNotificationsNode _ -> "Notifications" SingleIssueNode (EntityData {_static = Issue {issueNumber = IssueNumber num, issueTitle}}) -> diff --git a/app/Sauron/UI/Pagination.hs b/app/Sauron/UI/Pagination.hs index ce51768..88e76a5 100644 --- a/app/Sauron/UI/Pagination.hs +++ b/app/Sauron/UI/Pagination.hs @@ -68,12 +68,54 @@ instance ListDrawable Fixed 'PaginatedWorkflowsT where instance ListDrawable Fixed 'PaginatedBranchesT where drawLine appState ed@(EntityData {..}) = case _state of - Fetched branches -> paginatedHeading ed appState "Branches" (countWidget _pageInfo branches) + Fetched branches -> paginatedHeading ed appState "All Branches" (countWidget _pageInfo branches) Fetching maybeBranches -> case maybeBranches of - Just branches -> paginatedHeading ed appState "Branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) - Nothing -> paginatedHeading ed appState "Branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") - NotFetched -> paginatedHeading ed appState "Branches" (str [i|(not fetched)|]) - Errored err -> paginatedHeading ed appState "Branches" (str [i|(error fetching: #{err})|]) + Just branches -> paginatedHeading ed appState "All Branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Nothing -> paginatedHeading ed appState "All Branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") + NotFetched -> paginatedHeading ed appState "All Branches" (str [i|(not fetched)|]) + Errored err -> paginatedHeading ed appState "All Branches" (str [i|(error fetching: #{err})|]) + + drawInner _ _ = Nothing + +instance ListDrawable Fixed 'OverallBranchesT where + drawLine _appState (EntityData {_static=(), _toggled}) = hBox $ catMaybes [ + Just $ withAttr openMarkerAttr $ str (if _toggled then "[-] " else "[+] ") + , Just (hBox [str "GitHub-style Branches"]) + , Just (padLeft Max (str " ")) + ] + + drawInner _ _ = Nothing + +instance ListDrawable Fixed 'PaginatedYourBranchesT where + drawLine appState ed@(EntityData {..}) = case _state of + Fetched branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches) + Fetching maybeBranches -> case maybeBranches of + Just branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Nothing -> paginatedHeading ed appState "Your branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") + NotFetched -> paginatedHeading ed appState "Your branches" (str [i|(not fetched)|]) + Errored err -> paginatedHeading ed appState "Your branches" (str [i|(error fetching: #{err})|]) + + drawInner _ _ = Nothing + +instance ListDrawable Fixed 'PaginatedActiveBranchesT where + drawLine appState ed@(EntityData {..}) = case _state of + Fetched branches -> paginatedHeading ed appState "Active branches" (countWidget _pageInfo branches) + Fetching maybeBranches -> case maybeBranches of + Just branches -> paginatedHeading ed appState "Active branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Nothing -> paginatedHeading ed appState "Active branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") + NotFetched -> paginatedHeading ed appState "Active branches" (str [i|(not fetched)|]) + Errored err -> paginatedHeading ed appState "Active branches" (str [i|(error fetching: #{err})|]) + + drawInner _ _ = Nothing + +instance ListDrawable Fixed 'PaginatedStaleBranchesT where + drawLine appState ed@(EntityData {..}) = case _state of + Fetched branches -> paginatedHeading ed appState "Stale branches" (countWidget _pageInfo branches) + Fetching maybeBranches -> case maybeBranches of + Just branches -> paginatedHeading ed appState "Stale branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Nothing -> paginatedHeading ed appState "Stale branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") + NotFetched -> paginatedHeading ed appState "Stale branches" (str [i|(not fetched)|]) + Errored err -> paginatedHeading ed appState "Stale branches" (str [i|(error fetching: #{err})|]) drawInner _ _ = Nothing diff --git a/app/Sauron/UI/TopBox.hs b/app/Sauron/UI/TopBox.hs index d39c2a1..9e9cf01 100644 --- a/app/Sauron/UI/TopBox.hs +++ b/app/Sauron/UI/TopBox.hs @@ -110,6 +110,9 @@ isSearchable' (SomeNode (PaginatedPullsNode {})) = True isSearchable' (SomeNode (PaginatedWorkflowsNode {})) = False isSearchable' (SomeNode (PaginatedReposNode {})) = True isSearchable' (SomeNode (PaginatedBranchesNode {})) = True +isSearchable' (SomeNode (PaginatedYourBranchesNode {})) = True +isSearchable' (SomeNode (PaginatedActiveBranchesNode {})) = True +isSearchable' (SomeNode (PaginatedStaleBranchesNode {})) = True isSearchable' (SomeNode (PaginatedNotificationsNode {})) = True isSearchable' _ = False diff --git a/package.yaml b/package.yaml index 8a9c7df..9fda571 100644 --- a/package.yaml +++ b/package.yaml @@ -34,6 +34,7 @@ dependencies: - http-types - microlens - monad-logger +- morpheus-graphql-client - mtl - network-uri - pandoc-types diff --git a/sauron.cabal b/sauron.cabal index d852992..e9dd853 100644 --- a/sauron.cabal +++ b/sauron.cabal @@ -41,6 +41,7 @@ executable sauron Sauron.Fetch.ParseJobLogs Sauron.Filter Sauron.Fix + Sauron.GraphQL Sauron.HealthCheck Sauron.HealthCheck.Common Sauron.HealthCheck.Job @@ -121,6 +122,7 @@ executable sauron , microlens , microlens-th , monad-logger + , morpheus-graphql-client , mtl , network-uri , optparse-applicative @@ -177,6 +179,7 @@ test-suite test , http-types , microlens , monad-logger + , morpheus-graphql-client , mtl , network-uri , pandoc-types From 331eb9fe473993389b1fb1aed96c02630df1595c Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 26 Nov 2025 16:40:36 -0700 Subject: [PATCH 02/13] More work on rich branch display --- app/Main.hs | 2 - app/Sauron/Event.hs | 3 -- app/Sauron/Event/Open.hs | 2 +- app/Sauron/Fetch.hs | 32 ++++++++-------- app/Sauron/GraphQL.hs | 64 ++++++++++--------------------- app/Sauron/Types.hs | 34 ++++++++++++---- app/Sauron/UI/Branch.hs | 23 +++++------ app/Sauron/UI/Modals/ZoomModal.hs | 2 +- app/Sauron/UI/Pagination.hs | 6 +-- 9 files changed, 79 insertions(+), 89 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c39cd1c..8de875d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -135,8 +135,6 @@ main = do , _appColorMode = V.FullColor , _appLogs = mempty - - , _appBranchData = mempty } diff --git a/app/Sauron/Event.hs b/app/Sauron/Event.hs index fe321c8..122661c 100644 --- a/app/Sauron/Event.hs +++ b/app/Sauron/Event.hs @@ -45,9 +45,6 @@ appEvent _s (AppEvent (LogEntryAdded logEntry)) = do -- Add log entry to the logs sequence modify (appLogs %~ (Seq.|> logEntry)) -appEvent _s (AppEvent (BranchDataUpdated branchData)) = do - -- Update the branch data map - modify (appBranchData .~ branchData) -- Handle modal events diff --git a/app/Sauron/Event/Open.hs b/app/Sauron/Event/Open.hs index d2c3652..6d639d6 100644 --- a/app/Sauron/Event/Open.hs +++ b/app/Sauron/Event/Open.hs @@ -39,7 +39,7 @@ getNodeUrl (SingleIssueNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url) getNodeUrl (SinglePullNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) getNodeUrl (SingleWorkflowNode (EntityData {_static=workflowRun})) _ = Just (toString $ getUrl $ workflowRunHtmlUrl workflowRun) getNodeUrl (SingleJobNode (EntityData {_state=(fetchableCurrent -> Just (job, _))})) _ = Just (toString $ getUrl $ jobHtmlUrl job) -getNodeUrl (SingleBranchNode (EntityData {_static=branch})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchName branch)) +getNodeUrl (SingleBranchNode (EntityData {_static=(branch, _)})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchName branch)) getNodeUrl (SingleCommitNode (EntityData {_static=commit})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/commit/" <> toString (untagName (commitSha commit))) getNodeUrl (RepoNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just repoBaseUrl getNodeUrl _ _ = Nothing diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index ad02f01..82d47a0 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -147,7 +147,7 @@ fetchBranches owner name (PaginatedBranchesNode (EntityData {..})) = do writeTVar _pageInfo newPageInfo writeTVar _state (Fetched branches) (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) fetchYourBranches :: ( MonadReader BaseContext m, MonadIO m @@ -182,13 +182,13 @@ fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do let yourBranches = GraphQL.sortBranchesByDate $ GraphQL.filterBranchesByAuthor userName branchesWithCommits -- Convert GraphQL results to sauron Branch format let branches = V.fromList $ map graphqlBranchToGithubBranch yourBranches - -- Store the enhanced branch data in app state - let branchDataMap = Map.fromList [(GraphQL.branchName branch, branch) | branch <- yourBranches] - writeBChan (eventChan bc) (BranchDataUpdated branchDataMap) + -- Store the enhanced branch data in the node state + let branchDataMap = Map.fromList [(branchWithInfoBranchName branch, branch) | branch <- yourBranches] atomically $ do - writeTVar _state (Fetched branches) - (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + writeTVar _state (Fetched (branches, branchDataMap)) + (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> do + let graphqlData = Map.lookup branchName branchDataMap + SingleBranchNode <$> makeEmptyElem bc (branch, graphqlData) ("/tree/" <> branchName) (_depth + 1) logToModal bc $ "fetchYourBranches: Processing complete, found " <> show (case result of Left _ -> 0 Right branchesWithCommits -> length $ GraphQL.filterBranchesByAuthor userName branchesWithCommits) <> " your branches" @@ -212,7 +212,7 @@ fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = -- For now, return all branches until we implement proper async filtering writeTVar _state (Fetched branches) (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) fetchStaleBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m @@ -233,7 +233,7 @@ fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = d -- For now, return all branches until we implement proper async filtering writeTVar _state (Fetched branches) (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) + SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) fetchOverallBranches :: ( MonadReader BaseContext m, MonadIO m @@ -278,13 +278,13 @@ getAuthToken bc = case auth bc of OAuth token -> Just $ decodeUtf8 token _ -> Nothing -- Only OAuth tokens supported for now --- Convert GraphQL BranchWithCommit to GitHub Branch format -graphqlBranchToGithubBranch :: GraphQL.BranchWithCommit -> Branch -graphqlBranchToGithubBranch GraphQL.BranchWithCommit{..} = Branch - { branchName = branchName +-- Convert GraphQL BranchWithInfo to GitHub Branch format +graphqlBranchToGithubBranch :: BranchWithInfo -> Branch +graphqlBranchToGithubBranch BranchWithInfo{..} = Branch + { branchName = branchWithInfoBranchName , branchCommit = BranchCommit - { branchCommitSha = fromMaybe "unknown" commitOid - , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" commitOid + { branchCommitSha = fromMaybe "unknown" branchWithInfoCommitOid + , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" branchWithInfoCommitOid } } @@ -332,7 +332,7 @@ fetchNotifications (PaginatedNotificationsNode (EntityData {..})) = do fetchBranchCommits :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Node Variable SingleBranchT -> m () -fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=branch, ..})) = do +fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=(branch, _graphqlData), ..})) = do bc <- ask let branchSha = branchCommitSha $ branchCommit branch bracketOnError_ (atomically $ markFetching _state) diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index 66c0679..dd6a2d1 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -2,8 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} module Sauron.GraphQL ( - BranchWithCommit(..) - , queryBranchesWithCommits + queryBranchesWithCommits , sortBranchesByDate , filterBranchesByAuthor , prNumber @@ -18,6 +17,7 @@ import Data.Time.Format (parseTimeM, defaultTimeLocale) import Network.HTTP.Conduit (responseTimeoutMicro) import Network.HTTP.Simple import Relude +import Sauron.Types hiding (PageInfo) -- GitHub GraphQL API endpoint githubGraphQLEndpoint :: String @@ -112,24 +112,12 @@ data RefNode = RefNode { instance FromJSON RefNode data AssociatedPRs = AssociatedPRs { - prNodes :: Maybe [PullRequest] + prNodes :: Maybe [GraphQLPullRequest] } deriving (Show, Generic) instance FromJSON AssociatedPRs where parseJSON = withObject "AssociatedPRs" $ \o -> AssociatedPRs <$> o .:? "nodes" -data PullRequest = PullRequest { - prNumber :: Maybe Int - , prTitle :: Maybe Text - , prUrl :: Maybe Text - } deriving (Show, Eq, Generic) - -instance FromJSON PullRequest where - parseJSON = withObject "PullRequest" $ \o -> PullRequest - <$> o .:? "number" - <*> o .:? "title" - <*> o .:? "url" - data Target = Target { oid :: Maybe Text , author :: Maybe Author @@ -191,7 +179,7 @@ data GraphQLRequest = GraphQLRequest { } deriving (Show, Generic) instance ToJSON GraphQLRequest -queryBranchesWithCommits :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Int -> m (Either Text [BranchWithCommit]) +queryBranchesWithCommits :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Int -> m (Either Text [BranchWithInfo]) queryBranchesWithCommits debugFn authToken owner' repoName first' = liftIO $ do debugFn $ "GraphQL query for " <> owner' <> "/" <> repoName <> " (first " <> show first' <> ")" let requestPayload = GraphQLRequest @@ -241,51 +229,41 @@ queryBranchesWithCommits debugFn authToken owner' repoName first' = liftIO $ do debugFn "No data returned from GitHub" return $ Left "No data returned from GitHub" -refNodeToBranch :: RefNode -> Maybe BranchWithCommit +refNodeToBranch :: RefNode -> Maybe BranchWithInfo refNodeToBranch refNode = do let branchName = name refNode target' <- target refNode let prInfo = associatedPullRequests refNode >>= prNodes >>= viaNonEmpty head - return $ BranchWithCommit - { branchName = branchName - , commitOid = oid target' - , commitAuthor = author target' >>= user >>= login - , authorEmail = author target' >>= email - , commitDate = committedDate target' - , checkStatus = statusCheckRollup target' >>= statusState - , associatedPR = prInfo + return $ BranchWithInfo { + branchWithInfoBranchName = branchName + , branchWithInfoCommitOid = oid target' + , branchWithInfoCommitAuthor = author target' >>= user >>= login + , branchWithInfoAuthorEmail = author target' >>= email + , branchWithInfoCommitDate = committedDate target' + , branchWithInfoCheckStatus = statusCheckRollup target' >>= statusState + , branchWithInfoAssociatedPR = prInfo } -data BranchWithCommit = BranchWithCommit { - branchName :: Text - , commitOid :: Maybe Text - , commitAuthor :: Maybe Text - , authorEmail :: Maybe Text - , commitDate :: Maybe Text - , checkStatus :: Maybe Text - , associatedPR :: Maybe PullRequest - } deriving (Show, Eq) - -filterBranchesByAuthor :: Text -> [BranchWithCommit] -> [BranchWithCommit] +filterBranchesByAuthor :: Text -> [BranchWithInfo] -> [BranchWithInfo] filterBranchesByAuthor currentUser branches = - filter (\branch -> commitAuthor branch == Just currentUser) branches + filter (\branch -> branchWithInfoCommitAuthor branch == Just currentUser) branches -sortBranchesByDate :: [BranchWithCommit] -> [BranchWithCommit] +sortBranchesByDate :: [BranchWithInfo] -> [BranchWithInfo] sortBranchesByDate branches = sortBy (comparing (Down . commitDateUtc)) branches where - commitDateUtc :: BranchWithCommit -> Maybe UTCTime - commitDateUtc branch = commitDate branch >>= parseISODate + commitDateUtc :: BranchWithInfo -> Maybe UTCTime + commitDateUtc branch = branchWithInfoCommitDate branch >>= parseISODate parseISODate :: Text -> Maybe UTCTime parseISODate dateStr = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) -filterBranchesByActivity :: UTCTime -> [BranchWithCommit] -> [BranchWithCommit] +filterBranchesByActivity :: UTCTime -> [BranchWithInfo] -> [BranchWithInfo] filterBranchesByActivity cutoffTime branches = filter (isBranchActive cutoffTime) branches where - isBranchActive :: UTCTime -> BranchWithCommit -> Bool + isBranchActive :: UTCTime -> BranchWithInfo -> Bool isBranchActive cutoff branch = - case commitDate branch of + case branchWithInfoCommitDate branch of Nothing -> False Just dateStr -> case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index bfa5861..90fe6f1 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -19,6 +20,7 @@ import Brick.Widgets.Edit (Editor) import qualified Brick.Widgets.List as L import Control.Concurrent.QSem import Control.Monad.Logger (LogLevel(..)) +import Data.Aeson import Data.String.Interpolate import Data.Text () import Data.Time @@ -30,7 +32,6 @@ import Lens.Micro import Lens.Micro.TH import Network.HTTP.Client (Manager) import Relude -import qualified Sauron.GraphQL as GraphQL import qualified Text.Show import UnliftIO.Async @@ -164,7 +165,7 @@ type family NodeStatic a where NodeStatic SinglePullT = Issue NodeStatic SingleWorkflowT = WorkflowRun NodeStatic SingleJobT = () - NodeStatic SingleBranchT = Branch + NodeStatic SingleBranchT = (Branch, Maybe BranchWithInfo) NodeStatic SingleCommitT = Commit NodeStatic SingleNotificationT = Notification NodeStatic JobLogGroupT = JobLogGroup @@ -178,7 +179,7 @@ type family NodeState a where NodeState PaginatedReposT = SearchResult Repo NodeState PaginatedBranchesT = V.Vector Branch NodeState OverallBranchesT = () - NodeState PaginatedYourBranchesT = V.Vector Branch + NodeState PaginatedYourBranchesT = (V.Vector Branch, Map Text BranchWithInfo) NodeState PaginatedActiveBranchesT = V.Vector Branch NodeState PaginatedStaleBranchesT = V.Vector Branch NodeState PaginatedNotificationsT = V.Vector Notification @@ -294,6 +295,29 @@ entityDataL f (JobLogGroupNode ed) = JobLogGroupNode <$> f ed entityDataL f (HeadingNode ed) = HeadingNode <$> f ed entityDataL f (RepoNode ed) = RepoNode <$> f ed +-- * Data types beyond "github" package + +data GraphQLPullRequest = GraphQLPullRequest { + prNumber :: Maybe Int + , prTitle :: Maybe Text + , prUrl :: Maybe Text + } deriving (Show, Eq, Generic) +instance FromJSON GraphQLPullRequest where + parseJSON = withObject "GraphQLPullRequest" $ \o -> GraphQLPullRequest + <$> o .:? "number" + <*> o .:? "title" + <*> o .:? "url" + +data BranchWithInfo = BranchWithInfo { + branchWithInfoBranchName :: Text + , branchWithInfoCommitOid :: Maybe Text + , branchWithInfoCommitAuthor :: Maybe Text + , branchWithInfoAuthorEmail :: Maybe Text + , branchWithInfoCommitDate :: Maybe Text + , branchWithInfoCheckStatus :: Maybe Text + , branchWithInfoAssociatedPR :: Maybe GraphQLPullRequest + } deriving (Show, Eq) + -- * Misc data SortBy = @@ -413,7 +437,6 @@ data AppEvent = | TimeUpdated UTCTime | CommentModalEvent CommentModalEvent | LogEntryAdded LogEntry - | BranchDataUpdated (Map Text GraphQL.BranchWithCommit) data CommentModalEvent = CommentSubmitted (Either Error Comment) @@ -471,9 +494,6 @@ data AppState = AppState { , _appColorMode :: V.ColorMode , _appLogs :: Seq LogEntry - - -- Enhanced branch data from GraphQL queries - , _appBranchData :: Map Text GraphQL.BranchWithCommit } diff --git a/app/Sauron/UI/Branch.hs b/app/Sauron/UI/Branch.hs index 27c9670..aa6b030 100644 --- a/app/Sauron/UI/Branch.hs +++ b/app/Sauron/UI/Branch.hs @@ -7,7 +7,6 @@ module Sauron.UI.Branch ( ) where import Brick -import qualified Data.Map as Map import Data.String.Interpolate import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime) @@ -23,16 +22,14 @@ import Sauron.UI.Util.TimeDiff (timeFromNow) instance ListDrawable Fixed 'SingleBranchT where - drawLine appState (EntityData {_static=branch, _state, ..}) = - branchLine _toggled branch appState _state + drawLine appState (EntityData {_static=(branch, maybeBranchData), _state, ..}) = + branchLine _toggled branch maybeBranchData appState _state drawInner _ _ = Nothing -branchLine :: Bool -> Branch -> AppState -> Fetchable (V.Vector Commit) -> Widget n -branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState = vBox [line1, line2] +branchLine :: Bool -> Branch -> Maybe BranchWithInfo -> AppState -> Fetchable (V.Vector Commit) -> Widget n +branchLine toggled' (Branch {branchName, branchCommit}) maybeBranchData appState fetchableState = vBox [line1, line2] where - -- Get enhanced branch data from the app state - maybeBranchData = Map.lookup branchName (_appBranchData appState) line1 = hBox [ withAttr openMarkerAttr $ str (if toggled' then "[-] " else "[+] ") @@ -58,10 +55,10 @@ branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState ] -- Helper function to format commit time from GraphQL data using timeFromNow - formatCommitTime :: Maybe GraphQL.BranchWithCommit -> String + formatCommitTime :: Maybe BranchWithInfo -> String formatCommitTime Nothing = "Unknown" formatCommitTime (Just branchData) = - case GraphQL.commitDate branchData of + case branchWithInfoCommitDate branchData of Nothing -> "Unknown" Just dateStr -> case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of @@ -69,10 +66,10 @@ branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState Just commitTime -> timeFromNow (diffUTCTime (_appNow appState) commitTime) -- Helper function to format check status - formatCheckStatus :: Maybe GraphQL.BranchWithCommit -> String + formatCheckStatus :: Maybe BranchWithInfo -> String formatCheckStatus Nothing = "No checks" formatCheckStatus (Just branchData) = - case GraphQL.checkStatus branchData of + case branchWithInfoCheckStatus branchData of Nothing -> "No checks" Just "SUCCESS" -> "✓ Checks" Just "FAILURE" -> "✗ Failed" @@ -80,10 +77,10 @@ branchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState Just status -> toString status -- Helper function to format PR info - formatPRInfo :: Maybe GraphQL.BranchWithCommit -> String + formatPRInfo :: Maybe BranchWithInfo -> String formatPRInfo Nothing = "No PR" formatPRInfo (Just branchData) = - case GraphQL.associatedPR branchData of + case branchWithInfoAssociatedPR branchData of Nothing -> "No PR" Just pr -> case GraphQL.prNumber pr of Nothing -> "PR: Unknown" diff --git a/app/Sauron/UI/Modals/ZoomModal.hs b/app/Sauron/UI/Modals/ZoomModal.hs index eed6c12..b61c774 100644 --- a/app/Sauron/UI/Modals/ZoomModal.hs +++ b/app/Sauron/UI/Modals/ZoomModal.hs @@ -91,7 +91,7 @@ generateModalTitle (SomeNode inner) = Fetched (job, _) -> "Job: " <> T.unpack (untagName (jobName job)) Fetching (Just (job, _)) -> "Job: " <> T.unpack (untagName (jobName job)) _ -> "Job" - SingleBranchNode (EntityData {_static = Branch {branchName}}) -> + SingleBranchNode (EntityData {_static = (Branch {branchName}, _)}) -> "Branch: " <> T.unpack branchName SingleCommitNode (EntityData {_static = Commit {commitGitCommit = GitCommit {gitCommitMessage}}}) -> "Commit: " <> T.unpack (T.take 50 gitCommitMessage) <> if T.length gitCommitMessage > 50 then "..." else "" diff --git a/app/Sauron/UI/Pagination.hs b/app/Sauron/UI/Pagination.hs index 88e76a5..e6887ec 100644 --- a/app/Sauron/UI/Pagination.hs +++ b/app/Sauron/UI/Pagination.hs @@ -88,9 +88,9 @@ instance ListDrawable Fixed 'OverallBranchesT where instance ListDrawable Fixed 'PaginatedYourBranchesT where drawLine appState ed@(EntityData {..}) = case _state of - Fetched branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches) - Fetching maybeBranches -> case maybeBranches of - Just branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Fetched (branches, _branchData) -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches) + Fetching maybeBranchesData -> case maybeBranchesData of + Just (branches, _branchData) -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) Nothing -> paginatedHeading ed appState "Your branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") NotFetched -> paginatedHeading ed appState "Your branches" (str [i|(not fetched)|]) Errored err -> paginatedHeading ed appState "Your branches" (str [i|(error fetching: #{err})|]) From d23dd86202acee9481ca9d9fc0d18c558ad731bd Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 26 Nov 2025 22:17:37 -0700 Subject: [PATCH 03/13] Fix warnings --- app/Sauron/Event/Open.hs | 3 +- app/Sauron/Expanding.hs | 1 + app/Sauron/Fetch.hs | 64 +++++++++++++++++++------------ app/Sauron/Fix.hs | 1 + app/Sauron/GraphQL.hs | 25 ++++++------ app/Sauron/Types.hs | 22 +++++++---- app/Sauron/UI.hs | 2 + app/Sauron/UI/Branch.hs | 13 ++++++- app/Sauron/UI/Modals/ZoomModal.hs | 4 +- app/Sauron/UI/Pagination.hs | 6 +-- 10 files changed, 91 insertions(+), 50 deletions(-) diff --git a/app/Sauron/Event/Open.hs b/app/Sauron/Event/Open.hs index 6d639d6..44c947d 100644 --- a/app/Sauron/Event/Open.hs +++ b/app/Sauron/Event/Open.hs @@ -39,7 +39,8 @@ getNodeUrl (SingleIssueNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url) getNodeUrl (SinglePullNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) getNodeUrl (SingleWorkflowNode (EntityData {_static=workflowRun})) _ = Just (toString $ getUrl $ workflowRunHtmlUrl workflowRun) getNodeUrl (SingleJobNode (EntityData {_state=(fetchableCurrent -> Just (job, _))})) _ = Just (toString $ getUrl $ jobHtmlUrl job) -getNodeUrl (SingleBranchNode (EntityData {_static=(branch, _)})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchName branch)) +getNodeUrl (SingleBranchNode (EntityData {_static=branch})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchName branch)) +getNodeUrl (SingleBranchWithInfoNode (EntityData {_static=branchInfo})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchWithInfoBranchName branchInfo)) getNodeUrl (SingleCommitNode (EntityData {_static=commit})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/commit/" <> toString (untagName (commitSha commit))) getNodeUrl (RepoNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just repoBaseUrl getNodeUrl _ _ = Nothing diff --git a/app/Sauron/Expanding.hs b/app/Sauron/Expanding.hs index 671f76b..24962de 100644 --- a/app/Sauron/Expanding.hs +++ b/app/Sauron/Expanding.hs @@ -35,6 +35,7 @@ getExpandedList = V.fromList . concatMap expandNodes . V.toList SingleWorkflowNode (EntityData {..}) -> expandTyped _children SingleJobNode (EntityData {..}) -> expandTyped _children SingleBranchNode (EntityData {..}) -> expandTyped _children + SingleBranchWithInfoNode (EntityData {..}) -> expandTyped _children SingleCommitNode (EntityData {..}) -> expandChildless _children SingleNotificationNode (EntityData {..}) -> expandChildless _children JobLogGroupNode (EntityData {..}) -> expandTyped _children diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index 82d47a0..853ef31 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -24,6 +24,7 @@ module Sauron.Fetch ( , fetchActiveBranches , fetchStaleBranches , fetchBranchCommits + , fetchBranchWithInfoCommits , fetchCommitDetails , fetchNotifications @@ -147,7 +148,7 @@ fetchBranches owner name (PaginatedBranchesNode (EntityData {..})) = do writeTVar _pageInfo newPageInfo writeTVar _state (Fetched branches) (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) + SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) fetchYourBranches :: ( MonadReader BaseContext m, MonadIO m @@ -180,15 +181,11 @@ fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do Right branchesWithCommits -> do -- Filter to only branches authored by current user and sort by date let yourBranches = GraphQL.sortBranchesByDate $ GraphQL.filterBranchesByAuthor userName branchesWithCommits - -- Convert GraphQL results to sauron Branch format - let branches = V.fromList $ map graphqlBranchToGithubBranch yourBranches -- Store the enhanced branch data in the node state - let branchDataMap = Map.fromList [(branchWithInfoBranchName branch, branch) | branch <- yourBranches] atomically $ do - writeTVar _state (Fetched (branches, branchDataMap)) - (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> do - let graphqlData = Map.lookup branchName branchDataMap - SingleBranchNode <$> makeEmptyElem bc (branch, graphqlData) ("/tree/" <> branchName) (_depth + 1) + writeTVar _state (Fetched (V.fromList yourBranches)) + (writeTVar _children =<<) $ forM yourBranches $ \branchInfo -> + SingleBranchWithInfoNode <$> makeEmptyElem bc branchInfo ("/tree/" <> branchWithInfoBranchName branchInfo) (_depth + 1) logToModal bc $ "fetchYourBranches: Processing complete, found " <> show (case result of Left _ -> 0 Right branchesWithCommits -> length $ GraphQL.filterBranchesByAuthor userName branchesWithCommits) <> " your branches" @@ -210,9 +207,9 @@ fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = Right (branches, newPageInfo) -> do writeTVar _pageInfo newPageInfo -- For now, return all branches until we implement proper async filtering - writeTVar _state (Fetched branches) - (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) + writeTVar _state (Fetched (V.fromList [])) + (writeTVar _children =<<) $ forM (V.toList branches) $ \(Branch {..}) -> + SingleBranchWithInfoNode <$> makeEmptyElem bc (BranchWithInfo branchName Nothing Nothing Nothing Nothing Nothing Nothing) ("/tree/" <> branchName) (_depth + 1) fetchStaleBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m @@ -231,9 +228,9 @@ fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = d Right (branches, newPageInfo) -> do writeTVar _pageInfo newPageInfo -- For now, return all branches until we implement proper async filtering - writeTVar _state (Fetched branches) - (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> - SingleBranchNode <$> makeEmptyElem bc (branch, Nothing) ("/tree/" <> branchName) (_depth + 1) + writeTVar _state (Fetched (V.fromList [])) + (writeTVar _children =<<) $ forM (V.toList branches) $ \(Branch {..}) -> + SingleBranchWithInfoNode <$> makeEmptyElem bc (BranchWithInfo branchName Nothing Nothing Nothing Nothing Nothing Nothing) ("/tree/" <> branchName) (_depth + 1) fetchOverallBranches :: ( MonadReader BaseContext m, MonadIO m @@ -278,15 +275,15 @@ getAuthToken bc = case auth bc of OAuth token -> Just $ decodeUtf8 token _ -> Nothing -- Only OAuth tokens supported for now --- Convert GraphQL BranchWithInfo to GitHub Branch format -graphqlBranchToGithubBranch :: BranchWithInfo -> Branch -graphqlBranchToGithubBranch BranchWithInfo{..} = Branch - { branchName = branchWithInfoBranchName - , branchCommit = BranchCommit - { branchCommitSha = fromMaybe "unknown" branchWithInfoCommitOid - , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" branchWithInfoCommitOid - } - } +-- TODO: Convert GraphQL BranchWithInfo to GitHub Branch format if needed +-- graphqlBranchToGithubBranch :: BranchWithInfo -> Branch +-- graphqlBranchToGithubBranch BranchWithInfo{..} = Branch +-- { branchName = branchWithInfoBranchName +-- , branchCommit = BranchCommit +-- { branchCommitSha = fromMaybe "unknown" branchWithInfoCommitOid +-- , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" branchWithInfoCommitOid +-- } +-- } -- TODO: Implement filtering functions using background processing or redesigned fetch approach -- The current STM-based approach doesn't allow IO operations in the callback @@ -332,7 +329,7 @@ fetchNotifications (PaginatedNotificationsNode (EntityData {..})) = do fetchBranchCommits :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Node Variable SingleBranchT -> m () -fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=(branch, _graphqlData), ..})) = do +fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=branch, ..})) = do bc <- ask let branchSha = branchCommitSha $ branchCommit branch bracketOnError_ (atomically $ markFetching _state) @@ -346,6 +343,25 @@ fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=(branch, _g (writeTVar _children =<<) $ forM (V.toList commits) $ \commit@(Commit {..}) -> SingleCommitNode <$> makeEmptyElem bc commit ("/commit/" <> T.pack (toString (untagName commitSha))) (_depth + 1) +fetchBranchWithInfoCommits :: ( + MonadReader BaseContext m, MonadIO m, MonadMask m + ) => Name Owner -> Name Repo -> Node Variable SingleBranchWithInfoT -> m () +fetchBranchWithInfoCommits owner name (SingleBranchWithInfoNode (EntityData {_static=branchInfo, ..})) = do + bc <- ask + case branchWithInfoCommitOid branchInfo of + Nothing -> atomically $ writeTVar _state (Errored "No commit OID available for branch with info") + Just commitOid -> do + bracketOnError_ (atomically $ markFetching _state) + (atomically $ writeTVar _state (Errored "Branch commits fetch failed with exception.")) $ + withGithubApiSemaphore (githubWithLogging (commitsWithOptionsForR owner name (FetchAtLeast 10) [CommitQuerySha commitOid])) >>= \case + Left err -> atomically $ do + writeTVar _state (Errored (show err)) + writeTVar _children [] + Right commits -> atomically $ do + writeTVar _state (Fetched commits) + (writeTVar _children =<<) $ forM (V.toList commits) $ \commit@(Commit {..}) -> + SingleCommitNode <$> makeEmptyElem bc commit ("/commit/" <> T.pack (toString (untagName commitSha))) (_depth + 1) + fetchCommitDetails :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Name Commit -> TVar (Fetchable Commit) -> m () diff --git a/app/Sauron/Fix.hs b/app/Sauron/Fix.hs index 8e8caf0..fb1a9b9 100644 --- a/app/Sauron/Fix.hs +++ b/app/Sauron/Fix.hs @@ -50,6 +50,7 @@ fixNode item@(SinglePullNode ed) = fixChildlessNode item ed fixNode item@(SingleWorkflowNode ed) = fixTypedNode item ed fixNode item@(SingleJobNode ed) = fixTypedNode item ed fixNode item@(SingleBranchNode ed) = fixTypedNode item ed +fixNode item@(SingleBranchWithInfoNode ed) = fixTypedNode item ed fixNode item@(SingleCommitNode ed) = fixChildlessNode item ed fixNode item@(SingleNotificationNode ed) = fixChildlessNode item ed fixNode item@(JobLogGroupNode ed) = fixTypedNode item ed diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index dd6a2d1..ba6002d 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -257,15 +257,16 @@ sortBranchesByDate branches = sortBy (comparing (Down . commitDateUtc)) branches parseISODate :: Text -> Maybe UTCTime parseISODate dateStr = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) -filterBranchesByActivity :: UTCTime -> [BranchWithInfo] -> [BranchWithInfo] -filterBranchesByActivity cutoffTime branches = - filter (isBranchActive cutoffTime) branches - where - isBranchActive :: UTCTime -> BranchWithInfo -> Bool - isBranchActive cutoff branch = - case branchWithInfoCommitDate branch of - Nothing -> False - Just dateStr -> - case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of - Nothing -> False - Just commitTime -> commitTime > cutoff +-- TODO: Implement active/stale branch filtering +-- filterBranchesByActivity :: UTCTime -> [BranchWithInfo] -> [BranchWithInfo] +-- filterBranchesByActivity cutoffTime branches = +-- filter (isBranchActive cutoffTime) branches +-- where +-- isBranchActive :: UTCTime -> BranchWithInfo -> Bool +-- isBranchActive cutoff branch = +-- case branchWithInfoCommitDate branch of +-- Nothing -> False +-- Just dateStr -> +-- case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of +-- Nothing -> False +-- Just commitTime -> commitTime > cutoff diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index 90fe6f1..593397d 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -70,6 +70,7 @@ data Node f (a :: NodeTyp) where SingleWorkflowNode :: EntityData f 'SingleWorkflowT -> Node f 'SingleWorkflowT SingleJobNode :: EntityData f 'SingleJobT -> Node f 'SingleJobT SingleBranchNode :: EntityData f 'SingleBranchT -> Node f 'SingleBranchT + SingleBranchWithInfoNode :: EntityData f 'SingleBranchWithInfoT -> Node f 'SingleBranchWithInfoT SingleCommitNode :: EntityData f 'SingleCommitT -> Node f 'SingleCommitT SingleNotificationNode :: EntityData f 'SingleNotificationT -> Node f 'SingleNotificationT JobLogGroupNode :: EntityData f 'JobLogGroupT -> Node f 'JobLogGroupT @@ -94,6 +95,7 @@ data NodeTyp = | SingleWorkflowT | SingleJobT | SingleBranchT + | SingleBranchWithInfoT | SingleCommitT | SingleNotificationT | JobLogGroupT @@ -120,6 +122,7 @@ instance Show (Node f a) where show (SingleWorkflowNode (EntityData {..})) = [i|SingleWorkflowNode<#{_ident}>|] show (SingleJobNode (EntityData {..})) = [i|SingleJobNode<#{_ident}>|] show (SingleBranchNode (EntityData {..})) = [i|SingleBranchNode<#{_ident}>|] + show (SingleBranchWithInfoNode (EntityData {..})) = [i|SingleBranchWithInfoNode<#{_ident}>|] show (SingleCommitNode (EntityData {..})) = [i|SingleCommitNode<#{_ident}>|] show (SingleNotificationNode (EntityData {..})) = [i|SingleNotificationNode<#{_ident}>|] show (JobLogGroupNode (EntityData {..})) = [i|JobLogGroupNode<#{_ident}>|] @@ -165,7 +168,8 @@ type family NodeStatic a where NodeStatic SinglePullT = Issue NodeStatic SingleWorkflowT = WorkflowRun NodeStatic SingleJobT = () - NodeStatic SingleBranchT = (Branch, Maybe BranchWithInfo) + NodeStatic SingleBranchT = Branch + NodeStatic SingleBranchWithInfoT = BranchWithInfo NodeStatic SingleCommitT = Commit NodeStatic SingleNotificationT = Notification NodeStatic JobLogGroupT = JobLogGroup @@ -179,15 +183,16 @@ type family NodeState a where NodeState PaginatedReposT = SearchResult Repo NodeState PaginatedBranchesT = V.Vector Branch NodeState OverallBranchesT = () - NodeState PaginatedYourBranchesT = (V.Vector Branch, Map Text BranchWithInfo) - NodeState PaginatedActiveBranchesT = V.Vector Branch - NodeState PaginatedStaleBranchesT = V.Vector Branch + NodeState PaginatedYourBranchesT = V.Vector BranchWithInfo + NodeState PaginatedActiveBranchesT = V.Vector BranchWithInfo + NodeState PaginatedStaleBranchesT = V.Vector BranchWithInfo NodeState PaginatedNotificationsT = V.Vector Notification NodeState SingleIssueT = V.Vector (Either IssueEvent IssueComment) NodeState SinglePullT = V.Vector (Either IssueEvent IssueComment) NodeState SingleWorkflowT = WithTotalCount Job NodeState SingleJobT = (Job, [JobLogGroup]) NodeState SingleBranchT = V.Vector Commit + NodeState SingleBranchWithInfoT = V.Vector Commit NodeState SingleCommitT = Commit NodeState SingleNotificationT = () NodeState JobLogGroupT = () @@ -201,15 +206,16 @@ type family NodeChildType f a where NodeChildType f PaginatedReposT = Node f RepoT NodeChildType f PaginatedBranchesT = Node f SingleBranchT NodeChildType f OverallBranchesT = SomeNode f - NodeChildType f PaginatedYourBranchesT = Node f SingleBranchT - NodeChildType f PaginatedActiveBranchesT = Node f SingleBranchT - NodeChildType f PaginatedStaleBranchesT = Node f SingleBranchT + NodeChildType f PaginatedYourBranchesT = Node f SingleBranchWithInfoT + NodeChildType f PaginatedActiveBranchesT = Node f SingleBranchWithInfoT + NodeChildType f PaginatedStaleBranchesT = Node f SingleBranchWithInfoT NodeChildType f PaginatedNotificationsT = Node f SingleNotificationT NodeChildType f SingleIssueT = () NodeChildType f SinglePullT = () NodeChildType f SingleWorkflowT = Node f SingleJobT NodeChildType f SingleJobT = Node f JobLogGroupT NodeChildType f SingleBranchT = Node f SingleCommitT + NodeChildType f SingleBranchWithInfoT = Node f SingleCommitT NodeChildType f SingleCommitT = () NodeChildType f SingleNotificationT = () NodeChildType f JobLogGroupT = Node f JobLogGroupT @@ -259,6 +265,7 @@ getExistentialChildrenWrapped node = case node of SingleWorkflowNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) SingleJobNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) SingleBranchNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) + SingleBranchWithInfoNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) JobLogGroupNode ed -> fmap (fmap SomeNode) (readTVar (_children ed)) -- These are leaf nodes with no meaningful children @@ -289,6 +296,7 @@ entityDataL f (SinglePullNode ed) = SinglePullNode <$> f ed entityDataL f (SingleWorkflowNode ed) = SingleWorkflowNode <$> f ed entityDataL f (SingleJobNode ed) = SingleJobNode <$> f ed entityDataL f (SingleBranchNode ed) = SingleBranchNode <$> f ed +entityDataL f (SingleBranchWithInfoNode ed) = SingleBranchWithInfoNode <$> f ed entityDataL f (SingleCommitNode ed) = SingleCommitNode <$> f ed entityDataL f (SingleNotificationNode ed) = SingleNotificationNode <$> f ed entityDataL f (JobLogGroupNode ed) = JobLogGroupNode <$> f ed diff --git a/app/Sauron/UI.hs b/app/Sauron/UI.hs index 8205951..5b4de86 100644 --- a/app/Sauron/UI.hs +++ b/app/Sauron/UI.hs @@ -63,6 +63,7 @@ drawNodeLine appState node = case node of SingleWorkflowNode ed -> drawLine appState ed SingleJobNode ed -> drawLine appState ed SingleBranchNode ed -> drawLine appState ed + SingleBranchWithInfoNode ed -> drawLine appState ed SingleCommitNode ed -> drawLine appState ed SingleNotificationNode ed -> drawLine appState ed JobLogGroupNode ed -> drawLine appState ed @@ -86,6 +87,7 @@ drawNodeInner appState node = case node of SingleWorkflowNode ed -> drawInner appState ed SingleJobNode ed -> drawInner appState ed SingleBranchNode ed -> drawInner appState ed + SingleBranchWithInfoNode ed -> drawInner appState ed SingleCommitNode ed -> drawInner appState ed SingleNotificationNode ed -> drawInner appState ed JobLogGroupNode ed -> drawInner appState ed diff --git a/app/Sauron/UI/Branch.hs b/app/Sauron/UI/Branch.hs index aa6b030..0e9dd6f 100644 --- a/app/Sauron/UI/Branch.hs +++ b/app/Sauron/UI/Branch.hs @@ -22,8 +22,17 @@ import Sauron.UI.Util.TimeDiff (timeFromNow) instance ListDrawable Fixed 'SingleBranchT where - drawLine appState (EntityData {_static=(branch, maybeBranchData), _state, ..}) = - branchLine _toggled branch maybeBranchData appState _state + drawLine appState (EntityData {_static=branch, _state, ..}) = + branchLine _toggled branch Nothing appState _state + + drawInner _ _ = Nothing + +instance ListDrawable Fixed 'SingleBranchWithInfoT where + drawLine appState (EntityData {_static=branchInfo, _state, ..}) = + let branchCommit = BranchCommit (fromMaybe "" (branchWithInfoCommitOid branchInfo)) + (URL "") -- placeholder URL + branch = Branch (branchWithInfoBranchName branchInfo) branchCommit + in branchLine _toggled branch (Just branchInfo) appState _state drawInner _ _ = Nothing diff --git a/app/Sauron/UI/Modals/ZoomModal.hs b/app/Sauron/UI/Modals/ZoomModal.hs index b61c774..bba9215 100644 --- a/app/Sauron/UI/Modals/ZoomModal.hs +++ b/app/Sauron/UI/Modals/ZoomModal.hs @@ -91,8 +91,10 @@ generateModalTitle (SomeNode inner) = Fetched (job, _) -> "Job: " <> T.unpack (untagName (jobName job)) Fetching (Just (job, _)) -> "Job: " <> T.unpack (untagName (jobName job)) _ -> "Job" - SingleBranchNode (EntityData {_static = (Branch {branchName}, _)}) -> + SingleBranchNode (EntityData {_static = Branch {branchName}}) -> "Branch: " <> T.unpack branchName + SingleBranchWithInfoNode (EntityData {_static = branchInfo}) -> + "Branch: " <> T.unpack (branchWithInfoBranchName branchInfo) SingleCommitNode (EntityData {_static = Commit {commitGitCommit = GitCommit {gitCommitMessage}}}) -> "Commit: " <> T.unpack (T.take 50 gitCommitMessage) <> if T.length gitCommitMessage > 50 then "..." else "" SingleNotificationNode (EntityData {_static = Notification {notificationSubject = Subject {subjectTitle}}}) -> diff --git a/app/Sauron/UI/Pagination.hs b/app/Sauron/UI/Pagination.hs index e6887ec..88e76a5 100644 --- a/app/Sauron/UI/Pagination.hs +++ b/app/Sauron/UI/Pagination.hs @@ -88,9 +88,9 @@ instance ListDrawable Fixed 'OverallBranchesT where instance ListDrawable Fixed 'PaginatedYourBranchesT where drawLine appState ed@(EntityData {..}) = case _state of - Fetched (branches, _branchData) -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches) - Fetching maybeBranchesData -> case maybeBranchesData of - Just (branches, _branchData) -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) + Fetched branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches) + Fetching maybeBranches -> case maybeBranches of + Just branches -> paginatedHeading ed appState "Your branches" (countWidget _pageInfo branches <+> str " " <+> getQuarterCircleSpinner (_appAnimationCounter appState)) Nothing -> paginatedHeading ed appState "Your branches" (str "(" <+> getQuarterCircleSpinner (_appAnimationCounter appState) <+> str ")") NotFetched -> paginatedHeading ed appState "Your branches" (str [i|(not fetched)|]) Errored err -> paginatedHeading ed appState "Your branches" (str [i|(error fetching: #{err})|]) From ddcc57e5aba3305c603086d429604acf66734290 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 26 Nov 2025 23:26:32 -0700 Subject: [PATCH 04/13] Branch bugfixes and refactoring --- app/Sauron/Actions.hs | 2 + app/Sauron/Fetch.hs | 248 ++++++++++++++------------------------- app/Sauron/Fetch/Core.hs | 46 +++++++- app/Sauron/GraphQL.hs | 51 +++++--- 4 files changed, 171 insertions(+), 176 deletions(-) diff --git a/app/Sauron/Actions.hs b/app/Sauron/Actions.hs index cb93a66..772922b 100644 --- a/app/Sauron/Actions.hs +++ b/app/Sauron/Actions.hs @@ -79,6 +79,8 @@ refresh bc item@(SingleJobNode (EntityData {_state})) parents@(findRepoParent -> liftIO $ void $ startJobHealthCheckIfNeeded bc item parents refresh bc item@(SingleBranchNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = liftIO $ void $ async $ liftIO $ runReaderT (fetchBranchCommits owner name item) bc +refresh bc item@(SingleBranchWithInfoNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = + liftIO $ void $ async $ liftIO $ runReaderT (fetchBranchWithInfoCommits owner name item) bc refresh bc (SingleCommitNode (EntityData {_static=commit, _state})) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = liftIO $ void $ async $ liftIO $ runReaderT (fetchCommitDetails owner name (commitSha commit) _state) bc refresh _ (SingleNotificationNode _) _ = return () diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index 853ef31..8504535 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -36,17 +36,15 @@ module Sauron.Fetch ( , makeEmptyElem ) where -import Brick.BChan (writeBChan) import Control.Exception.Safe (bracketOnError_) import Control.Monad (foldM) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class -import Control.Monad.Logger (LogLevel(..)) import qualified Data.Map.Strict as Map import Data.String.Interpolate import qualified Data.Text as T import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime(..), getCurrentTime) +import Data.Time.Clock (UTCTime(..)) import qualified Data.Vector as V import GitHub import Network.HTTP.Conduit hiding (Proxy) @@ -150,87 +148,105 @@ fetchBranches owner name (PaginatedBranchesNode (EntityData {..})) = do (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) -fetchYourBranches :: ( - MonadReader BaseContext m, MonadIO m - ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () -fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do +fetchBranchesWithFilter :: ( + MonadReader BaseContext m, MonadIO m, MonadMask m + ) + => Name Owner + -> Name Repo + -> TVar (Fetchable (V.Vector BranchWithInfo)) + -> TVar [Node Variable SingleBranchWithInfoT] + -> TVar PageInfo + -> Int + -> Text + -> ([BranchWithInfo] -> [BranchWithInfo]) + -> Text + -> m () +fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPrefix filterFn logSuffix = do bc <- ask - -- Use GraphQL for efficient "Your branches" query - liftIO $ logToModal bc "fetchYourBranches: Starting GraphQL query" - case getAuthToken bc of - Nothing -> liftIO $ do - logToModal bc "fetchYourBranches: No auth token available" - atomically $ writeTVar _state (Errored "No auth token available for GraphQL query") - Just authToken -> do - liftIO $ logToModal bc $ "fetchYourBranches: Got auth token: " <> T.take 10 authToken <> "..." - currentUserName <- liftIO $ getUserName bc - case currentUserName of - Nothing -> liftIO $ do - logToModal bc "fetchYourBranches: Could not get current user name" - atomically $ writeTVar _state (Errored "Could not get current user name") - Just userName -> liftIO $ do - logToModal bc $ "fetchYourBranches: Got username: " <> userName - logToModal bc $ "fetchYourBranches: Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name + bracketOnError_ (atomically $ markFetching stateVar) + (atomically $ writeTVar stateVar (Errored $ logPrefix <> " fetch failed with exception.")) $ do + logToModal bc $ logPrefix <> ": Starting GraphQL query" + case getAuthToken bc of + Nothing -> liftIO $ do + logToModal bc $ logPrefix <> ": No auth token available" + atomically $ writeTVar stateVar (Errored "No auth token available for GraphQL query") + Just authToken -> do + logToModal bc $ logPrefix <> ": Got auth token: " <> T.take 10 authToken <> "..." + liftIO $ do + logToModal bc $ logPrefix <> ": Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name + -- Read current page info to determine how many branches to fetch + currentPageInfo <- readTVarIO pageInfoVar + let branchesToFetch = pageInfoCurrentPage currentPageInfo * pageSize -- Fetch branches with commit info using GraphQL - result <- GraphQL.queryBranchesWithCommits (logToModal bc) authToken (toPathPart owner) (toPathPart name) 10 + result <- GraphQL.queryBranchesWithCommits (logToModal bc) authToken (toPathPart owner) (toPathPart name) branchesToFetch case result of Left err -> atomically $ do - writeTVar _state (Errored $ toText err) - writeTVar _children [] + writeTVar stateVar (Errored $ toText err) + writeTVar childrenVar [] Right branchesWithCommits -> do - -- Filter to only branches authored by current user and sort by date - let yourBranches = GraphQL.sortBranchesByDate $ GraphQL.filterBranchesByAuthor userName branchesWithCommits + -- Apply the provided filter function and sort by date + let filteredBranches = GraphQL.sortBranchesByDate $ filterFn branchesWithCommits + let currentPage = pageInfoCurrentPage currentPageInfo + let totalBranches = length filteredBranches + let totalPages = (totalBranches + pageSize - 1) `div` pageSize -- Ceiling division + let newPageInfo = PageInfo { + pageInfoCurrentPage = currentPage + , pageInfoFirstPage = if totalPages > 0 then Just 1 else Nothing + , pageInfoPrevPage = if currentPage > 1 then Just (currentPage - 1) else Nothing + , pageInfoNextPage = if currentPage < totalPages then Just (currentPage + 1) else Nothing + , pageInfoLastPage = if totalPages > 0 then Just totalPages else Nothing + } -- Store the enhanced branch data in the node state atomically $ do - writeTVar _state (Fetched (V.fromList yourBranches)) - (writeTVar _children =<<) $ forM yourBranches $ \branchInfo -> - SingleBranchWithInfoNode <$> makeEmptyElem bc branchInfo ("/tree/" <> branchWithInfoBranchName branchInfo) (_depth + 1) - logToModal bc $ "fetchYourBranches: Processing complete, found " <> show (case result of + writeTVar pageInfoVar newPageInfo + writeTVar stateVar (Fetched (V.fromList filteredBranches)) + (writeTVar childrenVar =<<) $ forM filteredBranches $ \branchInfo -> + SingleBranchWithInfoNode <$> makeEmptyElem bc branchInfo ("/tree/" <> branchWithInfoBranchName branchInfo) (depth' + 1) + logToModal bc $ logPrefix <> ": Processing complete, found " <> show (case result of Left _ -> 0 - Right branchesWithCommits -> length $ GraphQL.filterBranchesByAuthor userName branchesWithCommits) <> " your branches" + Right branchesWithCommits -> length $ filterFn branchesWithCommits) <> " " <> logSuffix + where + getAuthToken :: BaseContext -> Maybe Text + getAuthToken bc = case auth bc of + OAuth token -> Just $ decodeUtf8 token + _ -> Nothing -- Only OAuth tokens supported for now -fetchActiveBranches :: ( +fetchYourBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m - ) => Name Owner -> Name Repo -> Node Variable PaginatedActiveBranchesT -> m () -fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = do + ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () +fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do bc <- ask - _currentTime <- liftIO getCurrentTime - -- let threeMonthsAgo = addUTCTime (-90 * 24 * 60 * 60) currentTime -- 90 days + currentUserName <- liftIO $ getUserName bc + case currentUserName of + Nothing -> liftIO $ do + logToModal bc "fetchYourBranches: Could not get current user name" + atomically $ writeTVar _state (Errored "Could not get current user name") + Just userName -> + fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchYourBranches" + (GraphQL.filterBranchesByAuthor userName) "your branches" + where + getUserName :: BaseContext -> IO (Maybe Text) + getUserName bc = do + -- Get the current authenticated user's name from GitHub API + result <- runReaderT (withGithubApiSemaphore (githubWithLogging userInfoCurrentR)) bc + case result of + Left _err -> return Nothing + Right user -> return $ Just $ toPathPart $ userLogin user - -- For now, since filtering requires async IO, just fetch all branches - -- TODO: Implement efficient filtering with background worker or streaming approach - fetchPaginated'' (branchesForR owner name) _pageInfo _state $ \case - Left err -> do - writeTVar _state (Errored (show err)) - writeTVar _children [] - Right (branches, newPageInfo) -> do - writeTVar _pageInfo newPageInfo - -- For now, return all branches until we implement proper async filtering - writeTVar _state (Fetched (V.fromList [])) - (writeTVar _children =<<) $ forM (V.toList branches) $ \(Branch {..}) -> - SingleBranchWithInfoNode <$> makeEmptyElem bc (BranchWithInfo branchName Nothing Nothing Nothing Nothing Nothing Nothing) ("/tree/" <> branchName) (_depth + 1) +fetchActiveBranches :: ( + MonadReader BaseContext m, MonadIO m, MonadMask m + ) => Name Owner -> Name Repo -> Node Variable PaginatedActiveBranchesT -> m () +fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = + fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchActiveBranches" + (GraphQL.filterBranchesByActivity 90) "active branches" fetchStaleBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Node Variable PaginatedStaleBranchesT -> m () -fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = do - bc <- ask - _currentTime <- liftIO getCurrentTime - -- let threeMonthsAgo = addUTCTime (-90 * 24 * 60 * 60) currentTime -- 90 days - - -- For now, since filtering requires async IO, just fetch all branches - -- TODO: Implement efficient filtering with background worker or streaming approach - fetchPaginated'' (branchesForR owner name) _pageInfo _state $ \case - Left err -> do - writeTVar _state (Errored (show err)) - writeTVar _children [] - Right (branches, newPageInfo) -> do - writeTVar _pageInfo newPageInfo - -- For now, return all branches until we implement proper async filtering - writeTVar _state (Fetched (V.fromList [])) - (writeTVar _children =<<) $ forM (V.toList branches) $ \(Branch {..}) -> - SingleBranchWithInfoNode <$> makeEmptyElem bc (BranchWithInfo branchName Nothing Nothing Nothing Nothing Nothing Nothing) ("/tree/" <> branchName) (_depth + 1) +fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = + fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchStaleBranches" + (GraphQL.filterBranchesByInactivity 90) "stale branches" fetchOverallBranches :: ( MonadReader BaseContext m, MonadIO m @@ -242,75 +258,16 @@ fetchOverallBranches _owner _name (OverallBranchesNode (EntityData {..})) = do yourBranchesEd <- makeEmptyElem bc () "your-branches" (_depth + 1) activeBranchesEd <- makeEmptyElem bc () "active-branches" (_depth + 1) staleBranchesEd <- makeEmptyElem bc () "stale-branches" (_depth + 1) - let nodes = [ SomeNode (PaginatedYourBranchesNode yourBranchesEd) - , SomeNode (PaginatedActiveBranchesNode activeBranchesEd) - , SomeNode (PaginatedStaleBranchesNode staleBranchesEd) - ] - return nodes + return [ + SomeNode (PaginatedYourBranchesNode yourBranchesEd) + , SomeNode (PaginatedActiveBranchesNode activeBranchesEd) + , SomeNode (PaginatedStaleBranchesNode staleBranchesEd) + ] atomically $ do writeTVar _state (Fetched ()) writeTVar _children categorizedChildren --- Helper functions for branch categorization - --- Helper function to log to the modal -logToModal :: BaseContext -> Text -> IO () -logToModal bc msg = do - now <- getCurrentTime - let logEntry = LogEntry now LevelInfo msg - writeBChan (eventChan bc) (LogEntryAdded logEntry) - -getUserName :: BaseContext -> IO (Maybe Text) -getUserName bc = do - -- Get the current authenticated user's name from GitHub API - result <- runReaderT (withGithubApiSemaphore (githubWithLogging userInfoCurrentR)) bc - case result of - Left _err -> return Nothing - Right user -> return $ Just $ toPathPart $ userLogin user - --- Helper function to extract auth token for GraphQL queries -getAuthToken :: BaseContext -> Maybe Text -getAuthToken bc = case auth bc of - OAuth token -> Just $ decodeUtf8 token - _ -> Nothing -- Only OAuth tokens supported for now - --- TODO: Convert GraphQL BranchWithInfo to GitHub Branch format if needed --- graphqlBranchToGithubBranch :: BranchWithInfo -> Branch --- graphqlBranchToGithubBranch BranchWithInfo{..} = Branch --- { branchName = branchWithInfoBranchName --- , branchCommit = BranchCommit --- { branchCommitSha = fromMaybe "unknown" branchWithInfoCommitOid --- , branchCommitUrl = URL $ "https://github.com/commit/" <> fromMaybe "unknown" branchWithInfoCommitOid --- } --- } - --- TODO: Implement filtering functions using background processing or redesigned fetch approach --- The current STM-based approach doesn't allow IO operations in the callback --- filterBranchesByUser :: BaseContext -> Name Owner -> Name Repo -> Maybe Text -> V.Vector Branch -> IO (V.Vector Branch) --- filterBranchesByUser _bc _owner _name _userName branches = return branches -- Return all branches for now - --- filterBranchesByActivity :: BaseContext -> Name Owner -> Name Repo -> UTCTime -> V.Vector Branch -> Bool -> IO (V.Vector Branch) --- filterBranchesByActivity _bc _owner _name _cutoffTime branches _includeRecent = return branches -- Return all branches for now - --- Example of using the new branch filtering API for protected branches --- fetchProtectedBranches :: ( --- MonadReader BaseContext m, MonadIO m, MonadMask m --- ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () --- fetchProtectedBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do --- bc <- ask --- -- Use branchesWithOptionsForR to fetch only protected branches --- let fetchWithProtectedFilter = \fetchCount -> branchesWithOptionsForR owner name fetchCount [BranchQueryProtected True] --- fetchPaginated'' fetchWithProtectedFilter _pageInfo _state $ \case --- Left err -> do --- writeTVar _state (Errored (show err)) --- writeTVar _children [] --- Right (branches, newPageInfo) -> do --- writeTVar _pageInfo newPageInfo --- writeTVar _state (Fetched branches) --- (writeTVar _children =<<) $ forM (V.toList branches) $ \branch@(Branch {..}) -> --- SingleBranchNode <$> makeEmptyElem bc branch ("/tree/" <> branchName) (_depth + 1) - fetchNotifications :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Node Variable PaginatedNotificationsT -> m () @@ -557,35 +514,6 @@ fetchJob owner name jobId (SingleJobNode (EntityData {_state})) = do -- * Util -makeEmptyElem :: BaseContext -> NodeStatic a -> Text -> Int -> STM (EntityData Variable a) -makeEmptyElem (BaseContext {getIdentifierSTM}) typ' urlSuffix' depth' = do - stateVar <- newTVar NotFetched - ident' <- getIdentifierSTM - toggledVar <- newTVar False - childrenVar <- newTVar [] - searchVar <- newTVar $ SearchNone - pageInfoVar <- newTVar emptyPageInfo - healthCheckVar <- newTVar NotFetched - healthCheckThreadVar <- newTVar Nothing - return $ EntityData { - _static = typ' - , _state = stateVar - - , _urlSuffix = urlSuffix' - - , _toggled = toggledVar - , _children = childrenVar - - , _search = searchVar - , _pageInfo = pageInfoVar - - , _healthCheck = healthCheckVar - , _healthCheckThread = healthCheckThreadVar - - , _depth = depth' - , _ident = ident' -} - createJobStepNode :: BaseContext -> Int -> [JobLogGroup] -> JobStep -> STM (Node Variable 'JobLogGroupT) createJobStepNode bc depth' allLogs jobStep = do let stepTitle = untagName (jobStepName jobStep) diff --git a/app/Sauron/Fetch/Core.hs b/app/Sauron/Fetch/Core.hs index 96497c3..4a8f5b1 100644 --- a/app/Sauron/Fetch/Core.hs +++ b/app/Sauron/Fetch/Core.hs @@ -1,16 +1,23 @@ {-# LANGUAGE TypeFamilies #-} module Sauron.Fetch.Core ( - fetchPaginated'', - pageSize + fetchPaginated'' + , pageSize + + , makeEmptyElem + + , logToModal ) where +import Brick.BChan (writeBChan) import Control.Exception.Safe (bracketOnError_) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class +import Control.Monad.Logger import Control.Monad.Reader import Data.Aeson import qualified Data.List as L +import Data.Time import GitHub import Network.HTTP.Client (responseBody) import Network.HTTP.Types.URI (QueryItem, parseQuery) @@ -58,3 +65,38 @@ fetchPaginated'' mkReq pageInfoVar stateVar cb = do } cb $ Right (responseBody x, pgInfo) + +makeEmptyElem :: BaseContext -> NodeStatic a -> Text -> Int -> STM (EntityData Variable a) +makeEmptyElem (BaseContext {getIdentifierSTM}) typ' urlSuffix' depth' = do + stateVar <- newTVar NotFetched + ident' <- getIdentifierSTM + toggledVar <- newTVar False + childrenVar <- newTVar [] + searchVar <- newTVar $ SearchNone + pageInfoVar <- newTVar emptyPageInfo + healthCheckVar <- newTVar NotFetched + healthCheckThreadVar <- newTVar Nothing + return $ EntityData { + _static = typ' + , _state = stateVar + + , _urlSuffix = urlSuffix' + + , _toggled = toggledVar + , _children = childrenVar + + , _search = searchVar + , _pageInfo = pageInfoVar + + , _healthCheck = healthCheckVar + , _healthCheckThread = healthCheckThreadVar + + , _depth = depth' + , _ident = ident' +} + +logToModal :: MonadIO m => BaseContext -> Text -> m () +logToModal bc msg = do + now <- liftIO getCurrentTime + let logEntry = LogEntry now LevelInfo msg + liftIO $ writeBChan (eventChan bc) (LogEntryAdded logEntry) diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index ba6002d..05c4fac 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -5,6 +5,8 @@ module Sauron.GraphQL ( queryBranchesWithCommits , sortBranchesByDate , filterBranchesByAuthor + , filterBranchesByActivity + , filterBranchesByInactivity , prNumber ) where @@ -12,12 +14,13 @@ import Control.Exception.Safe (try) import Data.Aeson import Data.String.Interpolate import qualified Data.Text as T -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) import Data.Time.Format (parseTimeM, defaultTimeLocale) import Network.HTTP.Conduit (responseTimeoutMicro) import Network.HTTP.Simple import Relude import Sauron.Types hiding (PageInfo) +import System.IO.Unsafe (unsafePerformIO) -- GitHub GraphQL API endpoint githubGraphQLEndpoint :: String @@ -257,16 +260,36 @@ sortBranchesByDate branches = sortBy (comparing (Down . commitDateUtc)) branches parseISODate :: Text -> Maybe UTCTime parseISODate dateStr = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) --- TODO: Implement active/stale branch filtering --- filterBranchesByActivity :: UTCTime -> [BranchWithInfo] -> [BranchWithInfo] --- filterBranchesByActivity cutoffTime branches = --- filter (isBranchActive cutoffTime) branches --- where --- isBranchActive :: UTCTime -> BranchWithInfo -> Bool --- isBranchActive cutoff branch = --- case branchWithInfoCommitDate branch of --- Nothing -> False --- Just dateStr -> --- case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of --- Nothing -> False --- Just commitTime -> commitTime > cutoff +-- Filter branches that have activity within the specified number of days +filterBranchesByActivity :: Int -> [BranchWithInfo] -> [BranchWithInfo] +filterBranchesByActivity daysCutoff branches = unsafePerformIO $ do + currentTime <- getCurrentTime + return $ filter (isBranchActive currentTime daysCutoff) branches + where + isBranchActive :: UTCTime -> Int -> BranchWithInfo -> Bool + isBranchActive currentTime days branch = + case branchWithInfoCommitDate branch of + Nothing -> False + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of + Nothing -> False + Just commitTime -> + let cutoffTime = addUTCTime (fromIntegral (-days * 24 * 60 * 60)) currentTime + in commitTime > cutoffTime + +-- Filter branches that have NO activity within the specified number of days (stale branches) +filterBranchesByInactivity :: Int -> [BranchWithInfo] -> [BranchWithInfo] +filterBranchesByInactivity daysCutoff branches = unsafePerformIO $ do + currentTime <- getCurrentTime + return $ filter (isBranchStale currentTime daysCutoff) branches + where + isBranchStale :: UTCTime -> Int -> BranchWithInfo -> Bool + isBranchStale currentTime days branch = + case branchWithInfoCommitDate branch of + Nothing -> True -- No commit date means it's probably stale + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) of + Nothing -> True -- Can't parse date, consider stale + Just commitTime -> + let cutoffTime = addUTCTime (fromIntegral (-days * 24 * 60 * 60)) currentTime + in commitTime <= cutoffTime From b3ceb6ef3f5b8af1fead9e6907a0ae18ab6ca28e Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Thu, 27 Nov 2025 23:17:27 -0700 Subject: [PATCH 05/13] Render ahead/behind --- app/Sauron/Fetch.hs | 28 +++++--- app/Sauron/GraphQL.hs | 147 ++++++++++++++++++++++++++++------------ app/Sauron/Types.hs | 2 + app/Sauron/UI/Branch.hs | 10 ++- 4 files changed, 133 insertions(+), 54 deletions(-) diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index 8504535..7bc9197 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -175,9 +175,14 @@ fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPr logToModal bc $ logPrefix <> ": Got auth token: " <> T.take 10 authToken <> "..." liftIO $ do logToModal bc $ logPrefix <> ": Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name - -- Read current page info to determine how many branches to fetch + -- Read current page info to determine pagination currentPageInfo <- readTVarIO pageInfoVar - let branchesToFetch = pageInfoCurrentPage currentPageInfo * pageSize + let currentPage = pageInfoCurrentPage currentPageInfo + + -- Fetch a substantial number of branches to enable client-side filtering and pagination + -- We fetch more than we need to allow for filtering (many branches may be filtered out) + let branchesToFetch = max 100 (currentPage * pageSize * 3) -- Fetch at least 100, or enough for 3 pages worth + -- Fetch branches with commit info using GraphQL result <- GraphQL.queryBranchesWithCommits (logToModal bc) authToken (toPathPart owner) (toPathPart name) branchesToFetch case result of @@ -186,10 +191,14 @@ fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPr writeTVar childrenVar [] Right branchesWithCommits -> do -- Apply the provided filter function and sort by date - let filteredBranches = GraphQL.sortBranchesByDate $ filterFn branchesWithCommits - let currentPage = pageInfoCurrentPage currentPageInfo - let totalBranches = length filteredBranches - let totalPages = (totalBranches + pageSize - 1) `div` pageSize -- Ceiling division + let allFilteredBranches = GraphQL.sortBranchesByDate $ filterFn branchesWithCommits + let totalBranches = length allFilteredBranches + let totalPages = max 1 $ (totalBranches + pageSize - 1) `div` pageSize -- Ceiling division, at least 1 page + + -- Calculate the slice for the current page + let startIdx = (currentPage - 1) * pageSize + let currentPageBranches = take pageSize $ drop startIdx allFilteredBranches + let newPageInfo = PageInfo { pageInfoCurrentPage = currentPage , pageInfoFirstPage = if totalPages > 0 then Just 1 else Nothing @@ -197,11 +206,12 @@ fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPr , pageInfoNextPage = if currentPage < totalPages then Just (currentPage + 1) else Nothing , pageInfoLastPage = if totalPages > 0 then Just totalPages else Nothing } - -- Store the enhanced branch data in the node state + + -- Store only the current page's branches in the node state atomically $ do writeTVar pageInfoVar newPageInfo - writeTVar stateVar (Fetched (V.fromList filteredBranches)) - (writeTVar childrenVar =<<) $ forM filteredBranches $ \branchInfo -> + writeTVar stateVar (Fetched (V.fromList currentPageBranches)) + (writeTVar childrenVar =<<) $ forM currentPageBranches $ \branchInfo -> SingleBranchWithInfoNode <$> makeEmptyElem bc branchInfo ("/tree/" <> branchWithInfoBranchName branchInfo) (depth' + 1) logToModal bc $ logPrefix <> ": Processing complete, found " <> show (case result of Left _ -> 0 diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index 05c4fac..10844c3 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Sauron.GraphQL ( queryBranchesWithCommits @@ -22,14 +22,13 @@ import Relude import Sauron.Types hiding (PageInfo) import System.IO.Unsafe (unsafePerformIO) --- GitHub GraphQL API endpoint + githubGraphQLEndpoint :: String githubGraphQLEndpoint = "https://api.github.com/graphql" --- GraphQL query to get repository branches with commit information and associated pull requests getBranchesQuery :: Text getBranchesQuery = [i| - query GetBranchesWithCommits($owner: String!, $name: String!, $first: Int!) { + query GetBranchesWithCommits($owner: String!, $name: String!, $first: Int!, $defaultBranch: String!) { repository(owner: $owner, name: $name) { defaultBranchRef { name } refs(refPrefix: "refs/heads/", first: $first) { @@ -52,6 +51,10 @@ getBranchesQuery = [i| } } } + compare(headRef: $defaultBranch) { + aheadBy + behindBy + } associatedPullRequests(states: OPEN, first: 1) { nodes { number @@ -73,7 +76,6 @@ data BranchResponse = BranchResponse { data' :: Maybe RepositoryData , errors :: Maybe [GraphQLError] } deriving (Show, Generic) - instance FromJSON BranchResponse where parseJSON = withObject "BranchResponse" $ \o -> BranchResponse <$> o .:? "data" @@ -82,20 +84,17 @@ instance FromJSON BranchResponse where data RepositoryData = RepositoryData { repository :: Maybe Repository } deriving (Show, Generic) - instance FromJSON RepositoryData data Repository = Repository { refs :: Maybe Refs , defaultBranchRef :: Maybe DefaultBranchRef } deriving (Show, Generic) - instance FromJSON Repository data DefaultBranchRef = DefaultBranchRef { defaultBranchName :: Maybe Text } deriving (Show, Generic) - instance FromJSON DefaultBranchRef where parseJSON = withObject "DefaultBranchRef" $ \o -> DefaultBranchRef <$> o .:? "name" @@ -103,37 +102,44 @@ data Refs = Refs { nodes :: Maybe [RefNode] , pageInfo :: Maybe PageInfo } deriving (Show, Generic) - instance FromJSON Refs data RefNode = RefNode { name :: Text , target :: Maybe Target + , branchCompare :: Maybe BranchComparison , associatedPullRequests :: Maybe AssociatedPRs } deriving (Show, Generic) - -instance FromJSON RefNode +instance FromJSON RefNode where + parseJSON = withObject "RefNode" $ \o -> RefNode + <$> o .: "name" + <*> o .:? "target" + <*> o .:? "compare" + <*> o .:? "associatedPullRequests" data AssociatedPRs = AssociatedPRs { prNodes :: Maybe [GraphQLPullRequest] } deriving (Show, Generic) - instance FromJSON AssociatedPRs where parseJSON = withObject "AssociatedPRs" $ \o -> AssociatedPRs <$> o .:? "nodes" +data BranchComparison = BranchComparison { + aheadBy :: Maybe Int + , behindBy :: Maybe Int + } deriving (Show, Generic) +instance FromJSON BranchComparison + data Target = Target { oid :: Maybe Text , author :: Maybe Author , committedDate :: Maybe Text , statusCheckRollup :: Maybe StatusCheckRollup } deriving (Show, Generic) - instance FromJSON Target data StatusCheckRollup = StatusCheckRollup { statusState :: Maybe Text } deriving (Show, Generic) - instance FromJSON StatusCheckRollup where parseJSON = withObject "StatusCheckRollup" $ \o -> StatusCheckRollup <$> o .:? "state" @@ -168,12 +174,14 @@ data BranchVariables = BranchVariables { owner :: Text , repositoryName :: Text -- 'name' is a reserved keyword , first :: Int + , defaultBranch :: Text } deriving (Show, Generic) instance ToJSON BranchVariables where - toJSON (BranchVariables owner' name' first') = object [ + toJSON (BranchVariables owner' name' first' defaultBranch') = object [ "owner" .= owner' , "name" .= name' , "first" .= first' + , "defaultBranch" .= defaultBranch' ] data GraphQLRequest = GraphQLRequest { @@ -182,61 +190,110 @@ data GraphQLRequest = GraphQLRequest { } deriving (Show, Generic) instance ToJSON GraphQLRequest +-- First, let's create a simple query to get just the default branch name +getDefaultBranchQuery :: Text +getDefaultBranchQuery = [i| + query GetDefaultBranch($owner: String!, $name: String!) { + repository(owner: $owner, name: $name) { + defaultBranchRef { name } + } + } + |] + queryBranchesWithCommits :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Int -> m (Either Text [BranchWithInfo]) queryBranchesWithCommits debugFn authToken owner' repoName first' = liftIO $ do debugFn $ "GraphQL query for " <> owner' <> "/" <> repoName <> " (first " <> show first' <> ")" - let requestPayload = GraphQLRequest - { query = getBranchesQuery - , variables = BranchVariables owner' repoName first' + + -- First, get the default branch name + let defaultBranchPayload = GraphQLRequest + { query = getDefaultBranchQuery + , variables = BranchVariables owner' repoName 1 "main" -- default branch field is not used in this query } - debugFn $ "GraphQL query: " <> T.take 200 getBranchesQuery - result <- try $ do - debugFn "Creating HTTP request" + defaultBranchResult <- try $ do + debugFn "Getting default branch name" initialRequest <- parseRequest githubGraphQLEndpoint let httpRequest = setRequestMethod "POST" $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 authToken] $ setRequestHeader "Content-Type" ["application/json"] $ setRequestHeader "User-Agent" ["sauron-app"] - $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) -- 30 second timeout - $ setRequestBodyJSON requestPayload + $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) + $ setRequestBodyJSON defaultBranchPayload $ initialRequest - - debugFn "Sending GraphQL HTTP request" response <- httpJSON httpRequest - debugFn "HTTP response received, parsing JSON" let body = getResponseBody response :: BranchResponse - debugFn "GraphQL response parsed successfully" return body - case result of + case defaultBranchResult of Left (ex :: SomeException) -> do - debugFn $ "GraphQL HTTP request failed: " <> T.pack (show ex) - return $ Left $ "HTTP request failed: " <> T.pack (show ex) - Right body -> do - debugFn "Processing GraphQL response body" - case (data' body, errors body) of + debugFn $ "Default branch query failed: " <> T.pack (show ex) + return $ Left $ "Default branch query failed: " <> T.pack (show ex) + Right defaultBranchBody -> do + case (data' defaultBranchBody, errors defaultBranchBody) of (Just repoData, Nothing) -> do - debugFn "GraphQL success, processing data" - case repository repoData >>= refs >>= nodes of - Just refNodes -> do - debugFn $ "Found " <> show (length refNodes) <> " branches" - return $ Right $ mapMaybe refNodeToBranch refNodes - Nothing -> do - debugFn "No branches found in response" - return $ Right [] + let defaultBranchName' = fromMaybe "main" $ repository repoData >>= defaultBranchRef >>= defaultBranchName + debugFn $ "Found default branch: " <> defaultBranchName' + + -- Now query branches with comparison to default branch + let requestPayload = GraphQLRequest + { query = getBranchesQuery + , variables = BranchVariables owner' repoName first' defaultBranchName' + } + debugFn $ "GraphQL query: " <> T.take 200 getBranchesQuery + + result <- try $ do + debugFn "Creating HTTP request for branches with comparison" + initialRequest <- parseRequest githubGraphQLEndpoint + let httpRequest = setRequestMethod "POST" + $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 authToken] + $ setRequestHeader "Content-Type" ["application/json"] + $ setRequestHeader "User-Agent" ["sauron-app"] + $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) + $ setRequestBodyJSON requestPayload + $ initialRequest + + debugFn "Sending GraphQL HTTP request" + response <- httpJSON httpRequest + debugFn "HTTP response received, parsing JSON" + let body = getResponseBody response :: BranchResponse + debugFn "GraphQL response parsed successfully" + return body + + case result of + Left (ex :: SomeException) -> do + debugFn $ "GraphQL HTTP request failed: " <> T.pack (show ex) + return $ Left $ "HTTP request failed: " <> T.pack (show ex) + Right body -> do + debugFn "Processing GraphQL response body" + case (data' body, errors body) of + (Just repoData, Nothing) -> do + debugFn "GraphQL success, processing data" + case repository repoData >>= refs >>= nodes of + Just refNodes -> do + debugFn $ "Found " <> show (length refNodes) <> " branches" + return $ Right $ mapMaybe refNodeToBranch refNodes + Nothing -> do + debugFn "No branches found in response" + return $ Right [] + (_, Just errs) -> do + debugFn $ "GraphQL errors: " <> T.intercalate ", " (map message errs) + return $ Left $ T.intercalate ", " (map message errs) + (Nothing, Nothing) -> do + debugFn "No data returned from GitHub" + return $ Left "No data returned from GitHub" (_, Just errs) -> do - debugFn $ "GraphQL errors: " <> T.intercalate ", " (map message errs) + debugFn $ "Default branch query errors: " <> T.intercalate ", " (map message errs) return $ Left $ T.intercalate ", " (map message errs) (Nothing, Nothing) -> do - debugFn "No data returned from GitHub" - return $ Left "No data returned from GitHub" + debugFn "No data returned from GitHub for default branch query" + return $ Left "No data returned from GitHub for default branch query" refNodeToBranch :: RefNode -> Maybe BranchWithInfo refNodeToBranch refNode = do let branchName = name refNode target' <- target refNode let prInfo = associatedPullRequests refNode >>= prNodes >>= viaNonEmpty head + let compareInfo = branchCompare refNode return $ BranchWithInfo { branchWithInfoBranchName = branchName , branchWithInfoCommitOid = oid target' @@ -245,6 +302,8 @@ refNodeToBranch refNode = do , branchWithInfoCommitDate = committedDate target' , branchWithInfoCheckStatus = statusCheckRollup target' >>= statusState , branchWithInfoAssociatedPR = prInfo + , branchWithInfoAheadBy = compareInfo >>= aheadBy + , branchWithInfoBehindBy = compareInfo >>= behindBy } filterBranchesByAuthor :: Text -> [BranchWithInfo] -> [BranchWithInfo] diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index 593397d..fbda2b2 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -324,6 +324,8 @@ data BranchWithInfo = BranchWithInfo { , branchWithInfoCommitDate :: Maybe Text , branchWithInfoCheckStatus :: Maybe Text , branchWithInfoAssociatedPR :: Maybe GraphQLPullRequest + , branchWithInfoAheadBy :: Maybe Int + , branchWithInfoBehindBy :: Maybe Int } deriving (Show, Eq) -- * Misc diff --git a/app/Sauron/UI/Branch.hs b/app/Sauron/UI/Branch.hs index 0e9dd6f..a7845a3 100644 --- a/app/Sauron/UI/Branch.hs +++ b/app/Sauron/UI/Branch.hs @@ -49,7 +49,7 @@ branchLine toggled' (Branch {branchName, branchCommit}) maybeBranchData appState , hLimitPercent 12 $ padRight Max $ str $ formatCheckStatus maybeBranchData , hLimitPercent 10 $ - padRight Max $ str "↑0 ↓0" -- Placeholder for ahead/behind + padRight Max $ str $ formatAheadBehind maybeBranchData , hLimitPercent 15 $ padRight Max $ str $ formatPRInfo maybeBranchData , fetchableQuarterCircleSpinner (_appAnimationCounter appState) fetchableState @@ -94,3 +94,11 @@ branchLine toggled' (Branch {branchName, branchCommit}) maybeBranchData appState Just pr -> case GraphQL.prNumber pr of Nothing -> "PR: Unknown" Just num -> "PR #" <> show num + + -- Helper function to format ahead/behind counts + formatAheadBehind :: Maybe BranchWithInfo -> String + formatAheadBehind Nothing = "↑? ↓?" + formatAheadBehind (Just branchData) = + let ahead = fromMaybe 0 (branchWithInfoAheadBy branchData) + behind = fromMaybe 0 (branchWithInfoBehindBy branchData) + in "↑" <> show ahead <> " ↓" <> show behind From db3f2be0bdb7adcc47302f053effa7c53984dd0f Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 28 Nov 2025 02:28:07 -0700 Subject: [PATCH 06/13] Use repoDefaultBranch --- app/Sauron/Actions.hs | 21 +++-- app/Sauron/Fetch.hs | 26 +++--- app/Sauron/GraphQL.hs | 193 ++++++++++++++++++++---------------------- 3 files changed, 119 insertions(+), 121 deletions(-) diff --git a/app/Sauron/Actions.hs b/app/Sauron/Actions.hs index 772922b..1a09564 100644 --- a/app/Sauron/Actions.hs +++ b/app/Sauron/Actions.hs @@ -51,12 +51,21 @@ refresh bc item@(PaginatedBranchesNode _) (findRepoParent -> Just (RepoNode (Ent liftIO $ void $ async $ liftIO $ runReaderT (fetchBranches owner name item) bc refresh bc item@(OverallBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = liftIO $ void $ async $ liftIO $ runReaderT (fetchOverallBranches owner name item) bc -refresh bc item@(PaginatedYourBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = - liftIO $ void $ async $ liftIO $ runReaderT (fetchYourBranches owner name item) bc -refresh bc item@(PaginatedActiveBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = - liftIO $ void $ async $ liftIO $ runReaderT (fetchActiveBranches owner name item) bc -refresh bc item@(PaginatedStaleBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name)}))) = - liftIO $ void $ async $ liftIO $ runReaderT (fetchStaleBranches owner name item) bc +refresh bc item@(PaginatedYourBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name), _state}))) = + readTVarIO _state >>= \case + Fetched (Repo {..}) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchYourBranches owner name repoDefaultBranch item) bc + Fetching (Just (Repo {..})) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchYourBranches owner name repoDefaultBranch item) bc + _ -> return () +refresh bc item@(PaginatedActiveBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name), _state}))) = + readTVarIO _state >>= \case + Fetched (Repo {..}) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchActiveBranches owner name repoDefaultBranch item) bc + Fetching (Just (Repo {..})) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchActiveBranches owner name repoDefaultBranch item) bc + _ -> return () +refresh bc item@(PaginatedStaleBranchesNode _) (findRepoParent -> Just (RepoNode (EntityData {_static=(owner, name), _state}))) = + readTVarIO _state >>= \case + Fetched (Repo {..}) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchStaleBranches owner name repoDefaultBranch item) bc + Fetching (Just (Repo {..})) -> liftIO $ void $ async $ liftIO $ runReaderT (fetchStaleBranches owner name repoDefaultBranch item) bc + _ -> return () refresh bc item@(PaginatedNotificationsNode _) _parents = liftIO $ void $ async $ liftIO $ runReaderT (fetchNotifications item) bc refresh bc item@(PaginatedReposNode (EntityData {})) _parents = diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index 7bc9197..dd2e79e 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -153,6 +153,7 @@ fetchBranchesWithFilter :: ( ) => Name Owner -> Name Repo + -> Maybe Text -> TVar (Fetchable (V.Vector BranchWithInfo)) -> TVar [Node Variable SingleBranchWithInfoT] -> TVar PageInfo @@ -161,7 +162,7 @@ fetchBranchesWithFilter :: ( -> ([BranchWithInfo] -> [BranchWithInfo]) -> Text -> m () -fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPrefix filterFn logSuffix = do +fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageInfoVar depth' logPrefix filterFn logSuffix = do bc <- ask bracketOnError_ (atomically $ markFetching stateVar) @@ -184,7 +185,7 @@ fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPr let branchesToFetch = max 100 (currentPage * pageSize * 3) -- Fetch at least 100, or enough for 3 pages worth -- Fetch branches with commit info using GraphQL - result <- GraphQL.queryBranchesWithCommits (logToModal bc) authToken (toPathPart owner) (toPathPart name) branchesToFetch + result <- GraphQL.queryBranchesWithInfos (logToModal bc) authToken (toPathPart owner) (toPathPart name) repoDefaultBranch branchesToFetch case result of Left err -> atomically $ do writeTVar stateVar (Errored $ toText err) @@ -224,16 +225,15 @@ fetchBranchesWithFilter owner name stateVar childrenVar pageInfoVar depth' logPr fetchYourBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m - ) => Name Owner -> Name Repo -> Node Variable PaginatedYourBranchesT -> m () -fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do + ) => Name Owner -> Name Repo -> Maybe Text -> Node Variable PaginatedYourBranchesT -> m () +fetchYourBranches owner name repoDefaultBranch (PaginatedYourBranchesNode (EntityData {..})) = do bc <- ask - currentUserName <- liftIO $ getUserName bc - case currentUserName of + liftIO (getUserName bc) >>= \case Nothing -> liftIO $ do logToModal bc "fetchYourBranches: Could not get current user name" atomically $ writeTVar _state (Errored "Could not get current user name") Just userName -> - fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchYourBranches" + fetchBranchesWithFilter owner name repoDefaultBranch _state _children _pageInfo _depth "fetchYourBranches" (GraphQL.filterBranchesByAuthor userName) "your branches" where getUserName :: BaseContext -> IO (Maybe Text) @@ -246,16 +246,16 @@ fetchYourBranches owner name (PaginatedYourBranchesNode (EntityData {..})) = do fetchActiveBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m - ) => Name Owner -> Name Repo -> Node Variable PaginatedActiveBranchesT -> m () -fetchActiveBranches owner name (PaginatedActiveBranchesNode (EntityData {..})) = - fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchActiveBranches" + ) => Name Owner -> Name Repo -> Maybe Text -> Node Variable PaginatedActiveBranchesT -> m () +fetchActiveBranches owner name repoDefaultBranch (PaginatedActiveBranchesNode (EntityData {..})) = + fetchBranchesWithFilter owner name repoDefaultBranch _state _children _pageInfo _depth "fetchActiveBranches" (GraphQL.filterBranchesByActivity 90) "active branches" fetchStaleBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m - ) => Name Owner -> Name Repo -> Node Variable PaginatedStaleBranchesT -> m () -fetchStaleBranches owner name (PaginatedStaleBranchesNode (EntityData {..})) = - fetchBranchesWithFilter owner name _state _children _pageInfo _depth "fetchStaleBranches" + ) => Name Owner -> Name Repo -> Maybe Text -> Node Variable PaginatedStaleBranchesT -> m () +fetchStaleBranches owner name repoDefaultBranch (PaginatedStaleBranchesNode (EntityData {..})) = + fetchBranchesWithFilter owner name repoDefaultBranch _state _children _pageInfo _depth "fetchStaleBranches" (GraphQL.filterBranchesByInactivity 90) "stale branches" fetchOverallBranches :: ( diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index 10844c3..13a433a 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Sauron.GraphQL ( - queryBranchesWithCommits + queryBranchesWithInfos , sortBranchesByDate , filterBranchesByAuthor , filterBranchesByActivity @@ -30,7 +30,12 @@ getBranchesQuery :: Text getBranchesQuery = [i| query GetBranchesWithCommits($owner: String!, $name: String!, $first: Int!, $defaultBranch: String!) { repository(owner: $owner, name: $name) { - defaultBranchRef { name } + defaultBranchRef { + name + target { + oid + } + } refs(refPrefix: "refs/heads/", first: $first) { nodes { name @@ -55,19 +60,20 @@ getBranchesQuery = [i| aheadBy behindBy } - associatedPullRequests(states: OPEN, first: 1) { - nodes { - number - title - url - } - } } pageInfo { hasNextPage endCursor } } + pullRequests(states: OPEN, first: 100) { + nodes { + number + title + url + headRefName + } + } } } |] @@ -89,14 +95,18 @@ instance FromJSON RepositoryData data Repository = Repository { refs :: Maybe Refs , defaultBranchRef :: Maybe DefaultBranchRef + , pullRequests :: Maybe PullRequests } deriving (Show, Generic) instance FromJSON Repository data DefaultBranchRef = DefaultBranchRef { defaultBranchName :: Maybe Text + , defaultBranchTarget :: Maybe Target } deriving (Show, Generic) instance FromJSON DefaultBranchRef where - parseJSON = withObject "DefaultBranchRef" $ \o -> DefaultBranchRef <$> o .:? "name" + parseJSON = withObject "DefaultBranchRef" $ \o -> DefaultBranchRef + <$> o .:? "name" + <*> o .:? "target" data Refs = Refs { nodes :: Maybe [RefNode] @@ -104,24 +114,35 @@ data Refs = Refs { } deriving (Show, Generic) instance FromJSON Refs +data PullRequests = PullRequests { + prNodes :: Maybe [GraphQLPullRequestWithHead] + } deriving (Show, Generic) +instance FromJSON PullRequests where + parseJSON = withObject "PullRequests" $ \o -> PullRequests <$> o .:? "nodes" + +data GraphQLPullRequestWithHead = GraphQLPullRequestWithHead { + prWithHeadNumber :: Maybe Int + , prWithHeadTitle :: Maybe Text + , prWithHeadUrl :: Maybe Text + , prWithHeadRefName :: Maybe Text + } deriving (Show, Generic) +instance FromJSON GraphQLPullRequestWithHead where + parseJSON = withObject "GraphQLPullRequestWithHead" $ \o -> GraphQLPullRequestWithHead + <$> o .:? "number" + <*> o .:? "title" + <*> o .:? "url" + <*> o .:? "headRefName" + data RefNode = RefNode { name :: Text , target :: Maybe Target , branchCompare :: Maybe BranchComparison - , associatedPullRequests :: Maybe AssociatedPRs } deriving (Show, Generic) instance FromJSON RefNode where parseJSON = withObject "RefNode" $ \o -> RefNode <$> o .: "name" <*> o .:? "target" <*> o .:? "compare" - <*> o .:? "associatedPullRequests" - -data AssociatedPRs = AssociatedPRs { - prNodes :: Maybe [GraphQLPullRequest] - } deriving (Show, Generic) -instance FromJSON AssociatedPRs where - parseJSON = withObject "AssociatedPRs" $ \o -> AssociatedPRs <$> o .:? "nodes" data BranchComparison = BranchComparison { aheadBy :: Maybe Int @@ -190,110 +211,68 @@ data GraphQLRequest = GraphQLRequest { } deriving (Show, Generic) instance ToJSON GraphQLRequest --- First, let's create a simple query to get just the default branch name -getDefaultBranchQuery :: Text -getDefaultBranchQuery = [i| - query GetDefaultBranch($owner: String!, $name: String!) { - repository(owner: $owner, name: $name) { - defaultBranchRef { name } - } - } - |] -queryBranchesWithCommits :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Int -> m (Either Text [BranchWithInfo]) -queryBranchesWithCommits debugFn authToken owner' repoName first' = liftIO $ do +queryBranchesWithInfos :: MonadIO m => (Text -> IO ()) -> Text -> Text -> Text -> Maybe Text -> Int -> m (Either Text [BranchWithInfo]) +queryBranchesWithInfos debugFn authToken owner' repoName repoDefaultBranch first' = liftIO $ do debugFn $ "GraphQL query for " <> owner' <> "/" <> repoName <> " (first " <> show first' <> ")" - -- First, get the default branch name - let defaultBranchPayload = GraphQLRequest - { query = getDefaultBranchQuery - , variables = BranchVariables owner' repoName 1 "main" -- default branch field is not used in this query + let defaultBranch = fromMaybe "main" repoDefaultBranch + let requestPayload = GraphQLRequest { + query = getBranchesQuery + , variables = BranchVariables owner' repoName first' defaultBranch } - defaultBranchResult <- try $ do - debugFn "Getting default branch name" + result :: Either SomeException BranchResponse <- try $ do initialRequest <- parseRequest githubGraphQLEndpoint let httpRequest = setRequestMethod "POST" $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 authToken] $ setRequestHeader "Content-Type" ["application/json"] $ setRequestHeader "User-Agent" ["sauron-app"] $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) - $ setRequestBodyJSON defaultBranchPayload + $ setRequestBodyJSON requestPayload $ initialRequest - response <- httpJSON httpRequest - let body = getResponseBody response :: BranchResponse - return body - case defaultBranchResult of + getResponseBody <$> httpJSON httpRequest + + case result of Left (ex :: SomeException) -> do - debugFn $ "Default branch query failed: " <> T.pack (show ex) - return $ Left $ "Default branch query failed: " <> T.pack (show ex) - Right defaultBranchBody -> do - case (data' defaultBranchBody, errors defaultBranchBody) of + debugFn $ "GraphQL HTTP request failed: " <> T.pack (show ex) + return $ Left $ "HTTP request failed: " <> T.pack (show ex) + Right body -> do + debugFn "Processing GraphQL response body" + case (data' body, errors body) of (Just repoData, Nothing) -> do - let defaultBranchName' = fromMaybe "main" $ repository repoData >>= defaultBranchRef >>= defaultBranchName - debugFn $ "Found default branch: " <> defaultBranchName' - - -- Now query branches with comparison to default branch - let requestPayload = GraphQLRequest - { query = getBranchesQuery - , variables = BranchVariables owner' repoName first' defaultBranchName' - } - debugFn $ "GraphQL query: " <> T.take 200 getBranchesQuery - - result <- try $ do - debugFn "Creating HTTP request for branches with comparison" - initialRequest <- parseRequest githubGraphQLEndpoint - let httpRequest = setRequestMethod "POST" - $ setRequestHeader "Authorization" ["Bearer " <> encodeUtf8 authToken] - $ setRequestHeader "Content-Type" ["application/json"] - $ setRequestHeader "User-Agent" ["sauron-app"] - $ setRequestResponseTimeout (responseTimeoutMicro (30 * 1000000)) - $ setRequestBodyJSON requestPayload - $ initialRequest - - debugFn "Sending GraphQL HTTP request" - response <- httpJSON httpRequest - debugFn "HTTP response received, parsing JSON" - let body = getResponseBody response :: BranchResponse - debugFn "GraphQL response parsed successfully" - return body - - case result of - Left (ex :: SomeException) -> do - debugFn $ "GraphQL HTTP request failed: " <> T.pack (show ex) - return $ Left $ "HTTP request failed: " <> T.pack (show ex) - Right body -> do - debugFn "Processing GraphQL response body" - case (data' body, errors body) of - (Just repoData, Nothing) -> do - debugFn "GraphQL success, processing data" - case repository repoData >>= refs >>= nodes of - Just refNodes -> do - debugFn $ "Found " <> show (length refNodes) <> " branches" - return $ Right $ mapMaybe refNodeToBranch refNodes - Nothing -> do - debugFn "No branches found in response" - return $ Right [] - (_, Just errs) -> do - debugFn $ "GraphQL errors: " <> T.intercalate ", " (map message errs) - return $ Left $ T.intercalate ", " (map message errs) - (Nothing, Nothing) -> do - debugFn "No data returned from GitHub" - return $ Left "No data returned from GitHub" + case (repository repoData >>= refs >>= nodes, repository repoData >>= pullRequests >>= prNodes) of + (Just refNodes, maybePullRequests) -> do + let pullRequestList = fromMaybe [] maybePullRequests + debugFn $ "Found " <> show (length refNodes) <> " branches and " <> show (length pullRequestList) <> " pull requests" + return $ Right $ mapMaybe (refNodeToBranchWithComparison defaultBranch pullRequestList) refNodes + (Nothing, _) -> do + debugFn "No branches found in response" + return $ Right [] (_, Just errs) -> do - debugFn $ "Default branch query errors: " <> T.intercalate ", " (map message errs) + debugFn $ "GraphQL errors: " <> T.intercalate ", " (map message errs) return $ Left $ T.intercalate ", " (map message errs) (Nothing, Nothing) -> do - debugFn "No data returned from GitHub for default branch query" - return $ Left "No data returned from GitHub for default branch query" + debugFn "No data returned from GitHub" + return $ Left "No data returned from GitHub" -refNodeToBranch :: RefNode -> Maybe BranchWithInfo -refNodeToBranch refNode = do +refNodeToBranchWithComparison :: Text -> [GraphQLPullRequestWithHead] -> RefNode -> Maybe BranchWithInfo +refNodeToBranchWithComparison defaultBranchName pullRequests refNode = do let branchName = name refNode target' <- target refNode - let prInfo = associatedPullRequests refNode >>= prNodes >>= viaNonEmpty head + let prInfo = findPullRequestForBranch branchName pullRequests let compareInfo = branchCompare refNode + + -- Extract ahead/behind counts from the GraphQL comparison + let (aheadCount, behindCount) = case compareInfo of + Just comparison -> (aheadBy comparison, behindBy comparison) + Nothing -> + -- Fallback: if this is the default branch, it's up to date + if branchName == defaultBranchName + then (Just 0, Just 0) + else (Nothing, Nothing) + return $ BranchWithInfo { branchWithInfoBranchName = branchName , branchWithInfoCommitOid = oid target' @@ -302,9 +281,19 @@ refNodeToBranch refNode = do , branchWithInfoCommitDate = committedDate target' , branchWithInfoCheckStatus = statusCheckRollup target' >>= statusState , branchWithInfoAssociatedPR = prInfo - , branchWithInfoAheadBy = compareInfo >>= aheadBy - , branchWithInfoBehindBy = compareInfo >>= behindBy + , branchWithInfoAheadBy = aheadCount + , branchWithInfoBehindBy = behindCount + } + +findPullRequestForBranch :: Text -> [GraphQLPullRequestWithHead] -> Maybe GraphQLPullRequest +findPullRequestForBranch branchName pullRequests = + case find (\pr -> prWithHeadRefName pr == Just branchName) pullRequests of + Just prWithHead -> Just $ GraphQLPullRequest { + prNumber = prWithHeadNumber prWithHead + , prTitle = prWithHeadTitle prWithHead + , prUrl = prWithHeadUrl prWithHead } + Nothing -> Nothing filterBranchesByAuthor :: Text -> [BranchWithInfo] -> [BranchWithInfo] filterBranchesByAuthor currentUser branches = From 6735502b7feae0bf7f1b698ca15f88d6bec73b53 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 2 Dec 2025 20:31:51 -0800 Subject: [PATCH 07/13] Separate out Sauron.UI.BranchWithInfo --- app/Sauron/UI.hs | 1 + app/Sauron/UI/Branch.hs | 75 ++----------------------- app/Sauron/UI/BranchWithInfo.hs | 98 +++++++++++++++++++++++++++++++++ sauron.cabal | 1 + 4 files changed, 105 insertions(+), 70 deletions(-) create mode 100644 app/Sauron/UI/BranchWithInfo.hs diff --git a/app/Sauron/UI.hs b/app/Sauron/UI.hs index 5b4de86..0b155c8 100644 --- a/app/Sauron/UI.hs +++ b/app/Sauron/UI.hs @@ -16,6 +16,7 @@ import Data.String.Interpolate import Relude import Sauron.Types import Sauron.UI.Branch () +import Sauron.UI.BranchWithInfo () import Sauron.UI.Commit () import Sauron.UI.Issue () import Sauron.UI.Job () diff --git a/app/Sauron/UI/Branch.hs b/app/Sauron/UI/Branch.hs index a7845a3..72e82ca 100644 --- a/app/Sauron/UI/Branch.hs +++ b/app/Sauron/UI/Branch.hs @@ -2,56 +2,31 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Sauron.UI.Branch ( - branchLine - ) where +module Sauron.UI.Branch () where import Brick import Data.String.Interpolate -import qualified Data.Text as T -import Data.Time.Clock (UTCTime, diffUTCTime) -import Data.Time.Format (parseTimeM, defaultTimeLocale) import qualified Data.Vector as V import GitHub import Relude -import qualified Sauron.GraphQL as GraphQL import Sauron.Types import Sauron.UI.AttrMap import Sauron.UI.Statuses (fetchableQuarterCircleSpinner) -import Sauron.UI.Util.TimeDiff (timeFromNow) instance ListDrawable Fixed 'SingleBranchT where drawLine appState (EntityData {_static=branch, _state, ..}) = - branchLine _toggled branch Nothing appState _state + simpleBranchLine _toggled branch appState _state drawInner _ _ = Nothing -instance ListDrawable Fixed 'SingleBranchWithInfoT where - drawLine appState (EntityData {_static=branchInfo, _state, ..}) = - let branchCommit = BranchCommit (fromMaybe "" (branchWithInfoCommitOid branchInfo)) - (URL "") -- placeholder URL - branch = Branch (branchWithInfoBranchName branchInfo) branchCommit - in branchLine _toggled branch (Just branchInfo) appState _state - - drawInner _ _ = Nothing - -branchLine :: Bool -> Branch -> Maybe BranchWithInfo -> AppState -> Fetchable (V.Vector Commit) -> Widget n -branchLine toggled' (Branch {branchName, branchCommit}) maybeBranchData appState fetchableState = vBox [line1, line2] +simpleBranchLine :: Bool -> Branch -> AppState -> Fetchable (V.Vector Commit) -> Widget n +simpleBranchLine toggled' (Branch {branchName, branchCommit}) appState fetchableState = vBox [line1, line2] where - line1 = hBox [ withAttr openMarkerAttr $ str (if toggled' then "[-] " else "[+] ") - , hLimitPercent 30 $ withAttr branchAttr $ + , hLimitPercent 40 $ withAttr branchAttr $ padRight Max $ txt branchName - , hLimitPercent 15 $ - padRight Max $ str $ formatCommitTime maybeBranchData - , hLimitPercent 12 $ - padRight Max $ str $ formatCheckStatus maybeBranchData - , hLimitPercent 10 $ - padRight Max $ str $ formatAheadBehind maybeBranchData - , hLimitPercent 15 $ - padRight Max $ str $ formatPRInfo maybeBranchData , fetchableQuarterCircleSpinner (_appAnimationCounter appState) fetchableState , padLeft Max $ case fetchableState of Fetched commits -> str [i|(#{V.length commits} commits)|] @@ -62,43 +37,3 @@ branchLine toggled' (Branch {branchName, branchCommit}) maybeBranchData appState str "Latest commit " , withAttr hashAttr $ str $ take 7 $ toString $ branchCommitSha branchCommit ] - - -- Helper function to format commit time from GraphQL data using timeFromNow - formatCommitTime :: Maybe BranchWithInfo -> String - formatCommitTime Nothing = "Unknown" - formatCommitTime (Just branchData) = - case branchWithInfoCommitDate branchData of - Nothing -> "Unknown" - Just dateStr -> - case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of - Nothing -> toString $ T.take 10 dateStr -- Fallback to raw date - Just commitTime -> timeFromNow (diffUTCTime (_appNow appState) commitTime) - - -- Helper function to format check status - formatCheckStatus :: Maybe BranchWithInfo -> String - formatCheckStatus Nothing = "No checks" - formatCheckStatus (Just branchData) = - case branchWithInfoCheckStatus branchData of - Nothing -> "No checks" - Just "SUCCESS" -> "✓ Checks" - Just "FAILURE" -> "✗ Failed" - Just "PENDING" -> "⏳ Running" - Just status -> toString status - - -- Helper function to format PR info - formatPRInfo :: Maybe BranchWithInfo -> String - formatPRInfo Nothing = "No PR" - formatPRInfo (Just branchData) = - case branchWithInfoAssociatedPR branchData of - Nothing -> "No PR" - Just pr -> case GraphQL.prNumber pr of - Nothing -> "PR: Unknown" - Just num -> "PR #" <> show num - - -- Helper function to format ahead/behind counts - formatAheadBehind :: Maybe BranchWithInfo -> String - formatAheadBehind Nothing = "↑? ↓?" - formatAheadBehind (Just branchData) = - let ahead = fromMaybe 0 (branchWithInfoAheadBy branchData) - behind = fromMaybe 0 (branchWithInfoBehindBy branchData) - in "↑" <> show ahead <> " ↓" <> show behind diff --git a/app/Sauron/UI/BranchWithInfo.hs b/app/Sauron/UI/BranchWithInfo.hs new file mode 100644 index 0000000..df83f9c --- /dev/null +++ b/app/Sauron/UI/BranchWithInfo.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Sauron.UI.BranchWithInfo () where + +import Brick +import Data.String.Interpolate +import qualified Data.Text as T +import Data.Time.Clock (UTCTime, diffUTCTime) +import Data.Time.Format (parseTimeM, defaultTimeLocale) +import qualified Data.Vector as V +import GitHub +import Relude +import qualified Sauron.GraphQL as GraphQL +import Sauron.Types +import Sauron.UI.AttrMap +import Sauron.UI.Statuses (fetchableQuarterCircleSpinner) +import Sauron.UI.Util.TimeDiff (timeFromNow) + + +instance ListDrawable Fixed 'SingleBranchWithInfoT where + drawLine appState (EntityData {_static=branchInfo, _state, ..}) = + let branchCommit = BranchCommit (fromMaybe "" (branchWithInfoCommitOid branchInfo)) + (URL "") -- placeholder URL + branch = Branch (branchWithInfoBranchName branchInfo) branchCommit + in branchLineWithInfo _toggled branch branchInfo appState _state + + drawInner _ _ = Nothing + +branchLineWithInfo :: Bool -> Branch -> BranchWithInfo -> AppState -> Fetchable (V.Vector Commit) -> Widget n +branchLineWithInfo toggled' (Branch {branchName, branchCommit}) branchData appState fetchableState = vBox [line1, line2] + where + + line1 = hBox [ + withAttr openMarkerAttr $ str (if toggled' then "[-] " else "[+] ") + , hLimitPercent 30 $ withAttr branchAttr $ + padRight Max $ txt branchName + , hLimitPercent 15 $ + padRight Max $ str $ formatCommitTime branchData + , hLimitPercent 12 $ + padRight Max $ formatCheckStatus branchData + , hLimitPercent 10 $ + padRight Max $ formatAheadBehind branchData + , hLimitPercent 15 $ + padRight Max $ str $ formatPRInfo branchData + , fetchableQuarterCircleSpinner (_appAnimationCounter appState) fetchableState + , padLeft Max $ case fetchableState of + Fetched commits -> str [i|(#{V.length commits} commits)|] + _ -> withAttr normalAttr $ str "branch" + ] + + line2 = padRight Max $ padLeft (Pad 4) $ hBox [ + str "Latest commit " + , withAttr hashAttr $ str $ take 7 $ toString $ branchCommitSha branchCommit + ] + + -- Helper function to format commit time from GraphQL data using timeFromNow + formatCommitTime :: BranchWithInfo -> String + formatCommitTime branchInfo = + case branchWithInfoCommitDate branchInfo of + Nothing -> "Unknown" + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of + Nothing -> toString $ T.take 10 dateStr -- Fallback to raw date + Just commitTime -> timeFromNow (diffUTCTime (_appNow appState) commitTime) + + -- Helper function to format check status with colors + formatCheckStatus :: BranchWithInfo -> Widget n + formatCheckStatus branchInfo = + case branchWithInfoCheckStatus branchInfo of + Nothing -> str "No checks" + Just "SUCCESS" -> hBox [withAttr greenCheckAttr $ str "✓", str " Checks"] + Just "FAILURE" -> hBox [withAttr redXAttr $ str "✗", str " Failed"] + Just "PENDING" -> hBox [withAttr queuedAttr $ str "⏳", str " Running"] + Just status -> str $ toString status + + -- Helper function to format PR info + formatPRInfo :: BranchWithInfo -> String + formatPRInfo branchInfo = + case branchWithInfoAssociatedPR branchInfo of + Nothing -> "No PR" + Just pr -> case GraphQL.prNumber pr of + Nothing -> "PR: Unknown" + Just num -> "PR #" <> show num + + -- Helper function to format ahead/behind counts with colors + formatAheadBehind :: BranchWithInfo -> Widget n + formatAheadBehind branchInfo = + let ahead = fromMaybe 0 (branchWithInfoAheadBy branchInfo) + behind = fromMaybe 0 (branchWithInfoBehindBy branchInfo) + aheadWidget = if ahead > 0 + then hBox [withAttr greenCheckAttr $ str "↑", str $ " " <> show ahead] + else str "↑ 0" + behindWidget = if behind > 0 + then hBox [withAttr queuedAttr $ str "↓", str $ " " <> show behind] + else str "↓ 0" + in hBox [aheadWidget, str " ", behindWidget] diff --git a/sauron.cabal b/sauron.cabal index e9dd853..b839b3e 100644 --- a/sauron.cabal +++ b/sauron.cabal @@ -59,6 +59,7 @@ executable sauron Sauron.UI.Border Sauron.UI.BottomBar Sauron.UI.Branch + Sauron.UI.BranchWithInfo Sauron.UI.Commit Sauron.UI.Event Sauron.UI.Issue From 670af7ec8754aab2548f0b6ea3467ac33ca20bf6 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 3 Dec 2025 17:33:00 -0800 Subject: [PATCH 08/13] BranchWithInfo columns widths looking good --- app/Sauron/Event/Open.hs | 2 +- app/Sauron/Fetch.hs | 21 ++++- app/Sauron/Types.hs | 9 +- app/Sauron/UI/BranchWithInfo.hs | 133 +++++++++++++++++------------- app/Sauron/UI/Modals/ZoomModal.hs | 2 +- 5 files changed, 103 insertions(+), 64 deletions(-) diff --git a/app/Sauron/Event/Open.hs b/app/Sauron/Event/Open.hs index 44c947d..b6400c5 100644 --- a/app/Sauron/Event/Open.hs +++ b/app/Sauron/Event/Open.hs @@ -40,7 +40,7 @@ getNodeUrl (SinglePullNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)} getNodeUrl (SingleWorkflowNode (EntityData {_static=workflowRun})) _ = Just (toString $ getUrl $ workflowRunHtmlUrl workflowRun) getNodeUrl (SingleJobNode (EntityData {_state=(fetchableCurrent -> Just (job, _))})) _ = Just (toString $ getUrl $ jobHtmlUrl job) getNodeUrl (SingleBranchNode (EntityData {_static=branch})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchName branch)) -getNodeUrl (SingleBranchWithInfoNode (EntityData {_static=branchInfo})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchWithInfoBranchName branchInfo)) +getNodeUrl (SingleBranchWithInfoNode (EntityData {_static=(branchInfo, _columnWidths)})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/tree/" <> toString (branchWithInfoBranchName branchInfo)) getNodeUrl (SingleCommitNode (EntityData {_static=commit})) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/commit/" <> toString (untagName (commitSha commit))) getNodeUrl (RepoNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just repoBaseUrl getNodeUrl _ _ = Nothing diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index dd2e79e..b0a1a27 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -40,11 +40,12 @@ import Control.Exception.Safe (bracketOnError_) import Control.Monad (foldM) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class +import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.String.Interpolate import qualified Data.Text as T import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime(..)) +import Data.Time.Clock (UTCTime(..), getCurrentTime) import qualified Data.Vector as V import GitHub import Network.HTTP.Conduit hiding (Proxy) @@ -55,6 +56,7 @@ import Sauron.Fetch.Core import Sauron.Fetch.ParseJobLogs import qualified Sauron.GraphQL as GraphQL import Sauron.Types +import Sauron.UI.BranchWithInfo (formatCommitTimeText, formatPRInfoText, formatCheckStatusWithWidth, formatAheadBehindWithWidth) import UnliftIO.Async @@ -208,12 +210,16 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn , pageInfoLastPage = if totalPages > 0 then Just totalPages else Nothing } + -- Calculate column widths based on all branches in current page + currentTime <- getCurrentTime + let columnWidths = calculateColumnWidths currentTime currentPageBranches + -- Store only the current page's branches in the node state atomically $ do writeTVar pageInfoVar newPageInfo writeTVar stateVar (Fetched (V.fromList currentPageBranches)) (writeTVar childrenVar =<<) $ forM currentPageBranches $ \branchInfo -> - SingleBranchWithInfoNode <$> makeEmptyElem bc branchInfo ("/tree/" <> branchWithInfoBranchName branchInfo) (depth' + 1) + SingleBranchWithInfoNode <$> makeEmptyElem bc (branchInfo, columnWidths) ("/tree/" <> branchWithInfoBranchName branchInfo) (depth' + 1) logToModal bc $ logPrefix <> ": Processing complete, found " <> show (case result of Left _ -> 0 Right branchesWithCommits -> length $ filterFn branchesWithCommits) <> " " <> logSuffix @@ -223,6 +229,15 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn OAuth token -> Just $ decodeUtf8 token _ -> Nothing -- Only OAuth tokens supported for now + calculateColumnWidths :: UTCTime -> [BranchWithInfo] -> ColumnWidths + calculateColumnWidths _ [] = ColumnWidths 0 0 0 0 -- Default widths for empty list + calculateColumnWidths currentTime branches = ColumnWidths { + cwCommitTime = fromMaybe 0 $ viaNonEmpty List.maximum $ map (T.length . formatCommitTimeText currentTime) branches + , cwCheckStatus = fromMaybe 0 $ viaNonEmpty List.maximum $ map (snd . formatCheckStatusWithWidth) branches + , cwAheadBehind = fromMaybe 0 $ viaNonEmpty List.maximum $ map (snd . formatAheadBehindWithWidth) branches + , cwPRInfo = fromMaybe 0 $ viaNonEmpty List.maximum $ map (T.length . formatPRInfoText) branches + } + fetchYourBranches :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Maybe Text -> Node Variable PaginatedYourBranchesT -> m () @@ -313,7 +328,7 @@ fetchBranchCommits owner name (SingleBranchNode (EntityData {_static=branch, ..} fetchBranchWithInfoCommits :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Node Variable SingleBranchWithInfoT -> m () -fetchBranchWithInfoCommits owner name (SingleBranchWithInfoNode (EntityData {_static=branchInfo, ..})) = do +fetchBranchWithInfoCommits owner name (SingleBranchWithInfoNode (EntityData {_static=(branchInfo, _columnWidths), ..})) = do bc <- ask case branchWithInfoCommitOid branchInfo of Nothing -> atomically $ writeTVar _state (Errored "No commit OID available for branch with info") diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index fbda2b2..69a8bf1 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -169,7 +169,7 @@ type family NodeStatic a where NodeStatic SingleWorkflowT = WorkflowRun NodeStatic SingleJobT = () NodeStatic SingleBranchT = Branch - NodeStatic SingleBranchWithInfoT = BranchWithInfo + NodeStatic SingleBranchWithInfoT = (BranchWithInfo, ColumnWidths) NodeStatic SingleCommitT = Commit NodeStatic SingleNotificationT = Notification NodeStatic JobLogGroupT = JobLogGroup @@ -328,6 +328,13 @@ data BranchWithInfo = BranchWithInfo { , branchWithInfoBehindBy :: Maybe Int } deriving (Show, Eq) +data ColumnWidths = ColumnWidths { + cwCommitTime :: Int + , cwCheckStatus :: Int + , cwAheadBehind :: Int + , cwPRInfo :: Int + } deriving (Show, Eq) + -- * Misc data SortBy = diff --git a/app/Sauron/UI/BranchWithInfo.hs b/app/Sauron/UI/BranchWithInfo.hs index df83f9c..25ed9cf 100644 --- a/app/Sauron/UI/BranchWithInfo.hs +++ b/app/Sauron/UI/BranchWithInfo.hs @@ -2,10 +2,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Sauron.UI.BranchWithInfo () where +module Sauron.UI.BranchWithInfo ( + formatCommitTimeText, + formatPRInfoText, + formatCheckStatusWithWidth, + formatAheadBehindWithWidth +) where import Brick -import Data.String.Interpolate import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime) import Data.Time.Format (parseTimeM, defaultTimeLocale) @@ -20,79 +24,92 @@ import Sauron.UI.Util.TimeDiff (timeFromNow) instance ListDrawable Fixed 'SingleBranchWithInfoT where - drawLine appState (EntityData {_static=branchInfo, _state, ..}) = + drawLine appState (EntityData {_static=(branchInfo, columnWidths), _state, ..}) = let branchCommit = BranchCommit (fromMaybe "" (branchWithInfoCommitOid branchInfo)) (URL "") -- placeholder URL branch = Branch (branchWithInfoBranchName branchInfo) branchCommit - in branchLineWithInfo _toggled branch branchInfo appState _state + in branchLineWithInfo _toggled branch branchInfo columnWidths appState _state drawInner _ _ = Nothing -branchLineWithInfo :: Bool -> Branch -> BranchWithInfo -> AppState -> Fetchable (V.Vector Commit) -> Widget n -branchLineWithInfo toggled' (Branch {branchName, branchCommit}) branchData appState fetchableState = vBox [line1, line2] +branchLineWithInfo :: Bool -> Branch -> BranchWithInfo -> ColumnWidths -> AppState -> Fetchable (V.Vector Commit) -> Widget n +branchLineWithInfo toggled' (Branch {branchName, branchCommit}) branchData columnWidths appState fetchableState = vBox [line1, line2] where line1 = hBox [ withAttr openMarkerAttr $ str (if toggled' then "[-] " else "[+] ") - , hLimitPercent 30 $ withAttr branchAttr $ - padRight Max $ txt branchName - , hLimitPercent 15 $ - padRight Max $ str $ formatCommitTime branchData - , hLimitPercent 12 $ - padRight Max $ formatCheckStatus branchData - , hLimitPercent 10 $ - padRight Max $ formatAheadBehind branchData - , hLimitPercent 15 $ - padRight Max $ str $ formatPRInfo branchData + , withAttr branchAttr $ txt branchName , fetchableQuarterCircleSpinner (_appAnimationCounter appState) fetchableState - , padLeft Max $ case fetchableState of - Fetched commits -> str [i|(#{V.length commits} commits)|] - _ -> withAttr normalAttr $ str "branch" + , padLeft Max infoColumns ] + infoColumns = hBox [ + fixedWidth (cwCommitTime columnWidths) $ txt $ formatCommitTimeText (_appNow appState) branchData + , str spacing + , fixedWidth (cwCheckStatus columnWidths) $ formatCheckStatus branchData + , str spacing + , fixedWidth (cwAheadBehind columnWidths) $ formatAheadBehind branchData + , str spacing + , fixedWidth (cwPRInfo columnWidths) $ txt $ formatPRInfoText branchData + , str spacing + ] + where + fixedWidth w widget = hLimit w $ padRight Max widget + spacing = " " + line2 = padRight Max $ padLeft (Pad 4) $ hBox [ str "Latest commit " , withAttr hashAttr $ str $ take 7 $ toString $ branchCommitSha branchCommit ] - -- Helper function to format commit time from GraphQL data using timeFromNow - formatCommitTime :: BranchWithInfo -> String - formatCommitTime branchInfo = - case branchWithInfoCommitDate branchInfo of - Nothing -> "Unknown" - Just dateStr -> - case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of - Nothing -> toString $ T.take 10 dateStr -- Fallback to raw date - Just commitTime -> timeFromNow (diffUTCTime (_appNow appState) commitTime) - - -- Helper function to format check status with colors formatCheckStatus :: BranchWithInfo -> Widget n - formatCheckStatus branchInfo = - case branchWithInfoCheckStatus branchInfo of - Nothing -> str "No checks" - Just "SUCCESS" -> hBox [withAttr greenCheckAttr $ str "✓", str " Checks"] - Just "FAILURE" -> hBox [withAttr redXAttr $ str "✗", str " Failed"] - Just "PENDING" -> hBox [withAttr queuedAttr $ str "⏳", str " Running"] - Just status -> str $ toString status - - -- Helper function to format PR info - formatPRInfo :: BranchWithInfo -> String - formatPRInfo branchInfo = - case branchWithInfoAssociatedPR branchInfo of - Nothing -> "No PR" - Just pr -> case GraphQL.prNumber pr of - Nothing -> "PR: Unknown" - Just num -> "PR #" <> show num - - -- Helper function to format ahead/behind counts with colors + formatCheckStatus = fst . formatCheckStatusWithWidth + formatAheadBehind :: BranchWithInfo -> Widget n - formatAheadBehind branchInfo = - let ahead = fromMaybe 0 (branchWithInfoAheadBy branchInfo) - behind = fromMaybe 0 (branchWithInfoBehindBy branchInfo) - aheadWidget = if ahead > 0 - then hBox [withAttr greenCheckAttr $ str "↑", str $ " " <> show ahead] - else str "↑ 0" - behindWidget = if behind > 0 - then hBox [withAttr queuedAttr $ str "↓", str $ " " <> show behind] - else str "↓ 0" - in hBox [aheadWidget, str " ", behindWidget] + formatAheadBehind = fst . formatAheadBehindWithWidth + +-- * Widget + width helper functions + +formatCheckStatusWithWidth :: BranchWithInfo -> (Widget n, Int) +formatCheckStatusWithWidth branchInfo = + case branchWithInfoCheckStatus branchInfo of + Nothing -> let text = "No checks" in (str text, length text) + Just "SUCCESS" -> let widget = hBox [withAttr greenCheckAttr $ str "✓", str " Checks"] in (widget, 8) -- ✓ Checks = 8 chars + Just "FAILURE" -> let widget = hBox [withAttr redXAttr $ str "✗", str " Failed"] in (widget, 8) -- ✗ Failed = 8 chars + Just "PENDING" -> let widget = hBox [withAttr queuedAttr $ str "⏳", str " Running"] in (widget, 9) -- ⏳ Running = 9 chars + Just status -> let text = toString status in (str text, T.length status) + +formatAheadBehindWithWidth :: BranchWithInfo -> (Widget n, Int) +formatAheadBehindWithWidth branchInfo = (widget, T.length totalText) + where + ahead = fromMaybe 0 (branchWithInfoAheadBy branchInfo) + behind = fromMaybe 0 (branchWithInfoBehindBy branchInfo) + aheadWidget = if ahead > 0 + then hBox [withAttr greenCheckAttr $ str "↑", str $ " " <> show ahead] + else str "↑ 0" + behindWidget = if behind > 0 + then hBox [withAttr queuedAttr $ str "↓", str $ " " <> show behind] + else str "↓ 0" + widget = hBox [aheadWidget, str " ", behindWidget] + -- Calculate width: "↑ X ↓ Y" where X and Y are numbers + aheadText = if ahead > 0 then "↑ " <> show ahead else "↑ 0" + behindText = if behind > 0 then "↓ " <> show behind else "↓ 0" + totalText = aheadText <> " " <> behindText + +formatCommitTimeText :: UTCTime -> BranchWithInfo -> Text +formatCommitTimeText currentTime branchInfo = + case branchWithInfoCommitDate branchInfo of + Nothing -> "Unknown" + Just dateStr -> + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" (toString dateStr) :: Maybe UTCTime of + Nothing -> T.take 10 dateStr -- Fallback to raw date + Just commitTime -> toText $ timeFromNow (diffUTCTime currentTime commitTime) + + +formatPRInfoText :: BranchWithInfo -> Text +formatPRInfoText branchInfo = + case branchWithInfoAssociatedPR branchInfo of + Nothing -> "No PR" + Just pr -> case GraphQL.prNumber pr of + Nothing -> "PR: Unknown" + Just num -> "PR #" <> show num diff --git a/app/Sauron/UI/Modals/ZoomModal.hs b/app/Sauron/UI/Modals/ZoomModal.hs index bba9215..66025fc 100644 --- a/app/Sauron/UI/Modals/ZoomModal.hs +++ b/app/Sauron/UI/Modals/ZoomModal.hs @@ -93,7 +93,7 @@ generateModalTitle (SomeNode inner) = _ -> "Job" SingleBranchNode (EntityData {_static = Branch {branchName}}) -> "Branch: " <> T.unpack branchName - SingleBranchWithInfoNode (EntityData {_static = branchInfo}) -> + SingleBranchWithInfoNode (EntityData {_static = (branchInfo, _columnWidths)}) -> "Branch: " <> T.unpack (branchWithInfoBranchName branchInfo) SingleCommitNode (EntityData {_static = Commit {commitGitCommit = GitCommit {gitCommitMessage}}}) -> "Commit: " <> T.unpack (T.take 50 gitCommitMessage) <> if T.length gitCommitMessage > 50 then "..." else "" From 4bfae49b48b126e7dc3d000b5f3fe9bee1112ab6 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 3 Dec 2025 18:14:06 -0800 Subject: [PATCH 09/13] Little bit of log modal improvements --- app/Sauron/Event.hs | 8 ++++++-- app/Sauron/Fetch.hs | 2 -- app/Sauron/UI/Modals/LogModal.hs | 14 +++++++------- 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/app/Sauron/Event.hs b/app/Sauron/Event.hs index 122661c..ac4653f 100644 --- a/app/Sauron/Event.hs +++ b/app/Sauron/Event.hs @@ -87,6 +87,8 @@ appEvent s@(_appModal -> Just modalState) e = case e of (V.EvKey (V.KChar 'q') [V.MCtrl]) -> do modify (appModal .~ Nothing) liftIO $ atomically $ writeTVar (_appModalVariable s) Nothing + (V.EvKey (V.KChar 'c') []) -> do + modify (appLogs .~ Seq.empty) (V.EvKey (V.KChar 'v') [V.MCtrl]) -> vScrollPage (viewportScroll LogModalContent) Down (V.EvKey (V.KChar 'v') [V.MMeta]) -> vScrollPage (viewportScroll LogModalContent) Up (V.EvKey (V.KChar 'n') [V.MCtrl]) -> vScrollBy (viewportScroll LogModalContent) 1 @@ -178,8 +180,10 @@ appEvent s (VtyEvent e) = case e of liftIO $ atomically $ writeTVar (_appModalVariable s) (Just (ZoomModalState (SomeNode variableEl))) V.EvKey (V.KChar 'l') [V.MCtrl] -> do - modify (appModal .~ Just LogModalState) + modify (appModal ?~ LogModalState) liftIO $ atomically $ writeTVar (_appModalVariable s) (Just LogModalState) + -- Scroll to the bottom of the log modal content to show latest logs + vScrollToEnd (viewportScroll LogModalContent) V.EvKey c [] | c `elem` [V.KEsc, exitKey] -> do -- Cancel everything and wait for cleanups @@ -195,7 +199,7 @@ appEvent _s (MouseDown (ListRow _i) V.BScrollUp _ _) = do appEvent _s (MouseDown (ListRow _i) V.BScrollDown _ _) = do vScrollBy (viewportScroll MainList) 1 appEvent _s (MouseDown (ListRow n) V.BLeft _ _) = do - modify (appMainList %~ (listMoveTo n)) + modify (appMainList %~ listMoveTo n) appEvent _ _ = return () diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index b0a1a27..b94a02c 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -169,13 +169,11 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn bracketOnError_ (atomically $ markFetching stateVar) (atomically $ writeTVar stateVar (Errored $ logPrefix <> " fetch failed with exception.")) $ do - logToModal bc $ logPrefix <> ": Starting GraphQL query" case getAuthToken bc of Nothing -> liftIO $ do logToModal bc $ logPrefix <> ": No auth token available" atomically $ writeTVar stateVar (Errored "No auth token available for GraphQL query") Just authToken -> do - logToModal bc $ logPrefix <> ": Got auth token: " <> T.take 10 authToken <> "..." liftIO $ do logToModal bc $ logPrefix <> ": Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name -- Read current page info to determine pagination diff --git a/app/Sauron/UI/Modals/LogModal.hs b/app/Sauron/UI/Modals/LogModal.hs index 325648f..29aa855 100644 --- a/app/Sauron/UI/Modals/LogModal.hs +++ b/app/Sauron/UI/Modals/LogModal.hs @@ -23,7 +23,7 @@ renderLogModal appState LogModalState = , padBottom Max $ withVScrollBars OnRight $ withVScrollBarHandles $ viewport LogModalContent Vertical $ vBox (renderLogEntries (appState ^. appNow) (appState ^. appLogs)) , hBorder - , hCenter $ withAttr hotkeyMessageAttr $ str "Press [Esc] or [Ctrl+Q] to close" + , hCenter $ withAttr hotkeyMessageAttr $ str "Press [Esc] or [Ctrl+Q] to close, [c] to clear logs" ] & border & withAttr normalAttr @@ -41,9 +41,9 @@ renderLogEntries currentTime logs = renderLogEntry :: UTCTime -> LogEntry -> Widget ClickableName renderLogEntry _currentTime (LogEntry timestamp level message) = hBox [ - withAttr levelAttr $ str (formatLevel level) + withAttr timeAttr $ str (formatLogTime timestamp) , str " " - , withAttr timeAttr $ str (formatLogTime timestamp) + , withAttr levelAttr $ str (formatLevel level) , str " " , txtWrap message ] @@ -55,14 +55,14 @@ renderLogEntry _currentTime (LogEntry timestamp level message) = LevelDebug -> debugLogAttr _ -> normalAttr - timeAttr = normalAttr + timeAttr = debugLogAttr -- Use a muted color for timestamps formatLevel :: LogLevel -> String formatLevel LevelError = "[ERROR]" -formatLevel LevelWarn = "[WARN] " -formatLevel LevelInfo = "[INFO] " +formatLevel LevelWarn = "[WARN]" +formatLevel LevelInfo = "[INFO]" formatLevel LevelDebug = "[DEBUG]" formatLevel (LevelOther t) = "[" <> toString t <> "]" formatLogTime :: UTCTime -> String -formatLogTime = formatTime defaultTimeLocale "%H:%M:%S" +formatLogTime = formatTime defaultTimeLocale "%H:%M:%S.%06q" From 9f722956de3599d525f4d0c7f64de0eed61d2d9f Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Thu, 4 Dec 2025 13:00:34 -0800 Subject: [PATCH 10/13] More on logging/log modal --- app/Sauron/Actions/Util.hs | 11 +++++++---- app/Sauron/Event.hs | 4 ++++ app/Sauron/Fetch.hs | 17 ++++++++--------- app/Sauron/Fetch/Core.hs | 16 +++++++++++++--- app/Sauron/Types.hs | 1 + app/Sauron/UI/Modals/LogModal.hs | 16 +++++++++++++++- 6 files changed, 48 insertions(+), 17 deletions(-) diff --git a/app/Sauron/Actions/Util.hs b/app/Sauron/Actions/Util.hs index 30110da..5c71159 100644 --- a/app/Sauron/Actions/Util.hs +++ b/app/Sauron/Actions/Util.hs @@ -84,12 +84,15 @@ githubWithLogging' bc request = fmap responseBody <$> githubWithLogging'' bc req githubWithLogging'' :: (MonadIO m, FromJSON a) => BaseContext -> Request k a -> m (Either Error (Response a)) githubWithLogging'' (BaseContext {..}) request = do + startTime <- liftIO getCurrentTime result <- liftIO $ executeRequestWithMgrAndRes manager auth request - logResult eventChan request result + endTime <- liftIO getCurrentTime + let duration = diffUTCTime endTime startTime + logResult eventChan request result (Just duration) return result -logResult :: (MonadIO m) => BChan AppEvent -> Request k a -> Either Error (Response b) -> m () -logResult eventChan request result = do +logResult :: (MonadIO m) => BChan AppEvent -> Request k a -> Either Error (Response b) -> Maybe NominalDiffTime -> m () +logResult eventChan request result maybeDuration = do now <- liftIO getCurrentTime let url = requestToUrl request let level = case result of Left _ -> LevelError; _ -> LevelInfo @@ -100,7 +103,7 @@ logResult eventChan request result = do Nothing -> "" -- " " <> show (responseHeaders response) Just size -> " (" <> show size <> " bytes)" in (url <> sizeInfo) - let logEntry = LogEntry now level msg + let logEntry = LogEntry now level msg maybeDuration liftIO $ writeBChan eventChan (LogEntryAdded logEntry) where getResponseSize :: Response a -> Maybe Int diff --git a/app/Sauron/Event.hs b/app/Sauron/Event.hs index ac4653f..6ef5921 100644 --- a/app/Sauron/Event.hs +++ b/app/Sauron/Event.hs @@ -93,6 +93,10 @@ appEvent s@(_appModal -> Just modalState) e = case e of (V.EvKey (V.KChar 'v') [V.MMeta]) -> vScrollPage (viewportScroll LogModalContent) Up (V.EvKey (V.KChar 'n') [V.MCtrl]) -> vScrollBy (viewportScroll LogModalContent) 1 (V.EvKey (V.KChar 'p') [V.MCtrl]) -> vScrollBy (viewportScroll LogModalContent) (-1) + (V.EvKey V.KUp []) -> vScrollBy (viewportScroll LogModalContent) (-1) + (V.EvKey V.KDown []) -> vScrollBy (viewportScroll LogModalContent) 1 + (V.EvKey V.KPageUp []) -> vScrollPage (viewportScroll LogModalContent) Up + (V.EvKey V.KPageDown []) -> vScrollPage (viewportScroll LogModalContent) Down _ -> return () -- No other interactions for LogModal _ -> return () diff --git a/app/Sauron/Fetch.hs b/app/Sauron/Fetch.hs index b94a02c..84a5710 100644 --- a/app/Sauron/Fetch.hs +++ b/app/Sauron/Fetch.hs @@ -40,6 +40,7 @@ import Control.Exception.Safe (bracketOnError_) import Control.Monad (foldM) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class +import Control.Monad.Logger (LogLevel(..)) import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.String.Interpolate @@ -171,11 +172,11 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn (atomically $ writeTVar stateVar (Errored $ logPrefix <> " fetch failed with exception.")) $ do case getAuthToken bc of Nothing -> liftIO $ do - logToModal bc $ logPrefix <> ": No auth token available" + logToModal bc LevelError (logPrefix <> ": No auth token available") Nothing atomically $ writeTVar stateVar (Errored "No auth token available for GraphQL query") Just authToken -> do liftIO $ do - logToModal bc $ logPrefix <> ": Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name + logToModal bc LevelInfo (logPrefix <> ": Querying GraphQL for " <> toPathPart owner <> "/" <> toPathPart name) Nothing -- Read current page info to determine pagination currentPageInfo <- readTVarIO pageInfoVar let currentPage = pageInfoCurrentPage currentPageInfo @@ -185,7 +186,7 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn let branchesToFetch = max 100 (currentPage * pageSize * 3) -- Fetch at least 100, or enough for 3 pages worth -- Fetch branches with commit info using GraphQL - result <- GraphQL.queryBranchesWithInfos (logToModal bc) authToken (toPathPart owner) (toPathPart name) repoDefaultBranch branchesToFetch + result <- GraphQL.queryBranchesWithInfos (\msg -> logToModal bc LevelDebug msg Nothing) authToken (toPathPart owner) (toPathPart name) repoDefaultBranch branchesToFetch case result of Left err -> atomically $ do writeTVar stateVar (Errored $ toText err) @@ -218,9 +219,9 @@ fetchBranchesWithFilter owner name repoDefaultBranch stateVar childrenVar pageIn writeTVar stateVar (Fetched (V.fromList currentPageBranches)) (writeTVar childrenVar =<<) $ forM currentPageBranches $ \branchInfo -> SingleBranchWithInfoNode <$> makeEmptyElem bc (branchInfo, columnWidths) ("/tree/" <> branchWithInfoBranchName branchInfo) (depth' + 1) - logToModal bc $ logPrefix <> ": Processing complete, found " <> show (case result of + logToModal bc LevelInfo (logPrefix <> ": Processing complete, found " <> show (case result of Left _ -> 0 - Right branchesWithCommits -> length $ filterFn branchesWithCommits) <> " " <> logSuffix + Right branchesWithCommits -> length $ filterFn branchesWithCommits) <> " " <> logSuffix) Nothing where getAuthToken :: BaseContext -> Maybe Text getAuthToken bc = case auth bc of @@ -243,7 +244,7 @@ fetchYourBranches owner name repoDefaultBranch (PaginatedYourBranchesNode (Entit bc <- ask liftIO (getUserName bc) >>= \case Nothing -> liftIO $ do - logToModal bc "fetchYourBranches: Could not get current user name" + logToModal bc LevelError "fetchYourBranches: Could not get current user name" Nothing atomically $ writeTVar _state (Errored "Could not get current user name") Just userName -> fetchBranchesWithFilter owner name repoDefaultBranch _state _children _pageInfo _depth "fetchYourBranches" @@ -493,7 +494,7 @@ fetchJobLogs :: ( MonadReader BaseContext m, MonadIO m, MonadMask m ) => Name Owner -> Name Repo -> Job -> Node Variable SingleJobT -> m () fetchJobLogs owner name (Job {jobId, jobSteps}) (SingleJobNode (EntityData {..})) = do - BaseContext {auth, manager} <- ask + bc@(BaseContext {auth, manager}) <- ask bracketOnError_ (atomically $ markFetching _state) (atomically $ writeTVar _state (Errored "Job logs fetch failed with exception.")) $ do -- First, get the download URI @@ -507,8 +508,6 @@ fetchJobLogs owner name (Job {jobId, jobSteps}) (SingleJobNode (EntityData {..}) let parsedLogs = parseJobLogs (T.splitOn "\n" (decodeUtf8 logs)) -- traceM [i|parsedLogs: #{parsedLogs}|] - - bc <- ask children' <- liftIO $ atomically $ do mapM (createJobStepNode bc (_depth + 1) parsedLogs) (V.toList jobSteps) diff --git a/app/Sauron/Fetch/Core.hs b/app/Sauron/Fetch/Core.hs index 4a8f5b1..6100b5e 100644 --- a/app/Sauron/Fetch/Core.hs +++ b/app/Sauron/Fetch/Core.hs @@ -7,6 +7,7 @@ module Sauron.Fetch.Core ( , makeEmptyElem , logToModal + , withLogToModal ) where import Brick.BChan (writeBChan) @@ -95,8 +96,17 @@ makeEmptyElem (BaseContext {getIdentifierSTM}) typ' urlSuffix' depth' = do , _ident = ident' } -logToModal :: MonadIO m => BaseContext -> Text -> m () -logToModal bc msg = do +logToModal :: MonadIO m => BaseContext -> LogLevel -> Text -> Maybe NominalDiffTime -> m () +logToModal bc level msg maybeDuration = do now <- liftIO getCurrentTime - let logEntry = LogEntry now LevelInfo msg + let logEntry = LogEntry now level msg maybeDuration liftIO $ writeBChan (eventChan bc) (LogEntryAdded logEntry) + +withLogToModal :: MonadIO m => BaseContext -> LogLevel -> Text -> m a -> m a +withLogToModal bc level msg action = do + startTime <- liftIO getCurrentTime + result <- action + endTime <- liftIO getCurrentTime + let duration = diffUTCTime endTime startTime + logToModal bc level msg (Just duration) + return result diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index 69a8bf1..506c9a0 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -443,6 +443,7 @@ data LogEntry = LogEntry { _logEntryTimestamp :: UTCTime , _logEntryLevel :: LogLevel , _logEntryMessage :: Text + , _logEntryDuration :: Maybe NominalDiffTime } deriving (Show, Eq) -- * Overall app state diff --git a/app/Sauron/UI/Modals/LogModal.hs b/app/Sauron/UI/Modals/LogModal.hs index 29aa855..4b7e042 100644 --- a/app/Sauron/UI/Modals/LogModal.hs +++ b/app/Sauron/UI/Modals/LogModal.hs @@ -39,13 +39,16 @@ renderLogEntries currentTime logs = else toList $ fmap (renderLogEntry currentTime) logs renderLogEntry :: UTCTime -> LogEntry -> Widget ClickableName -renderLogEntry _currentTime (LogEntry timestamp level message) = +renderLogEntry _currentTime (LogEntry timestamp level message maybeDuration) = hBox [ withAttr timeAttr $ str (formatLogTime timestamp) , str " " , withAttr levelAttr $ str (formatLevel level) , str " " , txtWrap message + , case maybeDuration of + Nothing -> emptyWidget + Just duration -> hBox [str " ", formatDuration duration] ] where levelAttr = case level of @@ -57,6 +60,17 @@ renderLogEntry _currentTime (LogEntry timestamp level message) = timeAttr = debugLogAttr -- Use a muted color for timestamps + formatDuration :: NominalDiffTime -> Widget ClickableName + formatDuration duration = + let durationMs = round (duration * 1000) :: Integer + durationAttr + | durationMs < 100 = debugLogAttr -- Fast (< 100ms) - gray + | durationMs < 1000 = infoLogAttr -- Normal (100-1000ms) - white + | durationMs < 5000 = warningLogAttr -- Slow (1-5s) - yellow + | otherwise = errorLogAttr -- Very slow (>5s) - red + durationText = show durationMs <> "ms" + in withAttr durationAttr $ str durationText + formatLevel :: LogLevel -> String formatLevel LevelError = "[ERROR]" formatLevel LevelWarn = "[WARN]" From e29135baf4e1f2e52fcf87008f62cabed62be022 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Thu, 4 Dec 2025 18:27:07 -0800 Subject: [PATCH 11/13] Show URL parameters in log modal lines --- app/Sauron/Actions/Util.hs | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/app/Sauron/Actions/Util.hs b/app/Sauron/Actions/Util.hs index 5c71159..da50a49 100644 --- a/app/Sauron/Actions/Util.hs +++ b/app/Sauron/Actions/Util.hs @@ -24,11 +24,13 @@ import Control.Monad.IO.Class import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader import Data.Aeson (FromJSON) +import qualified Data.ByteString as BS import qualified Data.List as L import qualified Data.Text as T import Data.Time import GitHub import Network.HTTP.Client (Response, responseBody, responseHeaders) +import Network.HTTP.Types (EscapeItem(..)) import Network.HTTP.Types.Header (hContentLength) import Relude import Sauron.Types @@ -66,13 +68,29 @@ findRepoParent elems = viaNonEmpty head [x | SomeNode x@(RepoNode _) <- toList e requestToUrl :: Request k a -> Text requestToUrl req = case req of - Query paths _queryString -> pathsToUrl paths - PagedQuery paths _queryString _fetchCount -> pathsToUrl paths + Query paths queryString -> pathsToUrl paths <> formatQueryString queryString + PagedQuery paths queryString _fetchCount -> pathsToUrl paths <> formatQueryString queryString Command _method paths _body -> pathsToUrl paths where pathsToUrl :: [Text] -> Text pathsToUrl = ("/" <>) . T.intercalate "/" + formatQueryString :: QueryString -> Text + formatQueryString queryParams = + if null queryParams + then "" + else "?" <> T.intercalate "&" (map formatParam queryParams) + + formatParam :: (BS.ByteString, [EscapeItem]) -> Text + formatParam (key, values) = keyText <> "=" <> valuesText + where + keyText = decodeUtf8 key + valuesText = T.intercalate "," $ map formatEscapeItem values + + formatEscapeItem :: EscapeItem -> Text + formatEscapeItem (QE s) = decodeUtf8 s -- QE is already query-escaped + formatEscapeItem (QN s) = decodeUtf8 s + githubWithLogging :: (MonadReader BaseContext m, MonadIO m, FromJSON a) => Request k a -> m (Either Error a) githubWithLogging request = fmap responseBody <$> githubWithLoggingResponse request From aa59a8a97cc9949dd89ce9faea980786a04497e8 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Thu, 4 Dec 2025 18:28:56 -0800 Subject: [PATCH 12/13] Log levels in LogModal --- app/Main.hs | 3 +++ app/Sauron/Event.hs | 13 +++++++++++++ app/Sauron/Types.hs | 2 ++ app/Sauron/UI/Modals/LogModal.hs | 28 +++++++++++++++++++++++----- 4 files changed, 41 insertions(+), 5 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8de875d..56c42d5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,6 +11,7 @@ import qualified Brick.Widgets.List as L import Control.Concurrent.QSem import Control.Concurrent.STM (retry) import Control.Monad +import Control.Monad.Logger (LogLevel(..)) import Data.Function import Data.String.Interpolate import qualified Data.Text.IO as T @@ -135,6 +136,8 @@ main = do , _appColorMode = V.FullColor , _appLogs = mempty + + , _appLogLevelFilter = LevelInfo } diff --git a/app/Sauron/Event.hs b/app/Sauron/Event.hs index 6ef5921..fe0a27a 100644 --- a/app/Sauron/Event.hs +++ b/app/Sauron/Event.hs @@ -9,6 +9,7 @@ import Brick.Forms import Brick.Widgets.Edit (handleEditorEvent) import Brick.Widgets.List import Control.Monad +import Control.Monad.Logger (LogLevel(..)) import Control.Monad.IO.Unlift import Data.Function import qualified Data.Sequence as Seq @@ -97,6 +98,18 @@ appEvent s@(_appModal -> Just modalState) e = case e of (V.EvKey V.KDown []) -> vScrollBy (viewportScroll LogModalContent) 1 (V.EvKey V.KPageUp []) -> vScrollPage (viewportScroll LogModalContent) Up (V.EvKey V.KPageDown []) -> vScrollPage (viewportScroll LogModalContent) Down + (V.EvKey (V.KChar 'd') []) -> do + modify (appLogLevelFilter .~ LevelDebug) + vScrollToEnd (viewportScroll LogModalContent) + (V.EvKey (V.KChar 'i') []) -> do + modify (appLogLevelFilter .~ LevelInfo) + vScrollToEnd (viewportScroll LogModalContent) + (V.EvKey (V.KChar 'w') []) -> do + modify (appLogLevelFilter .~ LevelWarn) + vScrollToEnd (viewportScroll LogModalContent) + (V.EvKey (V.KChar 'e') []) -> do + modify (appLogLevelFilter .~ LevelError) + vScrollToEnd (viewportScroll LogModalContent) _ -> return () -- No other interactions for LogModal _ -> return () diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index 506c9a0..19e7fff 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -512,6 +512,8 @@ data AppState = AppState { , _appColorMode :: V.ColorMode , _appLogs :: Seq LogEntry + + , _appLogLevelFilter :: LogLevel } diff --git a/app/Sauron/UI/Modals/LogModal.hs b/app/Sauron/UI/Modals/LogModal.hs index 4b7e042..1c97ea6 100644 --- a/app/Sauron/UI/Modals/LogModal.hs +++ b/app/Sauron/UI/Modals/LogModal.hs @@ -15,21 +15,29 @@ import Sauron.UI.AttrMap (errorLogAttr, warningLogAttr, infoLogAttr, debugLogAtt renderLogModal :: AppState -> ModalState Fixed -> Widget ClickableName -renderLogModal appState LogModalState = - vBox [ - hCenter $ withAttr boldText $ str "Application Logs" +renderLogModal appState LogModalState = vBox [ + hCenter $ withAttr boldText $ str ("Application Logs - Filter: " <> filterText) , hBorder -- Scrollable content area with log entries , padBottom Max $ withVScrollBars OnRight $ withVScrollBarHandles $ viewport LogModalContent Vertical $ - vBox (renderLogEntries (appState ^. appNow) (appState ^. appLogs)) + vBox (renderLogEntries (appState ^. appNow) filteredLogs) , hBorder - , hCenter $ withAttr hotkeyMessageAttr $ str "Press [Esc] or [Ctrl+Q] to close, [c] to clear logs" + , hCenter $ withAttr hotkeyMessageAttr $ str "Press [Esc] or [Ctrl+Q] to close, [c] to clear logs, [d/i/w/e] to filter levels" ] & border & withAttr normalAttr & hLimitPercent 80 & vLimitPercent 90 & centerLayer + where + currentFilter = appState ^. appLogLevelFilter + filteredLogs = filterLogsByLevel currentFilter (appState ^. appLogs) + filterText = case currentFilter of + LevelDebug -> "All" + LevelInfo -> "Info" + LevelWarn -> "Warn" + LevelError -> "Error" + LevelOther t -> toString t renderLogModal _ _ = str "Invalid modal state" -- This should never happen renderLogEntries :: UTCTime -> Seq LogEntry -> [Widget ClickableName] @@ -80,3 +88,13 @@ formatLevel (LevelOther t) = "[" <> toString t <> "]" formatLogTime :: UTCTime -> String formatLogTime = formatTime defaultTimeLocale "%H:%M:%S.%06q" + +filterLogsByLevel :: LogLevel -> Seq LogEntry -> Seq LogEntry +filterLogsByLevel filterLevel = Seq.filter (\logEntry -> logLevelPriority (_logEntryLevel logEntry) >= logLevelPriority filterLevel) + where + logLevelPriority :: LogLevel -> Int + logLevelPriority LevelError = 4 + logLevelPriority LevelWarn = 3 + logLevelPriority LevelInfo = 2 + logLevelPriority LevelDebug = 1 + logLevelPriority (LevelOther _) = 0 From f7c6a6e93ce213b42759751eb2c9f7dc2d897fcd Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 5 Dec 2025 00:50:02 -0800 Subject: [PATCH 13/13] Some final tweaks on branches --- app/Sauron/Event/Open.hs | 3 +++ app/Sauron/GraphQL.hs | 7 +++++-- app/Sauron/Types.hs | 2 ++ app/Sauron/UI/BranchWithInfo.hs | 13 +++++++++---- 4 files changed, 19 insertions(+), 6 deletions(-) diff --git a/app/Sauron/Event/Open.hs b/app/Sauron/Event/Open.hs index b6400c5..ccdb0f9 100644 --- a/app/Sauron/Event/Open.hs +++ b/app/Sauron/Event/Open.hs @@ -34,6 +34,9 @@ getNodeUrl (PaginatedPullsNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just ( getNodeUrl (PaginatedWorkflowsNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/actions") getNodeUrl (PaginatedBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches") getNodeUrl (OverallBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches") +getNodeUrl (PaginatedYourBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches/yours") +getNodeUrl (PaginatedActiveBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches/active") +getNodeUrl (PaginatedStaleBranchesNode _) (findRepoBaseUrl -> Just repoBaseUrl) = Just (repoBaseUrl <> "/branches/stale") getNodeUrl (PaginatedNotificationsNode _) _ = Just "https://github.com/notifications" getNodeUrl (SingleIssueNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) getNodeUrl (SinglePullNode (EntityData {_static=(Issue {issueHtmlUrl=(Just url)})})) _parents = Just (toString $ getUrl url) diff --git a/app/Sauron/GraphQL.hs b/app/Sauron/GraphQL.hs index 13a433a..186883a 100644 --- a/app/Sauron/GraphQL.hs +++ b/app/Sauron/GraphQL.hs @@ -7,7 +7,6 @@ module Sauron.GraphQL ( , filterBranchesByAuthor , filterBranchesByActivity , filterBranchesByInactivity - , prNumber ) where import Control.Exception.Safe (try) @@ -66,12 +65,13 @@ getBranchesQuery = [i| endCursor } } - pullRequests(states: OPEN, first: 100) { + pullRequests(states: [OPEN, CLOSED, MERGED], first: 100) { nodes { number title url headRefName + state } } } @@ -125,6 +125,7 @@ data GraphQLPullRequestWithHead = GraphQLPullRequestWithHead { , prWithHeadTitle :: Maybe Text , prWithHeadUrl :: Maybe Text , prWithHeadRefName :: Maybe Text + , prWithHeadState :: Maybe Text } deriving (Show, Generic) instance FromJSON GraphQLPullRequestWithHead where parseJSON = withObject "GraphQLPullRequestWithHead" $ \o -> GraphQLPullRequestWithHead @@ -132,6 +133,7 @@ instance FromJSON GraphQLPullRequestWithHead where <*> o .:? "title" <*> o .:? "url" <*> o .:? "headRefName" + <*> o .:? "state" data RefNode = RefNode { name :: Text @@ -292,6 +294,7 @@ findPullRequestForBranch branchName pullRequests = prNumber = prWithHeadNumber prWithHead , prTitle = prWithHeadTitle prWithHead , prUrl = prWithHeadUrl prWithHead + , prState = prWithHeadState prWithHead } Nothing -> Nothing diff --git a/app/Sauron/Types.hs b/app/Sauron/Types.hs index 19e7fff..4316487 100644 --- a/app/Sauron/Types.hs +++ b/app/Sauron/Types.hs @@ -309,12 +309,14 @@ data GraphQLPullRequest = GraphQLPullRequest { prNumber :: Maybe Int , prTitle :: Maybe Text , prUrl :: Maybe Text + , prState :: Maybe Text } deriving (Show, Eq, Generic) instance FromJSON GraphQLPullRequest where parseJSON = withObject "GraphQLPullRequest" $ \o -> GraphQLPullRequest <$> o .:? "number" <*> o .:? "title" <*> o .:? "url" + <*> o .:? "state" data BranchWithInfo = BranchWithInfo { branchWithInfoBranchName :: Text diff --git a/app/Sauron/UI/BranchWithInfo.hs b/app/Sauron/UI/BranchWithInfo.hs index 25ed9cf..251b558 100644 --- a/app/Sauron/UI/BranchWithInfo.hs +++ b/app/Sauron/UI/BranchWithInfo.hs @@ -16,7 +16,6 @@ import Data.Time.Format (parseTimeM, defaultTimeLocale) import qualified Data.Vector as V import GitHub import Relude -import qualified Sauron.GraphQL as GraphQL import Sauron.Types import Sauron.UI.AttrMap import Sauron.UI.Statuses (fetchableQuarterCircleSpinner) @@ -76,7 +75,7 @@ formatCheckStatusWithWidth branchInfo = Nothing -> let text = "No checks" in (str text, length text) Just "SUCCESS" -> let widget = hBox [withAttr greenCheckAttr $ str "✓", str " Checks"] in (widget, 8) -- ✓ Checks = 8 chars Just "FAILURE" -> let widget = hBox [withAttr redXAttr $ str "✗", str " Failed"] in (widget, 8) -- ✗ Failed = 8 chars - Just "PENDING" -> let widget = hBox [withAttr queuedAttr $ str "⏳", str " Running"] in (widget, 9) -- ⏳ Running = 9 chars + Just "PENDING" -> let widget = hBox [withAttr queuedAttr $ str "●", str " Running"] in (widget, 9) -- ● Running = 9 chars Just status -> let text = toString status in (str text, T.length status) formatAheadBehindWithWidth :: BranchWithInfo -> (Widget n, Int) @@ -110,6 +109,12 @@ formatPRInfoText :: BranchWithInfo -> Text formatPRInfoText branchInfo = case branchWithInfoAssociatedPR branchInfo of Nothing -> "No PR" - Just pr -> case GraphQL.prNumber pr of + Just pr -> case prNumber pr of Nothing -> "PR: Unknown" - Just num -> "PR #" <> show num + Just num -> + let stateText = case prState pr of + Just "OPEN" -> "" -- Don't show state for open PRs + Just "MERGED" -> " (merged)" + Just "CLOSED" -> " (closed)" + _ -> "" + in "PR #" <> show num <> stateText