wip

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs

@@ -1,3 +1,4 @@
+{-# Language TemplateHaskell #-}
 module HBS2.Git.Data.RepoHead where
 
 import HBS2.Prelude.Plated
@@ -5,8 +6,15 @@ import HBS2.Data.Types.Refs
 
 import HBS2.Git.Local
 
+import Data.Text qualified as Text
+import Data.ByteString.Char8 qualified as B8
 import Data.Word
 import Codec.Serialise
+import Lens.Micro.Platform
+import Data.Coerce
+import Safe
+import Data.Maybe
+import Data.Set qualified as Set
 
 data RepoHeadType = RepoHeadType1
                     deriving stock (Enum,Generic)
@@ -27,6 +35,22 @@ data RepoHead =
   }
   deriving stock (Generic)
 
+makeLenses ''RepoHead
+
+repoHeadTags :: SimpleGetter RepoHead [Text]
+repoHeadTags =
+  to \RepoHeadSimple{..} -> do
+    catMaybes [ lastMay (B8.split '/' s) <&> (Text.pack . B8.unpack)
+                      | (GitRef s, _)  <- _repoHeadRefs, B8.isPrefixOf "refs/tags" s
+                      ] & Set.fromList & Set.toList
+
+
+repoHeadHeads :: SimpleGetter RepoHead [Text]
+repoHeadHeads =
+  to \RepoHeadSimple{..} -> do
+    catMaybes [ lastMay (B8.split '/' s) <&> (Text.pack . B8.unpack)
+                      | (GitRef s, _)  <- _repoHeadRefs, B8.isPrefixOf "refs/heads" s
+                      ] & Set.fromList & Set.toList
 
 instance Serialise RepoHeadType
 instance Serialise RepoHeadExt

hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -90,6 +90,8 @@ nav.left {
 
 nav.left .info-block {
   margin-bottom: 4rem;
+  padding-left: 1em;
+  padding-right: 1.2em;
 }
 
 section#repo-data {
@@ -204,11 +206,24 @@ div .repo-list-item {
   text-align: right;
 }
 
+.onleft {
+  text-align: left;
+}
+
 .icon {
   flex-basis: 90%;
   text-align: right;
 }
 
+.info-block .attrname {
+  font-size: 0.85rem;
+  font-weight: bolder;
+}
+
+.info-block .attrval {
+  font-size: 0.85rem;
+}
+
 
 form.search {
   display: flex;

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language OverloadedStrings #-}
 module HBS2.Git.Web.Html.Root where
 
 import HBS2.Git.DashBoard.Prelude
@@ -6,6 +7,7 @@ import HBS2.Git.DashBoard.Types
 import HBS2.Git.DashBoard.State
 
 import HBS2.Git.Data.Tx.Git
+import HBS2.Git.Data.RepoHead
 
 import Data.Text qualified as Text
 import Lucid.Base
@@ -16,6 +18,10 @@ import Control.Applicative
 import Text.Pandoc hiding (getPOSIXTime)
 import System.FilePath
 import Data.Word
+import Data.Either
+import Safe
+
+import Streaming.Prelude qualified as S
 
 rootPath :: [String] -> [String]
 rootPath = ("/":)
@@ -138,28 +144,89 @@ dashboardRootPage = rootPage do
           toHtml (WithTime now item)
 
 
+
+tabClick :: Attribute
+tabClick =
+  hyper_ "on click take .active from .tab for event's target"
+
+-- repoMenu :: Monad m => HtmlT m () -> HtmlT m ()
+repoMenu :: Term [Attribute] (t1 -> t2) => t1 -> t2
+repoMenu = ul_ []
+
+
+repoMenuItem0 :: Term [Attribute] (t1 -> t2) => [Attribute] -> t1 -> t2
+repoMenuItem0 misc name = li_ ([class_  "tab active"] <> misc <> [tabClick]) name
+
+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
 
   sto <- asks _sto
   mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
 
-  let manifest = _repoManifest . snd =<< mhead
+  let rawManifest  = (_repoManifest . snd =<< mhead)
+                      & fromMaybe (coerce rlRepoBrief)
+                      & Text.lines
+
+  w <- S.toList_ do
+         flip fix rawManifest $ \next ss -> do
+          case ss of
+            ( "" : rest )  -> S.yield (Right (Text.stripStart (Text.unlines rest)))
+            ( a : rest )   -> S.yield (Left a ) >> next rest
+            [] -> pure ()
+
+  let meta = Text.unlines (lefts w)
+                & Text.unpack
+                & parseTop
+                & fromRight mempty
+
+  let manifest = mconcat $ rights  w
 
   debug $ yellow "HEAD" <+> pretty rlRepoTx
+  debug $ yellow "META" <+> pretty meta
+
+  let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
+  let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
+
 
   div_ [class_ "container main"] $ do
     nav_ [class_ "left"] $ do
-      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
-      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
+
+      div_ [class_ "info-block" ] do
+        for_ author $ \a -> do
+            div_ [ class_ "attr" ] do
+              div_ [ class_ "attrname"] "author:"
+              div_ [ class_ "attrval"] $ toHtml a
+
+        for_ public $ \p -> do
+            div_ [ class_ "attr" ] do
+              div_ [ class_ "attrname"] "public:"
+              div_ [ class_ "attrval"] $ toHtml p
+
+      div_ [class_ "info-block" ] do
+        for_ (snd <$> mhead) $ \rh -> do
+          h6_ [] "heads"
+          for_ (view repoHeadHeads rh) $ \branch -> do
+            div_ [ class_ "attrval onleft"] $ 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
 
     main_ do
 
+      nav_ [ role_ "tab-control" ] do
+       repoMenu do
+        repoMenuItem  mempty $ a_ [href_ "/"] "root"
+        repoMenuItem0 mempty "manifest"
+
       section_ [id_ "repo-data"] do
         h1_ (toHtml $ rlRepoName)
 
-        for_ manifest $ \m -> do
-          toHtmlRaw (renderMarkdown' m)
-
-
+        toHtmlRaw (renderMarkdown' manifest)