diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 83484be7..35e769f9 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -13,11 +13,6 @@ import HBS2.Polling import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient -import HBS2.Git.Data.Tx.Git -import HBS2.Git.Data.RepoHead -import HBS2.Git.Local -import HBS2.Git.Local.CLI - import HBS2.Git.Web.Assets import HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.State.Index @@ -309,45 +304,6 @@ runDashboardWeb wo = do lift $ html =<< renderTextT (repoCommit style lww hash) -gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) - => LWWRefKey 'HBS2Basic - -> GitHash - -> m [(GitObjectType, GitHash, Text)] -gitShowTree what hash = do - path <- repoDataPath what - let cmd = [qc|git --git-dir {path} ls-tree {show $ pretty hash}|] - - -- FIXME: extract-method - gitRunCommand cmd - >>= orThrowUser ("can't read git repo" <+> pretty path) - <&> LBS8.lines - <&> fmap LBS8.words - <&> mapMaybe \case - [_,tp,h,name] -> do - (,,) <$> fromStringMay (LBS8.unpack tp) - <*> fromStringMay (LBS8.unpack h) - <*> pure (fromString (LBS8.unpack name)) - - _ -> Nothing - - -gitShowRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m [(GitRef, GitHash)] -gitShowRefs what = do - path <- repoDataPath what - let cmd = [qc|git --git-dir {path} show-ref|] - - sto <- asks _sto - - fromMaybe mempty <$> runMaybeT do - - (_,hd) <- lift (selectRepoList (mempty & set repoListByLww (Just what) & set repoListLimit (Just 1))) - <&> listToMaybe - >>= toMPlus - <&> rlRepoTx - >>= readRepoHeadFromTx sto . coerce - >>= toMPlus - - pure $ view repoHeadRefs hd runScotty :: DashBoardPerks m => DashBoardM m () diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index c1ddb9db..9de7579a 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -15,6 +15,7 @@ import HBS2.Git.DashBoard.Types import HBS2.Hash +import HBS2.Git.Data.RepoHead import HBS2.Git.Data.Tx.Git import HBS2.Git.Local import HBS2.Git.Local.CLI @@ -704,6 +705,47 @@ buildCommitTreeIndex dir = do insertProcessed hkey +gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash + -> m [(GitObjectType, GitHash, Text)] +gitShowTree what hash = do + path <- repoDataPath what + let cmd = [qc|git --git-dir {path} ls-tree {show $ pretty hash}|] + + -- FIXME: extract-method + gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> fmap LBS8.words + <&> mapMaybe \case + [_,tp,h,name] -> do + (,,) <$> fromStringMay (LBS8.unpack tp) + <*> fromStringMay (LBS8.unpack h) + <*> pure (fromString (LBS8.unpack name)) + + _ -> Nothing +gitShowRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> m [(GitRef, GitHash)] + +gitShowRefs what = do + path <- repoDataPath what + let cmd = [qc|git --git-dir {path} show-ref|] + + sto <- asks _sto + + fromMaybe mempty <$> runMaybeT do + + (_,hd) <- lift (selectRepoList (mempty & set repoListByLww (Just what) & set repoListLimit (Just 1))) + <&> listToMaybe + >>= toMPlus + <&> rlRepoTx + >>= readRepoHeadFromTx sto . coerce + >>= toMPlus + + pure $ view repoHeadRefs hd +