mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
4f22180ab6
commit
817fd837bf
|
|
@ -21,6 +21,15 @@ import Lucid.Base
|
|||
import Data.Text qualified as Text
|
||||
import Data.Word
|
||||
|
||||
-- import Data.Generics.Generic (genericDataType)
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generic.Data -- (gdataDefault, Generically(..))
|
||||
-- import Data.Data (Data)
|
||||
|
||||
-- import Generics.Deriving.Uniplate qualified as U
|
||||
|
||||
|
||||
type MyRefChan = RefChanId L4Proto
|
||||
|
||||
|
||||
|
|
@ -76,6 +85,9 @@ evolveDB = do
|
|||
instance ToField HashRef where
|
||||
toField x = toField $ show $ pretty x
|
||||
|
||||
instance FromField HashRef where
|
||||
fromField = fmap (fromString @HashRef) . fromField @String
|
||||
|
||||
instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where
|
||||
toField x = toField $ show $ pretty (AsBase58 x)
|
||||
|
||||
|
|
@ -88,8 +100,8 @@ newtype TxHash = TxHash HashRef
|
|||
deriving newtype (ToField)
|
||||
|
||||
newtype RepoName = RepoName Text
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,ToHtml)
|
||||
deriving stock (Eq,Show,Generic)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString)
|
||||
|
||||
newtype RepoBrief = RepoBrief Text
|
||||
deriving stock (Generic)
|
||||
|
|
@ -97,7 +109,7 @@ newtype RepoBrief = RepoBrief Text
|
|||
|
||||
newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
|
||||
newtype RepoChannel = RepoChannel MyRefChan
|
||||
|
||||
|
|
@ -109,12 +121,12 @@ newtype RepoHeadRef = RepoHeadRef HashRef
|
|||
|
||||
newtype RepoHeadSeq = RepoHeadSeq Word64
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField)
|
||||
deriving newtype (ToField,FromField)
|
||||
|
||||
|
||||
newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField)
|
||||
deriving newtype (ToField,FromField)
|
||||
|
||||
instance ToField RepoChannel where
|
||||
toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x)
|
||||
|
|
@ -185,28 +197,41 @@ getIndexEntries = do
|
|||
pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
||||
|
||||
|
||||
data NiceTS = NiceTS
|
||||
|
||||
data RepoListItem =
|
||||
RepoListItem
|
||||
{ rlRepoLww :: RepoLww
|
||||
, rlRepoSeq :: RepoHeadSeq
|
||||
, rlRepoName :: RepoName
|
||||
, rlRepoBrief :: RepoBrief
|
||||
, rlRepoGK0 :: RepoHeadGK0
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
-- deriving instance Data RepoListItem via Generically RepoListItem
|
||||
|
||||
rlRepoLwwAsText :: SimpleGetter RepoListItem Text
|
||||
rlRepoLwwAsText =
|
||||
to \RepoListItem{..} -> do
|
||||
Text.pack $ show $ pretty $ rlRepoLww
|
||||
|
||||
instance FromRow RepoListItem
|
||||
|
||||
selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoListItem]
|
||||
selectRepoList = withState do
|
||||
select_ @_ @RepoListItem [qc|select
|
||||
r.lww
|
||||
, n.name
|
||||
, b.brief
|
||||
from repo r join name n on r.lww = n.lww
|
||||
join brief b on b.lww = r.lww
|
||||
selectRepoList = fmap fixName <$> withState do
|
||||
select_ @_ @RepoListItem [qc|select r.lww
|
||||
, r.seq
|
||||
, r.name
|
||||
, r.brief
|
||||
, r.gk0
|
||||
from repolistview r
|
||||
|]
|
||||
|
||||
|
||||
|
||||
where
|
||||
fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed }
|
||||
| otherwise = x
|
||||
where fixed = Text.pack (show $ pretty (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww) ) & RepoName
|
||||
|
||||
createRepoListView :: DashBoardPerks m => DBPipeM m ()
|
||||
createRepoListView = do
|
||||
|
|
@ -222,7 +247,8 @@ with repolist as (
|
|||
r.lww,
|
||||
0 as seq,
|
||||
coalesce(n.name, r.lww) as name,
|
||||
coalesce(b.brief, '') as brief
|
||||
coalesce(b.brief, '') as brief,
|
||||
null as gk0
|
||||
from repo r
|
||||
left join name n on r.lww = n.lww
|
||||
left join brief b on r.lww = b.lww
|
||||
|
|
@ -231,7 +257,8 @@ with repolist as (
|
|||
lww,
|
||||
seq,
|
||||
name,
|
||||
brief
|
||||
brief,
|
||||
gk0
|
||||
from repohead
|
||||
),
|
||||
ranked_repos as (
|
||||
|
|
@ -240,17 +267,20 @@ ranked_repos as (
|
|||
seq,
|
||||
name,
|
||||
brief,
|
||||
gk0,
|
||||
row_number() over (partition by lww order by seq desc) as rn
|
||||
from repolist
|
||||
order by seq desc
|
||||
)
|
||||
|
||||
select lww, seq, name, brief
|
||||
select lww, seq, name, brief, gk0
|
||||
from ranked_repos
|
||||
where rn = 1;
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
||||
createRepoHeadTable :: DashBoardPerks m => DBPipeM m ()
|
||||
createRepoHeadTable = do
|
||||
ddl [qc|
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module HBS2.Git.Web.Html.Root where
|
||||
|
||||
import HBS2.Prelude
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
|
||||
|
|
@ -17,11 +16,13 @@ import Data.Maybe
|
|||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
import Lucid.Htmx
|
||||
|
||||
import Text.Pandoc hiding (getPOSIXTime)
|
||||
import Control.Monad.Identity
|
||||
import System.FilePath
|
||||
import Text.InterpolatedString.Perl6 (q)
|
||||
import Data.Word
|
||||
|
||||
rootPath :: [String] -> [String]
|
||||
rootPath = ("/":)
|
||||
|
|
@ -33,8 +34,12 @@ myCss :: Monad m => HtmlT m ()
|
|||
myCss = do
|
||||
link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]
|
||||
|
||||
hyper_ :: Text -> Attribute
|
||||
hyper_ = makeAttribute "_"
|
||||
|
||||
|
||||
onClickCopy :: Text -> Attribute
|
||||
onClickCopy s =
|
||||
hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|]
|
||||
|
||||
markdownToHtml :: Text -> Either PandocError String
|
||||
markdownToHtml markdown = runPure $ do
|
||||
|
|
@ -54,7 +59,45 @@ renderMarkdown markdown = case markdownToHtml markdown of
|
|||
|
||||
instance ToHtml RepoBrief where
|
||||
toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
||||
toHtmlRaw (RepoBrief txt) = toHtmlRaw ("JOPA:" <> renderMarkdown' txt)
|
||||
toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
||||
|
||||
data WithTime a = WithTime Integer a
|
||||
|
||||
instance ToHtml (WithTime RepoListItem) where
|
||||
toHtmlRaw = pure mempty
|
||||
|
||||
toHtml (WithTime t it@RepoListItem{..}) = do
|
||||
|
||||
let now = t
|
||||
|
||||
let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0
|
||||
|
||||
let url = path ["repo", Text.unpack $ view rlRepoLwwAsText it]
|
||||
let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq
|
||||
|
||||
let updated = "" <+> d
|
||||
where
|
||||
sec = now - t
|
||||
d | sec > 86400 = pretty (sec `div` 86400) <+> "days ago"
|
||||
| sec > 3600 = pretty (sec `div` 3600) <+> "hours ago"
|
||||
| otherwise = pretty (sec `div` 60) <+> "minutes ago"
|
||||
|
||||
div_ [class_ "repo-list-item"] do
|
||||
div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do
|
||||
|
||||
h2_ [class_ "xclip", onClickCopy (view rlRepoLwwAsText it)] $ toHtml rlRepoName
|
||||
p_ $ a_ [href_ url] (toHtml $ view rlRepoLwwAsText it)
|
||||
|
||||
toHtml rlRepoBrief
|
||||
|
||||
div_ [ ] do
|
||||
div_ [ class_ "attr" ] do
|
||||
div_ [ class_ "attrname"] (toHtml $ show updated)
|
||||
|
||||
when locked do
|
||||
div_ [ class_ "attr" ] do
|
||||
div_ [ class_ "attrval icon"] do
|
||||
img_ [src_ "/icon/lock-closed.svg"]
|
||||
|
||||
rootPage :: Monad m => HtmlT m () -> HtmlT m ()
|
||||
rootPage content = do
|
||||
|
|
@ -78,6 +121,7 @@ rootPage content = do
|
|||
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
||||
dashboardRootPage = rootPage do
|
||||
|
||||
now <- liftIO getPOSIXTime <&> fromIntegral . round
|
||||
items <- lift selectRepoList
|
||||
|
||||
div_ [class_ "container main"] $ do
|
||||
|
|
@ -96,46 +140,8 @@ dashboardRootPage = rootPage do
|
|||
|
||||
section_ [id_ "repo-search-results"] do
|
||||
|
||||
for_ items $ \RepoListItem{..} -> do
|
||||
|
||||
-- let t = coerce @_ @Word64 listEntrySeq
|
||||
-- let h = coerce @_ @(LWWRefKey HBS2Basic) listEntryRef
|
||||
-- let n = coerce @_ @(Maybe Text) listEntryName & fromMaybe ""
|
||||
-- let b = coerce @_ @(Maybe Text) listEntryBrief & fromMaybe ""
|
||||
-- let locked = listEntryGK0 & coerce @_ @(Maybe HashRef) & isJust
|
||||
|
||||
-- let days = "updated" <+> if d == 0 then "today" else viaShow d <+> "days ago"
|
||||
-- where d = ( now - t ) `div` 86400
|
||||
|
||||
-- let s = if Text.length n > 2 then n else "unnamed"
|
||||
-- let refpart = Text.take 8 $ Text.pack $ show $ pretty h
|
||||
-- let sref = show $ pretty h
|
||||
-- let ref = Text.pack sref
|
||||
|
||||
-- let suff = ["repo", sref]
|
||||
|
||||
-- let url = path (hrefBase <> suff)
|
||||
|
||||
div_ [class_ "repo-list-item"] do
|
||||
div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do
|
||||
|
||||
h2_ $ toHtml rlRepoName
|
||||
-- [class_ "xclip", onClickCopy ref] $ toHtml (s <> "-" <> refpart)
|
||||
|
||||
-- p_ $ a_ [href_ url] (toHtml ref)
|
||||
|
||||
toHtml rlRepoBrief
|
||||
-- renderMarkdown b
|
||||
|
||||
-- div_ [ ] do
|
||||
-- div_ [ class_ "attr" ] do
|
||||
-- div_ [ class_ "attrname"] (toHtml $ show days)
|
||||
|
||||
-- when locked do
|
||||
-- div_ [ class_ "attr" ] do
|
||||
-- div_ [ class_ "attrval icon"] do
|
||||
-- img_ [src_ "/icon/lock-closed.svg"]
|
||||
|
||||
for_ items $ \item@RepoListItem{..} -> do
|
||||
toHtml (WithTime now item)
|
||||
|
||||
|
||||
pure ()
|
||||
|
|
|
|||
|
|
@ -156,6 +156,9 @@ executable hbs2-git-dashboard
|
|||
build-depends:
|
||||
base, hbs2-git-dashboard-assets, hbs2-peer, hbs2-git, suckless-conf
|
||||
, binary
|
||||
, generic-deriving
|
||||
, generic-data
|
||||
, deriving-compat
|
||||
, vector
|
||||
, optparse-applicative
|
||||
, http-types
|
||||
|
|
|
|||
Loading…
Reference in New Issue