diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs index 6476aa9f..1d9a4bf4 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs @@ -37,18 +37,18 @@ data RepoHead = makeLenses ''RepoHead -repoHeadTags :: SimpleGetter RepoHead [Text] +repoHeadTags :: SimpleGetter RepoHead [(GitRef,GitHash)] repoHeadTags = to \h@RepoHeadSimple{} -> do - catMaybes [ lastMay (B8.split '/' s) <&> (Text.pack . B8.unpack) - | (GitRef s, _) <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s + catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef) + | (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s ] & Set.fromList & Set.toList -repoHeadHeads :: SimpleGetter RepoHead [Text] +repoHeadHeads :: SimpleGetter RepoHead [(GitRef,GitHash)] repoHeadHeads = to \h@RepoHeadSimple{} -> do - catMaybes [ lastMay (B8.split '/' s) <&> (Text.pack . B8.unpack) + catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef) | (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/heads" s ] & Set.fromList & Set.toList 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 05d2c6ea..cbe5bda3 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -225,6 +225,18 @@ div .repo-list-item { } +.info-block a { + font-size: inherit; + color: inherit; + text-decoration: none; +} + +.info-block a:hover { + text-decoration: underline dotted 2px black; + color: black; +} + + form.search { display: flex; align-items: center; diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 91650bbc..817606f8 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -171,7 +171,7 @@ data WebOptions = orFall :: m r -> Maybe a -> ContT r m a orFall a mb = ContT $ maybe1 mb a -renderHtml :: MonadIO m => HtmlT (ActionT m) a -> ActionT m () +renderHtml :: forall m a . MonadIO m => HtmlT (ActionT m) a -> ActionT m () renderHtml m = renderTextT m >>= html runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) () @@ -189,21 +189,24 @@ runDashboardWeb wo = do get (routePattern RepoListPage) do renderHtml dashboardRootPage - get (routePattern (RepoPage "lww")) do - lww' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) - flip runContT pure do + get "/:lww" do + lww <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + >>= orThrow (itemNotFound "repository key") - lww <- lww' & orFall (status status404) + redirect (LT.fromStrict $ toURL (RepoPage CommitsTab lww)) - item <- lift (selectRepoList ( mempty - & set repoListByLww (Just lww) - & set repoListLimit (Just 1)) - ) - <&> listToMaybe - >>= orFall (status status404) + get (routePattern (RepoPage "tab" "lww")) do + lww <- captureParam @String "lww" <&> fromStringMay + >>= orThrow (itemNotFound "repository key") - lift $ renderHtml (repoPage item) + tab <- captureParam @String "tab" + <&> fromStringMay + <&> fromMaybe CommitsTab + + qp <- queryParams + + renderHtml (repoPage tab lww qp) get (routePattern (RepoManifest "lww")) do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) @@ -223,12 +226,11 @@ runDashboardWeb wo = do get (routePattern (RepoRefs "lww")) do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) - setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|] + -- setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|] flip runContT pure do lww <- lwws' & orFall (status status404) - refs <- lift $ gitShowRefs lww - lift $ renderHtml (repoRefs lww refs) + lift $ renderHtml (repoRefs lww) get (routePattern (RepoTree "lww" "co" "hash")) do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) @@ -242,10 +244,8 @@ runDashboardWeb wo = do tree <- lift $ gitShowTree lww hash back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash) - let ctx = ViewContext [qc|/repo/{show $ pretty $ lww}/tree/{show $ pretty co}/{show $ pretty hash}|] mempty - debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back - lift $ html =<< renderTextT (repoTree ctx lww co hash tree (coerce <$> back)) + lift $ html =<< renderTextT (repoTree lww co hash tree (coerce <$> back)) get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) @@ -292,7 +292,7 @@ runDashboardWeb wo = do -- FIXME: this referrer <- lift (Scotty.header "Referer") - >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage lww)) + >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage CommitsTab lww)) lift $ renderHtml (repoCommits lww (Left pred)) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs index 011a1fe7..91fc1cd7 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs @@ -18,6 +18,9 @@ import Streaming.Prelude qualified as S {- HLINT ignore "Functor law" -} +class Monoid a => FromQueryParams a where + fromQueryParams :: [(Text,Text)] -> a + data CommitListStyle = CommitListBrief data SelectCommitsPred = @@ -25,19 +28,29 @@ data SelectCommitsPred = { _commitListStyle :: CommitListStyle , _commitPredOffset :: Int , _commitPredLimit :: Int + , _commitRef :: Maybe GitRef } makeLenses ''SelectCommitsPred instance Semigroup SelectCommitsPred where - (<>) _ _ = mempty + (<>) _ b = mempty & set commitListStyle (view commitListStyle b) + & set commitPredOffset (view commitPredOffset b) + & set commitPredLimit (view commitPredLimit b) + & set commitRef (view commitRef b) instance Monoid SelectCommitsPred where - mempty = SelectCommitsPred CommitListBrief 0 100 + mempty = SelectCommitsPred CommitListBrief 0 100 Nothing briefCommits :: SelectCommitsPred briefCommits = mempty + +instance FromQueryParams SelectCommitsPred where + fromQueryParams args = do + let val = headMay [ GitRef (fromString (Text.unpack v)) | ("ref", v) <- args ] + mempty & set commitRef val + newtype Author = Author Text deriving stock (Generic,Data) deriving newtype (Show) @@ -79,10 +92,12 @@ selectCommits lww SelectCommitsPred{..} = do let delim = "|||" :: Text dir <- repoDataPath lww + let what = maybe "--all" (show . pretty) _commitRef + let cmd = case _commitListStyle of CommitListBrief -> do let fmt = [qc|--pretty=format:"%H{delim}%at{delim}%an{delim}%s"|] :: String - [qc|git --git-dir={dir} log --all --max-count {lim} --skip {off} {fmt}|] + [qc|git --git-dir={dir} log {what} --max-count {lim} --skip {off} {fmt}|] debug $ red "selectCommits" <+> pretty cmd 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 9b0d0eaa..cd741008 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 @@ -7,6 +7,8 @@ import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.State.Commits +import HBS2.OrDie + import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.RepoHead @@ -37,14 +39,7 @@ import Data.Kind import Streaming.Prelude qualified as S -data ViewContext = - ViewContext - { _baseUri :: String - , _tab :: Text - } - deriving stock Generic - -instance Serialise ViewContext +import Network.HTTP.Types.Status rootPath :: [String] -> [String] rootPath = ("/":) @@ -65,7 +60,13 @@ data family Tabs a :: Type data RepoListPage = RepoListPage -newtype RepoPage a = RepoPage a +data RepoPageTabs = CommitsTab + | CommitsTabPred GitHash + | ManifestTab + | TreeTab + deriving stock (Eq,Ord,Show) + +data RepoPage s a = RepoPage s a data RepoRefs repo = RepoRefs repo @@ -88,15 +89,37 @@ data RepoCommitPatchQ repo commit = RepoCommitPatchQ repo commit toArg :: (Semigroup a, IsString a) => a -> a toArg s = ":" <> s +toPattern :: Text -> RoutePattern +toPattern = fromString . Text.unpack + +instance Pretty RepoPageTabs where + pretty = \case + CommitsTab -> "commits" + CommitsTabPred{} -> "commits" + ManifestTab -> "manifest" + TreeTab -> "tree" + +instance FromStringMaybe RepoPageTabs where + fromStringMay = \case + "commits" -> pure CommitsTab + "manifest" -> pure ManifestTab + "tree" -> pure TreeTab + _ -> pure CommitsTab + instance ToRoutePattern RepoListPage where routePattern = \case RepoListPage -> "/" -instance ToURL (RepoPage (LWWRefKey 'HBS2Basic)) where - toURL (RepoPage w) = path @String [ "/", show (pretty w) ] +instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where + toURL (RepoPage s w) = path @String [ "/", show (pretty s), show (pretty w)] + <> pred_ + where + pred_ = case s of + CommitsTabPred p -> Text.pack $ "?ref=" <> show (pretty p) + _ -> mempty -instance ToRoutePattern (RepoPage String) where - routePattern (RepoPage w) = fromString ("/" <> toArg w) +instance ToRoutePattern (RepoPage String String) where + routePattern (RepoPage s w) = path ["/", toArg s, toArg w] & toPattern instance ToURL RepoListPage where toURL _ = "/" @@ -107,7 +130,7 @@ instance ToURL (RepoRefs (LWWRefKey 'HBS2Basic)) where repo = show $ pretty repo' instance ToRoutePattern (RepoRefs String) where - routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & Text.unpack & fromString + routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & toPattern instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash) where @@ -119,7 +142,7 @@ instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash) where instance ToRoutePattern (RepoTree String String String) where routePattern (RepoTree r co tree) = - path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & Text.unpack & fromString + path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & toPattern instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash) where toURL (RepoBlob k co t bo) = path ["/", "htmx", "blob", repo, commit, tree, blob] @@ -131,7 +154,7 @@ instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash) where instance ToRoutePattern (RepoBlob String String String String) where routePattern (RepoBlob r c t b) = - path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & Text.unpack & fromString + path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & toPattern instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic)) where toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo] @@ -139,7 +162,7 @@ instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic)) where repo = show $ pretty repo' instance ToRoutePattern (RepoManifest String) where - routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & Text.unpack & fromString + routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & toPattern instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic)) where toURL (RepoCommits repo') = path ["/", "htmx", "commits", repo] @@ -147,7 +170,7 @@ instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic)) where repo = show $ pretty repo' instance ToRoutePattern (RepoCommits String) where - routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & Text.unpack & fromString + routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & toPattern instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int) where toURL (RepoCommitsQ repo' off lim) = path ["/", "htmx", "commits", repo, show off, show lim] @@ -155,7 +178,8 @@ instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int) where repo = show $ pretty repo' instance ToRoutePattern (RepoCommitsQ String String String) where - routePattern (RepoCommitsQ r o l) = path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & Text.unpack & fromString + routePattern (RepoCommitsQ r o l) = + path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & toPattern instance ToURL (RepoCommitDefault (LWWRefKey 'HBS2Basic) GitHash) where toURL (RepoCommitDefault repo' h) = toURL (RepoCommitSummaryQ repo' h) @@ -170,7 +194,8 @@ instance ToURL (RepoCommitSummaryQ (LWWRefKey 'HBS2Basic) GitHash) where ha = show $ pretty h instance ToRoutePattern (RepoCommitSummaryQ String String) where - routePattern (RepoCommitSummaryQ r h) = path ["/", "htmx", "commit", "summary", toArg r, toArg h] & Text.unpack & fromString + routePattern (RepoCommitSummaryQ r h) = + path ["/", "htmx", "commit", "summary", toArg r, toArg h] & toPattern instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash) where toURL (RepoCommitPatchQ repo' h) = path ["/", "htmx", "commit", "patch", repo, ha] @@ -179,7 +204,8 @@ instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash) where ha = show $ pretty h instance ToRoutePattern (RepoCommitPatchQ String String) where - routePattern (RepoCommitPatchQ r h) = path ["/", "htmx", "commit", "patch", toArg r, toArg h] & Text.unpack & fromString + routePattern (RepoCommitPatchQ r h) = + path ["/", "htmx", "commit", "patch", toArg r, toArg h] & toPattern myCss :: Monad m => HtmlT m () @@ -224,6 +250,11 @@ agePure t0 t = do | sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago" | otherwise -> pretty (sec `div` 60) <+> "minutes ago" + +instance ToHtml GitRef where + toHtml (GitRef s)= toHtml s + toHtmlRaw (GitRef s)= toHtmlRaw s + instance ToHtml (WithTime RepoListItem) where toHtmlRaw = pure mempty @@ -233,7 +264,7 @@ instance ToHtml (WithTime RepoListItem) where let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0 - let url = toURL (RepoPage (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww)) + let url = toURL (RepoPage CommitsTab (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww)) -- path ["repo", Text.unpack $ view rlRepoLwwAsText it] let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq @@ -353,9 +384,9 @@ thisRepoManifest it@RepoListItem{..} = do repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic - -> [(GitRef, GitHash)] -> HtmlT m () -repoRefs lww refs = do +repoRefs lww = do + refs <- lift $ gitShowRefs lww table_ [] do for_ refs $ \(r,h) -> do let r_ = Text.pack $ show $ pretty r @@ -421,15 +452,14 @@ treeLocator lww co locator next = do next repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) - => ViewContext - -> LWWRefKey 'HBS2Basic + => LWWRefKey 'HBS2Basic -> GitHash -- ^ this -> GitHash -- ^ this -> [(GitObjectType, GitHash, Text)] -> Maybe GitHash -- ^ back -> HtmlT m () -repoTree ctx lww co root tree back' = do +repoTree lww co root tree back' = do let syntaxMap = Sky.defaultSyntaxMap @@ -439,8 +469,6 @@ repoTree ctx lww co root tree back' = do tpOrder Blob = 1 tpOrder _ = 2 - let wtf = show $ pretty $ AsBase58 (serialise ctx) - locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root) table_ [] do @@ -724,11 +752,24 @@ repoBlob lww co tree BlobInfo{..} = do let code = renderText (Lucid.formatHtmlBlock fo tokens) toHtmlRaw code -repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () -repoPage it@RepoListItem{..} = rootPage do - let lww = rlRepoLww & coerce - let repo = show $ pretty lww +raiseStatus :: forall m . MonadIO m => Status -> Text -> m () +raiseStatus s t = throwIO (StatusError s t) + +itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s) + +repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) + => RepoPageTabs + -> LWWRefKey 'HBS2Basic + -> [(Text,Text)] + -> HtmlT m () +repoPage tab lww params = rootPage do + + it@RepoListItem{..} <- lift (selectRepoList ( mempty + & set repoListByLww (Just lww) + & set repoListLimit (Just 1)) + <&> listToMaybe + ) >>= orThrow (itemNotFound lww) sto <- asks _sto mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) @@ -738,6 +779,8 @@ repoPage it@RepoListItem{..} = rootPage do let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ] let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ] + let setActive True = class_ "tab active" + setActive False = class_ mempty div_ [class_ "container main"] $ do nav_ [class_ "left"] $ do @@ -756,14 +799,17 @@ repoPage it@RepoListItem{..} = rootPage do div_ [class_ "info-block" ] do for_ (snd <$> mhead) $ \rh -> do h6_ [] "heads" - for_ (view repoHeadHeads rh) $ \branch -> do - div_ [ class_ "attrval onleft"] $ toHtml branch + for_ (view repoHeadHeads rh) $ \(branch,v) -> do + div_ [ class_ "attrval onleft"] do + a_ [ href_ (toURL (RepoPage (CommitsTabPred v) lww )) + ] $ toHtml branch div_ [class_ "info-block" ] do for_ (snd <$> mhead) $ \rh -> do h6_ [] "tags" - for_ (view repoHeadTags rh) $ \tag -> do - div_ [ class_ "attrval onleft"] $ toHtml tag + for_ (view repoHeadTags rh) $ \(tag,v) -> do + div_ [ class_ "attrval onleft"] do + a_ [href_ (toURL (RepoPage (CommitsTabPred v) lww ))] $ toHtml tag main_ do @@ -771,15 +817,17 @@ repoPage it@RepoListItem{..} = rootPage do repoMenu do repoMenuItem mempty $ a_ [href_ "/"] "root" - repoMenuItem0 [ hxGet_ (toURL (RepoCommits lww)) - , hxTarget_ "#repo-tab-data" - ] "commits" + let menu t = if tab == t then repoMenuItem0 else repoMenuItem - repoMenuItem [ hxGet_ (toURL (RepoManifest lww)) - , hxTarget_ "#repo-tab-data" - ] "manifest" + menu CommitsTab [ hxGet_ (toURL (RepoCommits lww)) + , hxTarget_ "#repo-tab-data" + ] "commits" - repoMenuItem [ hxGet_ (toURL (RepoRefs lww)) + menu ManifestTab [ hxGet_ (toURL (RepoManifest lww)) + , hxTarget_ "#repo-tab-data" + ] "manifest" + + menu TreeTab [ hxGet_ (toURL (RepoRefs lww)) , hxTarget_ "#repo-tab-data" ] "tree" @@ -787,6 +835,21 @@ repoPage it@RepoListItem{..} = rootPage do h1_ (toHtml $ rlRepoName) div_ [id_ "repo-tab-data"] do - let predicate = Right mempty - repoCommits lww predicate + + case tab of + + TreeTab -> do + repoRefs lww + + ManifestTab -> do + thisRepoManifest it + + CommitsTab -> do + let predicate = Right (fromQueryParams params) + repoCommits lww predicate + + CommitsTabPred _ -> do + let predicate = Right (fromQueryParams params) + repoCommits lww predicate +