wip

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)
+    catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef)
-                      | (GitRef s, _)  <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s
+                      | (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
 

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;

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
+  get (routePattern (RepoPage "tab" "lww")) do
-                                      & set repoListByLww (Just lww)
+    lww <- captureParam @String "lww"  <&> fromStringMay
-                                      & set repoListLimit (Just 1))
+                >>= orThrow (itemNotFound "repository key")
-                                   )
-                 <&> listToMaybe
-                 >>= orFall (status status404)
 
-      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)
-      lift $ renderHtml (repoRefs lww refs)
 
   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))
 

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
 

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 =
+import Network.HTTP.Types.Status
-  ViewContext
-  { _baseUri :: String
-  , _tab     :: Text
-  }
-  deriving stock Generic
-
-instance Serialise ViewContext
 
 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
+instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where
-  toURL (RepoPage w)  = path @String [ "/", show (pretty w) ]
+  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
+instance ToRoutePattern (RepoPage String String) where
-  routePattern (RepoPage w) = fromString ("/" <> toArg w)
+  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
+raiseStatus :: forall m . MonadIO m => Status -> Text -> m ()
-  let repo = show $ pretty lww
+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
+          for_ (view repoHeadHeads rh) $ \(branch,v) -> do
-            div_ [ class_ "attrval onleft"] $ toHtml branch
+            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
+          for_ (view repoHeadTags rh) $ \(tag,v) -> do
-            div_ [ class_ "attrval onleft"] $ toHtml tag
+            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))
+        let menu t = if tab == t then repoMenuItem0 else repoMenuItem
-                      , hxTarget_ "#repo-tab-data"
-                      ] "commits"
 
-        repoMenuItem [ hxGet_ (toURL (RepoManifest lww))
+        menu CommitsTab [ hxGet_ (toURL (RepoCommits lww))
-                     , hxTarget_ "#repo-tab-data"
+                        , hxTarget_ "#repo-tab-data"
-                     ] "manifest"
+                        ] "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
+