mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 16:24:52 +09:00
C2S, UI: Loom creation and Repo linking to a Loom
RepoSourceR, for a repo that doesn't have a loom, lists looms that want to serve that repo with buttons for bidirectionally linking the repo to a loom Once linked, the repo navbar has a Patches/MRs link pointing to the LoomClothsR of the linked Loom
This commit is contained in:
fr33domlover
parent
1c8c6d9d24
commit
c495d78d05
15 changed files with 598 additions and 27 deletions
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -21,10 +21,14 @@ module Data.Aeson.Local
|
|||
, (.:|?)
|
||||
, (.:+)
|
||||
, (.:+?)
|
||||
, (.:*)
|
||||
, (.:*+)
|
||||
, (.=?)
|
||||
, (.=%)
|
||||
, (.=+)
|
||||
, (.=+?)
|
||||
, (.=*)
|
||||
, (.=*+)
|
||||
, WithValue (..)
|
||||
)
|
||||
where
|
||||
|
|
@ -32,6 +36,7 @@ where
|
|||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types (Parser)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Text (Text)
|
||||
import Network.URI
|
||||
|
||||
|
|
@ -58,7 +63,7 @@ fromEither (Right y) = Right' y
|
|||
(.:|) :: FromJSON a => Object -> Text -> Parser a
|
||||
o .:| t = o .: t <|> o .: (frg <> t)
|
||||
where
|
||||
frg = "https://forgefed.peers.community/ns#"
|
||||
frg = "https://forgefed.org/ns#"
|
||||
|
||||
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
o .:|? t = optional $ o .:| t
|
||||
|
|
@ -71,6 +76,26 @@ o .:+ t = Left <$> o .: t <|> Right <$> o .: t
|
|||
=> Object -> Text -> Parser (Maybe (Either a b))
|
||||
o .:+? t = optional $ o .:+ t
|
||||
|
||||
-- | For JSON-LD properties that aren't functional, i.e. can have any number of
|
||||
-- values
|
||||
(.:*) :: FromJSON a => Object -> Text -> Parser [a]
|
||||
o .:* t = do
|
||||
maybeOneOrArray <- o .:+? t
|
||||
case maybeOneOrArray of
|
||||
Nothing -> return []
|
||||
Just (Left v) -> return [v]
|
||||
Just (Right vs) -> return vs
|
||||
|
||||
-- | For JSON-LD properties that aren't functional, i.e. can have any number of
|
||||
-- values
|
||||
(.:*+) :: FromJSON a => Object -> Text -> Parser (NonEmpty a)
|
||||
o .:*+ t = do
|
||||
oneOrArray <- o .:+ t
|
||||
case oneOrArray of
|
||||
Left v -> return $ v :| []
|
||||
Right [] -> fail $ "No values for " ++ T.unpack t
|
||||
Right (v:vs) -> return $ v :| vs
|
||||
|
||||
infixr 8 .=?
|
||||
(.=?) :: ToJSON v => Text -> Maybe v -> Series
|
||||
_ .=? Nothing = mempty
|
||||
|
|
@ -93,6 +118,17 @@ infixr 8 .=+?
|
|||
k .=+? Nothing = mempty
|
||||
k .=+? (Just v) = k .=+ v
|
||||
|
||||
infixr 8 .=*
|
||||
(.=*) :: ToJSON a => Text -> [a] -> Series
|
||||
_ .=* [] = mempty
|
||||
k .=* [v] = k .= v
|
||||
k .=* vs = k .= vs
|
||||
|
||||
infixr 8 .=*+
|
||||
(.=*+) :: ToJSON a => Text -> NonEmpty a -> Series
|
||||
k .=*+ (v :| []) = k .= v
|
||||
k .=*+ (v :| vs) = k .= (v:vs)
|
||||
|
||||
data WithValue a = WithValue
|
||||
{ wvRaw :: Object
|
||||
, wvParsed :: a
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ module Vervis.API
|
|||
, applyC
|
||||
, noteC
|
||||
, createNoteC
|
||||
, createPatchTrackerC
|
||||
, createRepositoryC
|
||||
, createTicketTrackerC
|
||||
, followC
|
||||
|
|
@ -1277,6 +1278,276 @@ verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips =
|
|||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
-}
|
||||
|
||||
createPatchTrackerC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Audience URIMode
|
||||
-> AP.ActorDetail
|
||||
-> NonEmpty FedURI
|
||||
-> Maybe (Host, AP.ActorLocal URIMode)
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
createPatchTrackerC (Entity pidUser personUser) senderActor summary audience detail repos mlocal muTarget = do
|
||||
|
||||
-- Check input
|
||||
verifyNothingE mlocal "'id' not allowed in new PatchTracker to create"
|
||||
(name, msummary) <- parseDetail detail
|
||||
repoID <- parseRepo repos
|
||||
senderHash <- encodeKeyHashid pidUser
|
||||
now <- liftIO getCurrentTime
|
||||
verifyNothingE muTarget "'target' not supported in Create PatchTracker"
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create PatchTracker with no recipients"
|
||||
checkFederation remoteRecips
|
||||
|
||||
(obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
|
||||
|
||||
-- Find the specified repo in DB
|
||||
_ <- getE repoID "No such repo in DB"
|
||||
|
||||
-- Make sure the repo has a single, full-access collab, granted to the
|
||||
-- sender of this Create
|
||||
maybeApproved <- lift $ runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
guard $ recipID == pidUser
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
|
||||
return ()
|
||||
unless (isJust maybeApproved) $
|
||||
throwE "Repo's collabs unexpected state"
|
||||
|
||||
-- Insert new loom to DB
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
(loomID, Entity loomActorID loomActor) <-
|
||||
lift $ insertLoom now name msummary obiidCreate repoID
|
||||
|
||||
-- Insert the Create activity to author's outbox
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash
|
||||
|
||||
-- Deliver the Create activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpCreate <- do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[LocalActorRepo repoHash]
|
||||
[ LocalStagePersonFollowers senderHash
|
||||
, LocalStageRepoFollowers repoHash
|
||||
]
|
||||
moreRemoteRecips <-
|
||||
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) obiidCreate $
|
||||
localRecipSieve sieve False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
|
||||
|
||||
-- Insert collaboration access for loom's creator
|
||||
let loomOutboxID = actorOutbox loomActor
|
||||
obiidGrant <- lift $ insertEmptyOutboxItem loomOutboxID now
|
||||
lift $ insertCollab loomID obiidGrant
|
||||
|
||||
-- Insert a Grant activity to loom's outbox
|
||||
let grantRecipActors = [LocalActorPerson senderHash]
|
||||
grantRecipStages = [LocalStagePersonFollowers senderHash]
|
||||
docGrant <-
|
||||
lift $ insertGrantToOutbox senderHash loomHash obiidCreate obiidGrant grantRecipActors grantRecipStages
|
||||
|
||||
-- Deliver the Grant activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpGrant <- do
|
||||
remoteRecips <-
|
||||
lift $ deliverLocal' True (LocalActorLoom loomHash) loomActorID obiidGrant $
|
||||
makeRecipientSet grantRecipActors grantRecipStages
|
||||
checkFederation remoteRecips
|
||||
lift $ deliverRemoteDB'' [] obiidGrant [] remoteRecips
|
||||
|
||||
-- Insert follow record
|
||||
obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
obiidAccept <- lift $ insertEmptyOutboxItem loomOutboxID now
|
||||
lift $ insert_ $ Follow (personActor personUser) (actorFollowers loomActor) True obiidFollow obiidAccept
|
||||
|
||||
-- Insert a Follow activity to sender's outbox, and an Accept to the
|
||||
-- loom's outbox
|
||||
luFollow <- lift $ insertFollowToOutbox senderHash loomHash obiidFollow
|
||||
lift $ insertAcceptToOutbox senderHash loomHash obiidAccept luFollow
|
||||
|
||||
-- Deliver the Follow and Accept by simply manually inserting them to
|
||||
-- loom and sender inboxes respectively
|
||||
lift $ do
|
||||
ibiidF <- insert $ InboxItem False now
|
||||
insert_ $ InboxItemLocal (actorInbox loomActor) obiidFollow ibiidF
|
||||
ibiidA <- insert $ InboxItem False now
|
||||
insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return
|
||||
( obiidCreate
|
||||
, deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate
|
||||
, deliverRemoteHttp' [] obiidGrant docGrant remoteRecipsHttpGrant
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Create and Grant
|
||||
lift $ do
|
||||
forkWorker "createPatchTrackerC: async HTTP Create delivery" deliverHttpCreate
|
||||
forkWorker "createPatchTrackerC: async HTTP Grant delivery" deliverHttpGrant
|
||||
|
||||
return obiid
|
||||
|
||||
where
|
||||
|
||||
parseDetail (AP.ActorDetail typ muser mname msummary) = do
|
||||
unless (typ == AP.ActorTypePatchTracker) $
|
||||
error "createPatchTrackerC: Create object isn't a PatchTracker"
|
||||
verifyNothingE muser "PatchTracker can't have a username"
|
||||
name <- fromMaybeE mname "PatchTracker doesn't specify name"
|
||||
return (name, msummary)
|
||||
|
||||
parseRepo (ObjURI h lu :| us) = do
|
||||
unless (null us) $ throwE "More than one repo is specified"
|
||||
hl <- hostIsLocal h
|
||||
unless hl $ throwE "A remote repo is specified"
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Not a valid route"
|
||||
case route of
|
||||
RepoR repoHash -> decodeKeyHashidE repoHash "Invalid repo hash"
|
||||
_ -> throwE "Not a repo route"
|
||||
|
||||
insertLoom now name msummary obiidCreate repoID = do
|
||||
actor@(Entity actorID _) <-
|
||||
insertActor now name (fromMaybe "" msummary)
|
||||
loomID <- insert Loom
|
||||
{ loomNextTicket = 1
|
||||
, loomActor = actorID
|
||||
, loomRepo = repoID
|
||||
, loomCreate = obiidCreate
|
||||
}
|
||||
return (loomID, actor)
|
||||
|
||||
insertCreateToOutbox senderHash now blinded name msummary obiidCreate loomHash repoHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhid <- encodeKeyHashid obiidCreate
|
||||
let ptdetail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypePatchTracker
|
||||
, AP.actorUsername = Nothing
|
||||
, AP.actorName = Just name
|
||||
, AP.actorSummary = msummary
|
||||
}
|
||||
ptlocal = AP.ActorLocal
|
||||
{ AP.actorId = encodeRouteLocal $ LoomR loomHash
|
||||
, AP.actorInbox = encodeRouteLocal $ LoomInboxR loomHash
|
||||
, AP.actorOutbox = Nothing
|
||||
, AP.actorFollowers = Nothing
|
||||
, AP.actorFollowing = Nothing
|
||||
, AP.actorPublicKeys = []
|
||||
, AP.actorSshKeys = []
|
||||
}
|
||||
repo = encodeRouteHome $ RepoR repoHash
|
||||
create = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activityFulfills = []
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = CreatePatchTracker ptdetail (repo :| []) (Just (hLocal, ptlocal))
|
||||
, createTarget = Nothing
|
||||
}
|
||||
}
|
||||
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
|
||||
return create
|
||||
|
||||
insertCollab loomID obiidGrant = do
|
||||
cid <- insert Collab
|
||||
insert_ $ CollabTopicLoom cid loomID
|
||||
insert_ $ CollabEnable cid obiidGrant
|
||||
insert_ $ CollabRecipLocal cid pidUser
|
||||
insert_ $ CollabFulfillsLocalTopicCreation cid
|
||||
|
||||
insertGrantToOutbox adminHash loomHash obiidCreate obiidGrant actors stages = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidCreate <- encodeKeyHashid obiidCreate
|
||||
obikhidGrant <- encodeKeyHashid obiidGrant
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
grant = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
LoomOutboxItemR loomHash obikhidGrant
|
||||
, activityActor = encodeRouteLocal $ LoomR loomHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills =
|
||||
[encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
|
||||
, activitySpecific = GrantActivity Grant
|
||||
{ grantObject = Left RoleAdmin
|
||||
, grantContext = encodeRouteHome $ LoomR loomHash
|
||||
, grantTarget = encodeRouteHome $ PersonR adminHash
|
||||
}
|
||||
}
|
||||
update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant]
|
||||
return grant
|
||||
|
||||
insertFollowToOutbox senderHash loomHash obiidFollow = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
obikhid <- encodeKeyHashid obiidFollow
|
||||
let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
|
||||
recips = [encodeRouteHome $ LoomR loomHash]
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luFollow
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = FollowActivity AP.Follow
|
||||
{ AP.followObject = encodeRouteHome $ LoomR loomHash
|
||||
, AP.followContext = Nothing
|
||||
, AP.followHide = False
|
||||
}
|
||||
}
|
||||
update obiidFollow [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return luFollow
|
||||
|
||||
insertAcceptToOutbox senderHash loomHash obiidAccept luFollow = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
obikhid <- encodeKeyHashid obiidAccept
|
||||
|
||||
let recips = [encodeRouteHome $ PersonR senderHash]
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ LoomOutboxItemR loomHash obikhid
|
||||
, activityActor = encodeRouteLocal $ LoomR loomHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luFollow
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
|
||||
createRepositoryC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
@ -1399,6 +1670,7 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai
|
|||
, repoCollabAnon = Nothing
|
||||
, repoActor = actorID
|
||||
, repoCreate = createID
|
||||
, repoLoom = Nothing
|
||||
}
|
||||
return (repoID, actor)
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ module Vervis.Client
|
|||
--, unresolve
|
||||
--, offerMR
|
||||
createDeck
|
||||
, createLoom
|
||||
, createRepo
|
||||
)
|
||||
where
|
||||
|
|
@ -38,6 +39,7 @@ import Control.Monad
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bitraversable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Database.Persist
|
||||
|
|
@ -621,6 +623,37 @@ createDeck senderHash name desc = do
|
|||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
|
||||
|
||||
createLoom
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> KeyHashid Repo
|
||||
-> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, NonEmpty FedURI)
|
||||
createLoom senderHash name desc repoHash = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
audRepo =
|
||||
AudLocal
|
||||
[LocalActorRepo repoHash]
|
||||
[LocalStageRepoFollowers repoHash]
|
||||
|
||||
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audRepo]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypePatchTracker
|
||||
, AP.actorUsername = Nothing
|
||||
, AP.actorName = Just name
|
||||
, AP.actorSummary = Just desc
|
||||
}
|
||||
repo = encodeRouteHome $ RepoR repoHash
|
||||
|
||||
return (Nothing, AP.Audience recips [] [] [] [] [], detail, repo :| [])
|
||||
|
||||
createRepo
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> KeyHashid Person
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@
|
|||
module Vervis.Form.Project
|
||||
( NewProject (..)
|
||||
, newProjectForm
|
||||
, NewLoom (..)
|
||||
, newLoomForm
|
||||
--, NewProjectCollab (..)
|
||||
--, newProjectCollabForm
|
||||
--, editProjectForm
|
||||
|
|
@ -31,8 +33,11 @@ import Yesod.Form.Functions
|
|||
import Yesod.Form.Types
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Yesod.Hashids
|
||||
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
||||
|
|
@ -46,6 +51,33 @@ newProjectForm = renderDivs $ NewProject
|
|||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
|
||||
data NewLoom = NewLoom
|
||||
{ nlName :: Text
|
||||
, nlDesc :: Text
|
||||
, nlRepo :: RepoId
|
||||
}
|
||||
|
||||
newLoomForm :: Form NewLoom
|
||||
newLoomForm = renderDivs $ NewLoom
|
||||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
<*> areq selectRepo "Repo*" Nothing
|
||||
where
|
||||
selectRepo = selectField $ do
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (repo `E.InnerJoin` actor) -> do
|
||||
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ repo E.^. RepoLoom
|
||||
E.orderBy [E.desc $ repo E.^. RepoId]
|
||||
return (actor E.^. ActorName, repo E.^. RepoId)
|
||||
optionsPairs $ map (option hashRepo) l
|
||||
where
|
||||
option hashRepo (E.Value name, E.Value repoID) =
|
||||
( T.concat ["^", keyHashidText $ hashRepo repoID, " ", name]
|
||||
, repoID
|
||||
)
|
||||
|
||||
{-
|
||||
data NewProjectCollab = NewProjectCollab
|
||||
{ ncPerson :: PersonId
|
||||
|
|
|
|||
|
|
@ -21,15 +21,21 @@ module Vervis.Handler.Loom
|
|||
, getLoomOutboxItemR
|
||||
, getLoomFollowersR
|
||||
, getLoomClothsR
|
||||
|
||||
, getLoomNewR
|
||||
, postLoomNewR
|
||||
, postLoomFollowR
|
||||
, postLoomUnfollowR
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
|
|
@ -59,6 +65,7 @@ import Control.Monad.Trans.Except.Local
|
|||
import Data.Either.Local
|
||||
import Data.Paginate.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Form.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
|
|
@ -66,6 +73,7 @@ import Vervis.API
|
|||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.FedURI
|
||||
import Vervis.Form.Project
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Paginate
|
||||
|
|
@ -73,6 +81,8 @@ import Vervis.Recipient
|
|||
import Vervis.Settings
|
||||
import Vervis.Web.Actor
|
||||
|
||||
import qualified Vervis.Client as C
|
||||
|
||||
getLoomR :: KeyHashid Loom -> Handler TypedContent
|
||||
getLoomR loomHash = do
|
||||
loomID <- decodeKeyHashid404 loomHash
|
||||
|
|
@ -220,3 +230,71 @@ getLoomClothsR loomHash = selectRep $ do
|
|||
where
|
||||
here = LoomClothsR loomHash
|
||||
encodeStrict = BL.toStrict . encode
|
||||
|
||||
getLoomNewR :: Handler Html
|
||||
getLoomNewR = do
|
||||
((_result, widget), enctype) <- runFormPost newLoomForm
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
<form method=POST action=@{LoomNewR} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<div class="submit">
|
||||
<input type="submit">
|
||||
|]
|
||||
|
||||
postLoomNewR :: Handler Html
|
||||
postLoomNewR = do
|
||||
(NewLoom name desc repoID, _widget, _enctype) <-
|
||||
runFormPostRedirect LoomNewR newLoomForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
repoHash <- encodeKeyHashid repoID
|
||||
(maybeSummary, audience, detail, repos) <-
|
||||
C.createLoom personHash name desc repoHash
|
||||
actor <- runDB $ do
|
||||
|
||||
-- Find the specified repo in DB
|
||||
_ <- getJust repoID
|
||||
|
||||
-- Make sure the repo has a single, full-access collab, granted to the
|
||||
-- creator of the loom
|
||||
maybeApproved <- runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
guard $ recipID == personID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
|
||||
return ()
|
||||
unless (isJust maybeApproved) $ do
|
||||
setMessage "Can't link with the repo chosen"
|
||||
redirect LoomNewR
|
||||
|
||||
getJust $ personActor person
|
||||
|
||||
result <-
|
||||
runExceptT $ createPatchTrackerC personEntity actor maybeSummary audience detail repos Nothing Nothing
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect LoomNewR
|
||||
Right createID -> do
|
||||
maybeLoomID <- runDB $ getKeyBy $ UniqueLoomCreate createID
|
||||
case maybeLoomID of
|
||||
Nothing -> error "Can't find the newly created loom"
|
||||
Just loomID -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
setMessage "New patch tracker created"
|
||||
redirect $ LoomR loomHash
|
||||
|
||||
postLoomFollowR :: KeyHashid Loom -> Handler ()
|
||||
postLoomFollowR _ = error "Temporarily disabled"
|
||||
|
||||
postLoomUnfollowR :: KeyHashid Loom -> Handler ()
|
||||
postLoomUnfollowR _ = error "Temporarily disabled"
|
||||
|
|
|
|||
|
|
@ -284,6 +284,8 @@ postPersonOutboxR personHash = do
|
|||
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
|
||||
AP.CreateRepository detail vcs mlocal ->
|
||||
createRepositoryC eperson actorDB summary audience detail vcs mlocal mtarget
|
||||
AP.CreatePatchTracker detail repos mlocal ->
|
||||
createPatchTrackerC eperson actorDB summary audience detail repos mlocal mtarget
|
||||
_ -> throwE "Unsupported Create 'object' type"
|
||||
AP.InviteActivity invite ->
|
||||
inviteC eperson actorDB mcap summary audience invite
|
||||
|
|
|
|||
|
|
@ -42,6 +42,8 @@ module Vervis.Handler.Repo
|
|||
|
||||
, postPostReceiveR
|
||||
|
||||
, postRepoLinkR
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -70,6 +72,7 @@ import Control.Monad
|
|||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger (logWarn)
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Bifunctor
|
||||
import Data.Binary.Put
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -181,6 +184,7 @@ getRepoR repoHash = do
|
|||
(r,) <$> getJust (repoActor r)
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
let repoAP = AP.Repo
|
||||
{ AP.repoActor = AP.Actor
|
||||
{ AP.actorLocal = AP.ActorLocal
|
||||
|
|
@ -206,6 +210,8 @@ getRepoR repoHash = do
|
|||
}
|
||||
, AP.repoTeam = Nothing
|
||||
, AP.repoVcs = repoVcs repo
|
||||
, AP.repoLoom =
|
||||
encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo
|
||||
}
|
||||
|
||||
next =
|
||||
|
|
@ -359,22 +365,31 @@ postGitUploadRequestR repoHash = do
|
|||
getRepoSourceR :: KeyHashid Repo -> [Text] -> Handler Html
|
||||
getRepoSourceR repoHash path = do
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
(repo, actor) <- runDB $ do
|
||||
(repo, looms, actor) <- runDB $ do
|
||||
r <- get404 repoID
|
||||
(r,) <$> getJust (repoActor r)
|
||||
ls <-
|
||||
case repoLoom r of
|
||||
Just _ -> pure []
|
||||
Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId]
|
||||
(r,ls,) <$> getJust (repoActor r)
|
||||
|
||||
case repoVcs repo of
|
||||
VCSDarcs -> getDarcsRepoSource repo actor repoHash path
|
||||
VCSDarcs -> getDarcsRepoSource repo actor repoHash path looms
|
||||
VCSGit -> notFound
|
||||
|
||||
getRepoBranchSourceR :: KeyHashid Repo -> Text -> [Text] -> Handler Html
|
||||
getRepoBranchSourceR repoHash branch path = do
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
(repo, actor) <- runDB $ do
|
||||
(repo, looms, actor) <- runDB $ do
|
||||
r <- get404 repoID
|
||||
(r,) <$> getJust (repoActor r)
|
||||
ls <-
|
||||
case repoLoom r of
|
||||
Just _ -> pure []
|
||||
Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId]
|
||||
(r,ls,) <$> getJust (repoActor r)
|
||||
case repoVcs repo of
|
||||
VCSDarcs -> notFound
|
||||
VCSGit -> getGitRepoSource repo actor repoHash branch path
|
||||
VCSGit -> getGitRepoSource repo actor repoHash branch path looms
|
||||
|
||||
getRepoCommitsR :: KeyHashid Repo -> Handler TypedContent
|
||||
getRepoCommitsR repoHash = do
|
||||
|
|
@ -630,12 +645,62 @@ postPostReceiveR = do
|
|||
|]
|
||||
-}
|
||||
|
||||
postRepoLinkR :: KeyHashid Repo -> KeyHashid Loom -> Handler Html
|
||||
postRepoLinkR repoHash loomHash = do
|
||||
Entity personID person <- requireAuth
|
||||
|
||||
repoID <- decodeKeyHashid404 repoHash
|
||||
|
||||
result <- runExceptT $ runDBExcept $ do
|
||||
repo <- lift $ get404 repoID
|
||||
unless (isNothing $ repoLoom repo) $ throwE "Repo already has a loom"
|
||||
|
||||
loomID <- decodeKeyHashidE loomHash "Invalid loom hash"
|
||||
loom <- getE loomID "No such loom in DB"
|
||||
|
||||
-- Make sure both repo and loom have a single, full-access collab,
|
||||
-- granted to the logged-in person
|
||||
maybeApproved <- lift $ runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
|
||||
guard $ recipID == personID
|
||||
|
||||
collabs' <- lift $ selectList [CollabTopicLoomLoom ==. loomID] []
|
||||
collabID' <-
|
||||
case collabs' of
|
||||
[Entity _ c] -> return $ collabTopicLoomCollab c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID' <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID'
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID'
|
||||
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID'
|
||||
guard $ recipID' == personID
|
||||
|
||||
return ()
|
||||
|
||||
unless (isJust maybeApproved) $
|
||||
throwE "Repo and loom aren't both yours"
|
||||
|
||||
n <-
|
||||
lift $ updateWhereCount
|
||||
[RepoId ==. repoID, RepoLoom ==. Nothing]
|
||||
[RepoLoom =. Just loomID]
|
||||
case n of
|
||||
0 -> throwE "Couldn't update the repo"
|
||||
1 -> return ()
|
||||
_ -> error $ "Unexpected, " ++ show n ++ " repos were updated"
|
||||
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml e
|
||||
Right () -> setMessage "Repo successfully linked with loom!"
|
||||
redirect $ RepoR repoHash
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -2686,6 +2686,8 @@ changes hLocal ctx =
|
|||
, renameUnique "CollabEnable" "UniqueCollabTopicLocalAcceptAccept" "UniqueCollabEnableGrant"
|
||||
-- 492
|
||||
, removeEntity "CollabTopicLocal"
|
||||
-- 493
|
||||
, addFieldRefOptional "Repo" Nothing "loom" "Loom"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -82,8 +82,8 @@ import Vervis.Widget.Repo
|
|||
import qualified Vervis.Darcs as D
|
||||
|
||||
getDarcsRepoSource
|
||||
:: Repo -> Actor -> KeyHashid Repo -> [Text] -> Handler Html
|
||||
getDarcsRepoSource repository actor repo dir = do
|
||||
:: Repo -> Actor -> KeyHashid Repo -> [Text] -> [LoomId] -> Handler Html
|
||||
getDarcsRepoSource repository actor repo dir loomIDs = do
|
||||
path <- askRepoDir repo
|
||||
msv <- liftIO $ D.readSourceView path dir
|
||||
case msv of
|
||||
|
|
@ -91,7 +91,11 @@ getDarcsRepoSource repository actor repo dir = do
|
|||
Just sv -> do
|
||||
let parent = if null dir then [] else init dir
|
||||
dirs = zip parent (tail $ inits parent)
|
||||
looms <- runDB $ for loomIDs $ \ loomID -> do
|
||||
loom <- getJust loomID
|
||||
(loomID,) <$> getJust (loomActor loom)
|
||||
defaultLayout $ do
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
host <- asksSite siteInstanceHost
|
||||
ms <- lookupGetParam "style"
|
||||
style <-
|
||||
|
|
|
|||
|
|
@ -97,8 +97,8 @@ import qualified Data.ByteString.Lazy as BL (ByteString)
|
|||
import qualified Vervis.Git as G
|
||||
|
||||
getGitRepoSource
|
||||
:: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> Handler Html
|
||||
getGitRepoSource repository actor repo ref dir = do
|
||||
:: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> [LoomId] -> Handler Html
|
||||
getGitRepoSource repository actor repo ref dir loomIDs = do
|
||||
path <- askRepoDir repo
|
||||
(branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
|
||||
case msv of
|
||||
|
|
@ -106,7 +106,11 @@ getGitRepoSource repository actor repo ref dir = do
|
|||
Just sv -> do
|
||||
let parent = if null dir then [] else init dir
|
||||
dirs = zip parent (tail $ inits parent)
|
||||
looms <- runDB $ for loomIDs $ \ loomID -> do
|
||||
loom <- getJust loomID
|
||||
(loomID,) <$> getJust (loomActor loom)
|
||||
defaultLayout $ do
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
host <- asksSite siteInstanceHost
|
||||
ms <- lookupGetParam "style"
|
||||
style <-
|
||||
|
|
|
|||
|
|
@ -462,6 +462,7 @@ data Repo u = Repo
|
|||
{ repoActor :: Actor u
|
||||
, repoTeam :: Maybe LocalURI
|
||||
, repoVcs :: VersionControlSystem
|
||||
, repoLoom :: Maybe LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub Repo where
|
||||
|
|
@ -474,10 +475,12 @@ instance ActivityPub Repo where
|
|||
Repo a
|
||||
<$> withAuthorityMaybeO h (o .:|? "team")
|
||||
<*> o .: "versionControlSystem"
|
||||
toSeries authority (Repo actor team vcs)
|
||||
<*> withAuthorityMaybeO h (o .:? "sendPatchesTo")
|
||||
toSeries authority (Repo actor team vcs loom)
|
||||
= toSeries authority actor
|
||||
<> "team" .= (ObjURI authority <$> team)
|
||||
<> "versionControlSystem" .= vcs
|
||||
<> "sendPatchesTo" .=? (ObjURI authority <$> loom)
|
||||
|
||||
data TicketTracker u = TicketTracker
|
||||
{ ticketTrackerActor :: Actor u
|
||||
|
|
@ -1441,6 +1444,7 @@ data CreateObject u
|
|||
| CreateTicket (Authority u) (Ticket u)
|
||||
| CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||
| CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
|
||||
| CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
|
||||
|
||||
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
|
||||
parseCreateObject o
|
||||
|
|
@ -1457,6 +1461,12 @@ parseCreateObject o
|
|||
vcs <- o .: "versionControlSystem"
|
||||
ml <- parseActorLocal o
|
||||
return $ CreateRepository d vcs ml
|
||||
<|> do d <- parseActorDetail o
|
||||
unless (actorType d == ActorTypePatchTracker) $
|
||||
fail "type isn't PatchTracker"
|
||||
repos <- o .:*+ "tracksPatchesFor"
|
||||
ml <- parseActorLocal o
|
||||
return $ CreatePatchTracker d repos ml
|
||||
|
||||
encodeCreateObject :: UriMode u => CreateObject u -> Series
|
||||
encodeCreateObject (CreateNote h note) = toSeries h note
|
||||
|
|
@ -1467,6 +1477,10 @@ encodeCreateObject (CreateRepository d vcs ml)
|
|||
= encodeActorDetail d
|
||||
<> "versionControlSystem" .= vcs
|
||||
<> maybe mempty (uncurry encodeActorLocal) ml
|
||||
encodeCreateObject (CreatePatchTracker d repos ml)
|
||||
= encodeActorDetail d
|
||||
<> "tracksPatchesFor" .=*+ repos
|
||||
<> maybe mempty (uncurry encodeActorLocal) ml
|
||||
|
||||
data Create u = Create
|
||||
{ createObject :: CreateObject u
|
||||
|
|
@ -1485,6 +1499,7 @@ parseCreate o a luActor = do
|
|||
fail "Create actor != note attrib"
|
||||
CreateTicketTracker _ _ -> return ()
|
||||
CreateRepository _ _ _ -> return ()
|
||||
CreatePatchTracker _ _ _ -> return ()
|
||||
Create obj <$> o .:? "target"
|
||||
|
||||
encodeCreate :: UriMode u => Create u -> Series
|
||||
|
|
|
|||
|
|
@ -50,11 +50,24 @@ $# ^{personNavW user}
|
|||
<span>
|
||||
<a href=@{RepoCommitsR repo}>
|
||||
[🛠 Changes]
|
||||
<span>
|
||||
[🧩 Patches]
|
||||
$maybe loomID <- repoLoom repository
|
||||
<span>
|
||||
<a href=@{LoomClothsR $ hashLoom loomID}>
|
||||
[🧩 Patches]
|
||||
|
||||
^{followButton}
|
||||
|
||||
$if not $ null looms
|
||||
<h2>Enable patch tracking
|
||||
<ul>
|
||||
$forall (loomID, actor) <- looms
|
||||
<li>
|
||||
Loom
|
||||
<a href=@{LoomR $ hashLoom loomID}>
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
wants to link with this repo
|
||||
^{buttonW POST "Link" $ RepoLinkR repo $ hashLoom loomID}
|
||||
|
||||
<h2>Clone
|
||||
|
||||
<p>
|
||||
|
|
|
|||
|
|
@ -50,11 +50,23 @@ $# ^{personNavW user}
|
|||
<span>
|
||||
<a href=@{RepoCommitsR repo}>
|
||||
[🛠 Commits]
|
||||
<span>
|
||||
[🧩 Merge Requests]
|
||||
$maybe loomID <- repoLoom repository
|
||||
<span>
|
||||
<a href=@{LoomClothsR $ hashLoom loomID}>
|
||||
[🧩 Merge Requests]
|
||||
|
||||
^{followButton}
|
||||
|
||||
$if not $ null looms
|
||||
<h2>Enable patch tracking
|
||||
<ul>
|
||||
$forall (loomID, actor) <- looms
|
||||
Loom
|
||||
@{LoomR $ hashLoom loomID}
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
wants to link with this repo
|
||||
^{buttonW POST "Link" $ RepoLinkR repo $ hashLoom loomID}
|
||||
|
||||
<h2>Clone
|
||||
|
||||
<p>
|
||||
|
|
@ -67,16 +79,16 @@ $# ^{personNavW user}
|
|||
<h2>Branches
|
||||
|
||||
<ul>
|
||||
$forall branch <- branches
|
||||
<li>
|
||||
<a href=@{RepoBranchSourceR repo branch []}>#{branch}
|
||||
$forall branch <- branches
|
||||
<li>
|
||||
<a href=@{RepoBranchSourceR repo branch []}>#{branch}
|
||||
|
||||
<h2>Tags
|
||||
|
||||
<ul>
|
||||
$forall tag <- tags
|
||||
<li>
|
||||
<a href=@{RepoBranchSourceR repo tag []}>#{tag}
|
||||
$forall tag <- tags
|
||||
<li>
|
||||
<a href=@{RepoBranchSourceR repo tag []}>#{tag}
|
||||
|
||||
<div>
|
||||
<a href=@{RepoBranchSourceR repo ref []}>#{ref}
|
||||
|
|
|
|||
|
|
@ -347,6 +347,7 @@ Repo
|
|||
collabAnon RoleId Maybe
|
||||
actor ActorId
|
||||
create OutboxItemId
|
||||
loom LoomId Maybe
|
||||
|
||||
UniqueRepoActor actor
|
||||
UniqueRepoCreate create
|
||||
|
|
|
|||
|
|
@ -180,6 +180,8 @@
|
|||
|
||||
/post-receive PostReceiveR POST
|
||||
|
||||
/repos/#RepoKeyHashid/enable-loom/#LoomKeyHashid RepoLinkR POST
|
||||
|
||||
---- Deck --------------------------------------------------------------------
|
||||
|
||||
/decks/#DeckKeyHashid DeckR GET
|
||||
|
|
@ -236,11 +238,11 @@
|
|||
/looms/#LoomKeyHashid/followers LoomFollowersR GET
|
||||
/looms/#LoomKeyHashid/cloths LoomClothsR GET
|
||||
|
||||
-- /new-loom LoomNewR GET POST
|
||||
/new-loom LoomNewR GET POST
|
||||
-- /looms/#LoomKeyHashid/delete LoomDeleteR POST
|
||||
-- /looms/#LoomKeyHashid/edit LoomEditR GET POST
|
||||
-- /looms/#LoomKeyHashid/follow LoomFollowR POST
|
||||
-- /looms/#LoomKeyHashid/unfollow LoomUnfollowR POST
|
||||
/looms/#LoomKeyHashid/follow LoomFollowR POST
|
||||
/looms/#LoomKeyHashid/unfollow LoomUnfollowR POST
|
||||
|
||||
---- Cloth -------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue