mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
817fd837bf
commit
ac3274e9f7
|
|
@ -159,6 +159,8 @@ data WebOptions =
|
|||
{ _assetsOverride :: Maybe FilePath
|
||||
}
|
||||
|
||||
orFall :: m r -> Maybe a -> ContT r m a
|
||||
orFall a mb = ContT $ maybe1 mb a
|
||||
|
||||
runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) ()
|
||||
runDashboardWeb wo = do
|
||||
|
|
@ -175,6 +177,23 @@ runDashboardWeb wo = do
|
|||
get "/" do
|
||||
html =<< lift (renderTextT dashboardRootPage)
|
||||
|
||||
get "/repo/:lww" do
|
||||
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
|
||||
|
||||
env <- lift ask
|
||||
|
||||
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 (repoPage item)
|
||||
|
||||
|
||||
runScotty :: DashBoardPerks m => DashBoardM m ()
|
||||
runScotty = do
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
|
@ -20,15 +21,22 @@ import DBPipe.SQLite.Generic as G
|
|||
import Lucid.Base
|
||||
import Data.Text qualified as Text
|
||||
import Data.Word
|
||||
import Data.List qualified as List
|
||||
|
||||
-- import Data.Generics.Generic (genericDataType)
|
||||
data RepoListPred =
|
||||
RepoListPred
|
||||
{ _repoListByLww :: Maybe (LWWRefKey 'HBS2Basic)
|
||||
, _repoListLimit :: Maybe Int
|
||||
}
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generic.Data -- (gdataDefault, Generically(..))
|
||||
-- import Data.Data (Data)
|
||||
makeLenses 'RepoListPred
|
||||
|
||||
-- import Generics.Deriving.Uniplate qualified as U
|
||||
instance Semigroup RepoListPred where
|
||||
(<>) _ b = mempty & set repoListByLww (view repoListByLww b)
|
||||
& set repoListLimit (view repoListLimit b)
|
||||
|
||||
instance Monoid RepoListPred where
|
||||
mempty = RepoListPred Nothing Nothing
|
||||
|
||||
type MyRefChan = RefChanId L4Proto
|
||||
|
||||
|
|
@ -99,6 +107,11 @@ newtype TxHash = TxHash HashRef
|
|||
deriving stock (Generic)
|
||||
deriving newtype (ToField)
|
||||
|
||||
|
||||
newtype RepoHeadTx = RepoHeadTx HashRef
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
|
||||
newtype RepoName = RepoName Text
|
||||
deriving stock (Eq,Show,Generic)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString)
|
||||
|
|
@ -116,7 +129,7 @@ newtype RepoChannel = RepoChannel MyRefChan
|
|||
|
||||
newtype RepoHeadRef = RepoHeadRef HashRef
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField)
|
||||
deriving newtype (ToField,FromField)
|
||||
|
||||
|
||||
newtype RepoHeadSeq = RepoHeadSeq Word64
|
||||
|
|
@ -203,6 +216,8 @@ data RepoListItem =
|
|||
RepoListItem
|
||||
{ rlRepoLww :: RepoLww
|
||||
, rlRepoSeq :: RepoHeadSeq
|
||||
, rlRepoHead :: RepoHeadRef
|
||||
, rlRepoTx :: RepoHeadTx
|
||||
, rlRepoName :: RepoName
|
||||
, rlRepoBrief :: RepoBrief
|
||||
, rlRepoGK0 :: RepoHeadGK0
|
||||
|
|
@ -218,16 +233,39 @@ rlRepoLwwAsText =
|
|||
|
||||
instance FromRow RepoListItem
|
||||
|
||||
selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoListItem]
|
||||
selectRepoList = fmap fixName <$> withState do
|
||||
select_ @_ @RepoListItem [qc|select r.lww
|
||||
, r.seq
|
||||
, r.name
|
||||
, r.brief
|
||||
, r.gk0
|
||||
from repolistview r
|
||||
|]
|
||||
|
||||
|
||||
selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListPred -> m [RepoListItem]
|
||||
selectRepoList pred = fmap fixName <$> withState do
|
||||
|
||||
let onLww = maybe1 (view repoListByLww pred) mempty $ \w -> [("r.lww = ?", w)]
|
||||
let claus = onLww
|
||||
|
||||
let where_ | List.null claus = "true"
|
||||
| otherwise = Text.intercalate " and " (fmap fst claus)
|
||||
|
||||
let limit_ = case view repoListLimit pred of
|
||||
Nothing -> mempty
|
||||
Just n -> show $ "limit" <+> pretty n
|
||||
|
||||
let params = fmap snd claus
|
||||
|
||||
let sql = [qc|
|
||||
select r.lww
|
||||
, r.seq
|
||||
, r.repohead
|
||||
, r.tx
|
||||
, r.name
|
||||
, r.brief
|
||||
, r.gk0
|
||||
from repolistview r
|
||||
where {where_}
|
||||
{limit_}
|
||||
|]
|
||||
|
||||
debug $ yellow "selectRepoList" <+> pretty sql
|
||||
|
||||
select @RepoListItem sql params
|
||||
where
|
||||
fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed }
|
||||
| otherwise = x
|
||||
|
|
@ -246,6 +284,8 @@ with repolist as (
|
|||
select
|
||||
r.lww,
|
||||
0 as seq,
|
||||
null as repohead,
|
||||
null as tx,
|
||||
coalesce(n.name, r.lww) as name,
|
||||
coalesce(b.brief, '') as brief,
|
||||
null as gk0
|
||||
|
|
@ -256,6 +296,8 @@ with repolist as (
|
|||
select
|
||||
lww,
|
||||
seq,
|
||||
repohead,
|
||||
tx,
|
||||
name,
|
||||
brief,
|
||||
gk0
|
||||
|
|
@ -265,6 +307,8 @@ ranked_repos as (
|
|||
select
|
||||
lww,
|
||||
seq,
|
||||
repohead,
|
||||
tx,
|
||||
name,
|
||||
brief,
|
||||
gk0,
|
||||
|
|
@ -273,20 +317,20 @@ ranked_repos as (
|
|||
order by seq desc
|
||||
)
|
||||
|
||||
select lww, seq, name, brief, gk0
|
||||
select lww, seq, repohead, tx, name, brief, gk0
|
||||
from ranked_repos
|
||||
where rn = 1;
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
||||
createRepoHeadTable :: DashBoardPerks m => DBPipeM m ()
|
||||
createRepoHeadTable = do
|
||||
ddl [qc|
|
||||
create table if not exists repohead
|
||||
( lww text not null
|
||||
, repohead text not null
|
||||
, tx text not null
|
||||
, seq integer not null
|
||||
, gk0 text null
|
||||
, name text
|
||||
|
|
@ -312,15 +356,20 @@ instance HasColumnName RepoHeadSeq where
|
|||
instance HasColumnName RepoHeadGK0 where
|
||||
columnName = "gk0"
|
||||
|
||||
instance HasColumnName RepoHeadTx where
|
||||
columnName = "tx"
|
||||
|
||||
insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> HashRef
|
||||
-> RepoHeadTx
|
||||
-> RepoHeadRef
|
||||
-> RepoHead
|
||||
-> DBPipeM m ()
|
||||
insertRepoHead lww href rh = do
|
||||
insertRepoHead lww tx rf rh = do
|
||||
insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable
|
||||
( RepoLww lww
|
||||
, RepoHeadRef href
|
||||
, rf
|
||||
, tx
|
||||
, RepoHeadSeq (_repoHeadTime rh)
|
||||
, RepoHeadGK0 (_repoHeadGK0 rh)
|
||||
, RepoName (_repoHeadName rh)
|
||||
|
|
|
|||
|
|
@ -57,11 +57,11 @@ updateIndexFromPeer = do
|
|||
for_ txs $ \(n,tx,blk) -> void $ runMaybeT do
|
||||
(rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus
|
||||
debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw
|
||||
lift $ S.yield (lw, rhh, rhead)
|
||||
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead)
|
||||
|
||||
withState $ transactional do
|
||||
for_ headz $ \(l, rh, rhead) -> do
|
||||
insertRepoHead l rh rhead
|
||||
for_ headz $ \(l, tx, rh, rhead) -> do
|
||||
insertRepoHead l tx rh rhead
|
||||
|
||||
-- db <- asks _db
|
||||
|
||||
|
|
|
|||
|
|
@ -5,23 +5,16 @@ import HBS2.Git.DashBoard.Prelude
|
|||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
|
||||
import HBS2.Base58
|
||||
import HBS2.Peer.Proto.RefChan.Types
|
||||
import HBS2.Git.Data.Tx.Git
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Reader
|
||||
import Data.Maybe
|
||||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
import Lucid.Htmx
|
||||
|
||||
import Control.Applicative
|
||||
import Text.Pandoc hiding (getPOSIXTime)
|
||||
import Control.Monad.Identity
|
||||
import System.FilePath
|
||||
import Text.InterpolatedString.Perl6 (q)
|
||||
import Data.Word
|
||||
|
||||
rootPath :: [String] -> [String]
|
||||
|
|
@ -121,8 +114,9 @@ rootPage content = do
|
|||
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
||||
dashboardRootPage = rootPage do
|
||||
|
||||
items <- lift $ selectRepoList mempty
|
||||
|
||||
now <- liftIO getPOSIXTime <&> fromIntegral . round
|
||||
items <- lift selectRepoList
|
||||
|
||||
div_ [class_ "container main"] $ do
|
||||
nav_ [class_ "left"] $ do
|
||||
|
|
@ -144,36 +138,28 @@ dashboardRootPage = rootPage do
|
|||
toHtml (WithTime now item)
|
||||
|
||||
|
||||
pure ()
|
||||
-- for_ channels $ \chan -> void $ runMaybeT do
|
||||
repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
|
||||
repoPage RepoListItem{..} = rootPage do
|
||||
|
||||
-- let title = headDef "unknown" [ t
|
||||
-- | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
|
||||
-- ]
|
||||
-- let desc = mconcat [ d
|
||||
-- | ListVal (SymbolVal "description" : d) <- chan
|
||||
-- ] & take 5
|
||||
sto <- asks _sto
|
||||
mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
|
||||
|
||||
-- rchan <- headMay ( catMaybes
|
||||
-- [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
|
||||
-- | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
|
||||
-- ] ) & toMPlus
|
||||
let manifest = _repoManifest . snd =<< mhead
|
||||
|
||||
debug $ yellow "HEAD" <+> pretty rlRepoTx
|
||||
|
||||
div_ [class_ "container main"] $ do
|
||||
nav_ [class_ "left"] $ do
|
||||
div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
||||
div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
||||
|
||||
main_ do
|
||||
|
||||
section_ [id_ "repo-data"] do
|
||||
h1_ (toHtml $ rlRepoName)
|
||||
|
||||
for_ manifest $ \m -> do
|
||||
toHtmlRaw (renderMarkdown' m)
|
||||
|
||||
|
||||
-- let alias = headMay [ x
|
||||
-- | ListVal [SymbolVal "alias", LitStrVal x] <- chan
|
||||
-- ]
|
||||
|
||||
-- let url = case alias of
|
||||
-- Just x -> Text.unpack x
|
||||
-- Nothing -> (show . pretty . AsBase58) rchan
|
||||
|
||||
-- lift do
|
||||
-- div_ [class_ "channel-list-item"] do
|
||||
-- h2_ $ toHtml title
|
||||
|
||||
-- p_ $ a_ [href_ (path [url])] (toHtml (show $ pretty $ AsBase58 rchan))
|
||||
|
||||
-- for_ [ s | LitStrVal s <- desc ] $ \s -> do
|
||||
-- p_ (toHtml s)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue