diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css index cc8c2468..279a63e5 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -310,3 +310,17 @@ nav[role="tab-control"] li.active { color: #0089D1; } +.mono { + font-family: 'Courier New', Courier, monospace; +} + + +.blob { + width: 16px; + height: 16px; + display: inline-block; + + background-image: url('/icon/file.svg'); + background-size: cover; +} + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob.svg new file mode 100644 index 00000000..cfbcd398 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob.svg @@ -0,0 +1,16 @@ + + + + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg new file mode 100644 index 00000000..cd87bb8e --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg @@ -0,0 +1,4 @@ + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree.svg new file mode 100644 index 00000000..3516f786 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree.svg @@ -0,0 +1,4 @@ + + + + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 372d018a..8fbdf234 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -13,6 +13,8 @@ import HBS2.Polling import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient +import HBS2.Git.Local +import HBS2.Git.Local.CLI import HBS2.Git.Web.Assets import HBS2.Git.DashBoard.State @@ -39,6 +41,7 @@ import Control.Concurrent.STM (flushTQueue) import System.FilePath import System.Process.Typed import System.Directory (XdgDirectory(..),getXdgDirectory) +import Data.ByteString.Lazy.Char8 qualified as LBS8 configParser :: DashBoardPerks m => Parser (m ()) @@ -185,9 +188,6 @@ runDashboardWeb wo = do get "/repo/:lww" do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) - - env <- lift ask - flip runContT pure do lww <- lwws' & orFall (status status404) @@ -200,6 +200,80 @@ runDashboardWeb wo = do lift $ html =<< renderTextT (repoPage item) + get "/repo/:lww/manifest" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + flip runContT pure do + lww <- lwws' & orFall (status status404) + + item <- lift (selectRepoList ( mempty + & set repoListByLww (Just lww) + & set repoListLimit (Just 1)) + ) + <&> listToMaybe + >>= orFall (status status404) + + lift $ html =<< renderTextT (repoManifest item) + + + get "/repo/:lww/refs" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + flip runContT pure do + lww <- lwws' & orFall (status status404) + refs <- lift $ gitShowRefs lww + lift $ html =<< renderTextT (repoRefs lww refs) + + get "/repo/:lww/tree/:hash" do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + hash' <- captureParam @String "hash" <&> fromStringMay @GitHash + back <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<) + + flip runContT pure do + lww <- lwws' & orFall (status status404) + hash <- hash' & orFall (status status404) + tree <- lift $ gitShowTree lww hash + lift $ html =<< renderTextT (repoTree lww hash tree back) + + +repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath +repoDataPath lw = asks _dataDir <&> ( (show $ pretty lw)) >>= canonicalizePath + + +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|] + + -- FIXME: extract-method + gitRunCommand cmd + >>= orThrowUser ("can't read git repo" <+> pretty path) + <&> LBS8.lines + <&> fmap LBS8.words + <&> mapMaybe \case + [val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val) + _ -> Nothing + runScotty :: DashBoardPerks m => DashBoardM m () runScotty = do diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs index 739aecaa..f845d206 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs @@ -17,6 +17,7 @@ module HBS2.Git.DashBoard.Prelude , module Lens.Micro.Platform , module UnliftIO , module Codec.Serialise + , GitRef(..), GitHash(..), GitObjectType(..) , qc, q ) where @@ -41,6 +42,7 @@ import HBS2.Peer.Proto.LWWRef as API import HBS2.Peer.Proto.RefChan.Types as API import HBS2.Peer.Proto.RefChan.RefChanUpdate as API +import HBS2.Git.Local import Data.Config.Suckless as Config diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index e53ffb65..227febf2 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs @@ -21,6 +21,10 @@ import Data.Word import Data.Either import Safe +import Data.ByteString.Char8 qualified as BS8 +import Network.URI (uriToString, parseURI, URI(..), URIAuth(..)) +import Network.HTTP.Types.URI (renderQuery) + import Streaming.Prelude qualified as S rootPath :: [String] -> [String] @@ -161,11 +165,11 @@ repoMenuItem :: Term [Attribute] (t1 -> t2) => [Attribute] -> t1 -> t2 repoMenuItem misc name = li_ ([class_ "tab"] <> misc <> [tabClick]) name -repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () -repoPage RepoListItem{..} = rootPage do +parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text) +parsedManifest RepoListItem{..} = do sto <- asks _sto - mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) + mhead <- readRepoHeadFromTx sto (coerce rlRepoTx) let rawManifest = (_repoManifest . snd =<< mhead) & fromMaybe (coerce rlRepoBrief) @@ -185,6 +189,90 @@ repoPage RepoListItem{..} = rootPage do let manifest = mconcat $ rights w + pure (meta, manifest) + + +repoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () +repoManifest it@RepoListItem{..} = do + (_, manifest) <- lift $ parsedManifest it + toHtmlRaw (renderMarkdown' manifest) + +repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> [(GitRef, GitHash)] + -> HtmlT m () +repoRefs lww refs = do + table_ [] do + for_ refs $ \(r,h) -> do + let link = path [ "repo", show $ pretty lww, "tree", show (pretty h) ] + tr_ mempty do + td_ mempty (toHtml $ show $ pretty r) + td_ [class_ "mono"] $ a_ [ href_ "#" + , hxGet_ link + , hxTarget_ "#repo-tab-data" + ] (toHtml $ show $ pretty h) + + + +repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> [(GitObjectType, GitHash, Text)] + -> Maybe GitHash -- ^ back + -> HtmlT m () + +repoTree lww root tree back' = do + + table_ [] do + tr_ mempty do + + for_ back' $ \root -> do + let rootLink = path [ "repo", show $ pretty lww, "tree", show (pretty root) ] + td_ $ img_ [src_ "/icon/tree-up.svg"] + td_ ".." + td_ do a_ [ href_ "#" + , hxGet_ rootLink + , hxTarget_ "#repo-tab-data" + ] (toHtml $ show $ pretty root) + + for_ tree $ \(tp,h,name) -> do + + let back = show $ pretty root + let backPart = [qc|?back={back}|] + + let link = path [ "repo", show $ pretty lww, "tree", show (pretty h) ] + tr_ mempty do + td_ $ case tp of + Blob -> img_ [src_ "/icon/blob.svg"] + Tree -> img_ [src_ "/icon/tree.svg"] + _ -> mempty + + td_ mempty (toHtml $ show $ pretty name) + td_ [class_ "mono"] do + case tp of + Blob -> do + span_ do + toHtml $ show $ pretty h + + Tree -> do + a_ [ href_ "#" + , hxGet_ (link <> backPart) + , hxTarget_ "#repo-tab-data" + ] (toHtml $ show $ pretty h) + + _ -> mempty + + +repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () +repoPage it@RepoListItem{..} = rootPage do + + let repo = show $ pretty rlRepoLww + + sto <- asks _sto + mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) + + (meta, manifest) <- lift $ parsedManifest it + debug $ yellow "HEAD" <+> pretty rlRepoTx debug $ yellow "META" <+> pretty meta @@ -223,10 +311,18 @@ repoPage RepoListItem{..} = rootPage do nav_ [ role_ "tab-control" ] do repoMenu do repoMenuItem mempty $ a_ [href_ "/"] "root" - repoMenuItem0 mempty "manifest" + + repoMenuItem0 [ hxGet_ (path ["repo", repo, "manifest"]) + , hxTarget_ "#repo-tab-data" + ] "manifest" + + repoMenuItem [ hxGet_ (path ["repo", repo, "refs"]) + , hxTarget_ "#repo-tab-data" + ] "browse" section_ [id_ "repo-data"] do h1_ (toHtml $ rlRepoName) + div_ [id_ "repo-tab-data"] do toHtmlRaw (renderMarkdown' manifest) diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 64a2ad0c..d5495f92 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -163,6 +163,7 @@ executable hbs2-git-dashboard , optparse-applicative , http-types , file-embed + , network-uri , wai , wai-extra , wai-middleware-static