sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:44:52 +09:00
Code Issues Activity

C2S & UI: Allow creation of a new Repo

Browse source
This commit is contained in:
fr33domlover 2022-09-16 10:34:44 +00:00
parent 8ec98e2a59
commit e78f043f49
13 changed files with 424 additions and 180 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/Darcs/Local/Repository.hs
View file

@ -73,17 +73,15 @@ initialRepoTree repo =
createRepo
:: FilePath
-- ^ Parent directory which already exists
-> String
-- ^ Name of new repo, i.e. new directory to create under the parent
-> Text
-- ^ Repo keyhashid, i.e. new directory to create under the parent
-> FilePath
-- ^ Path of Vervis hook program
-> Text
-- ^ Instance HTTP authority
-> Text
-- ^ Repo key hashid
-> IO ()
createRepo parent name cmd authority repo = do
let path = parent </> name
createRepo parent repo cmd authority = do
let path = parent </> T.unpack repo
createDirectory path
let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path]
(_, _, _, ph) <- createProcess settings

22
src/Data/Git/Local.hs
View file

@ -67,9 +67,9 @@ writeHookFile path cmd authority repo = do
TIO.writeFile file $ hookContent cmd authority repo
setFileMode file ownerModes
initialRepoTree :: FilePath -> Text -> Text -> FileName -> DirTree Text
initialRepoTree hook authority repo dir =
Dir dir
initialRepoTree :: FilePath -> Text -> Text -> DirTree Text
initialRepoTree hook authority repo =
Dir (T.unpack repo)
[ Dir "branches" []
, File "config"
"[core]\n\
@ -78,7 +78,7 @@ initialRepoTree hook authority repo dir =
\ bare = true"
, File "description"
"Unnamed repository; edit this file to name the repository."
, File "HEAD" "ref: refs/heads/master"
, File "HEAD" "ref: refs/heads/main"
, Dir "hooks"
[ File "post-receive" $ hookContent hook authority repo
]
@ -103,22 +103,22 @@ initialRepoTree hook authority repo dir =
createRepo
:: FilePath
-- ^ Parent directory which already exists
-> String
-- ^ Name of new repo, i.e. new directory to create under the parent
-> Text
-- ^ Repo hashid, i.e. new directory to create under the parent
-> FilePath
-- ^ Path of Vervis hook program
-> Text
-- ^ Instance HTTP authority
-> Text
-- ^ Repo hashid
-> IO ()
createRepo path name cmd authority repo = do
let tree = path :/ initialRepoTree cmd authority repo name
createRepo path repo cmd authority = do
let tree = path :/ initialRepoTree cmd authority repo
result <- writeDirectoryWith TIO.writeFile tree
let errs = failures $ dirTree result
when (not . null $ errs) $
throwIO $ userError $ show errs
setFileMode (path </> name </> "hooks" </> "post-receive") ownerModes
setFileMode
(path </> T.unpack repo </> "hooks" </> "post-receive")
ownerModes
data EntObjType = EntObjBlob | EntObjTree

314
src/Vervis/API.hs
View file

@ -22,6 +22,7 @@ module Vervis.API
, applyC
, noteC
, createNoteC
, createRepositoryC
, createTicketTrackerC
, followC
, inviteC
@ -34,70 +35,38 @@ module Vervis.API
where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Crypto.Hash
import Data.Aeson
import Data.Barbie
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.Functor.Identity
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Units
import Data.Traversable
import Data.Tuple
import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy)
import GHC.Generics
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Text.Blaze.Html (preEscapedToHtml)
import System.Directory
import Text.Blaze.Html.Renderer.Text
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
import qualified Network.Wai as W
import Data.Time.Interval
import Network.HTTP.Signature hiding (requestHeaders)
import Yesod.HttpSignature
import Crypto.PublicVerifKey
import Database.Persist.JSON
import Development.PatchMediaType
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
@ -105,32 +74,26 @@ import Yesod.MonadSite
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local
import qualified Data.Git.Local as G (createRepo)
import qualified Darcs.Local.Repository as D (createRepo)
import Vervis.Access
import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.Cloth
import Vervis.Darcs
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Delivery
import Vervis.Discussion
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Git
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Role
import Vervis.Model.Workflow
import Vervis.Model.Ticket
import Vervis.Path
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Recipient
@ -1314,6 +1277,269 @@ verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips =
guard $ localRecipRepo $ localRecipRepoDirect repoSet
-}
createRepositoryC
:: Entity Person
-> Actor
-> Maybe TextHtml
-> Audience URIMode
-> AP.ActorDetail
-> VersionControlSystem
-> Maybe (Host, AP.ActorLocal URIMode)
-> Maybe FedURI
-> ExceptT Text Handler OutboxItemId
createRepositoryC (Entity pidUser personUser) senderActor summary audience detail vcs mlocal muTarget = do
-- Check input
verifyNothingE mlocal "'id' not allowed in new Repository to create"
(name, msummary) <- parseDetail detail
senderHash <- encodeKeyHashid pidUser
now <- liftIO getCurrentTime
verifyNothingE muTarget "'target' not supported in Create Repository"
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience
fromMaybeE mrecips "Create Repository with no recipients"
checkFederation remoteRecips
(obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
-- Insert new repo to DB
obiidCreate <-
lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
(repoID, Entity repoActorID repoActor) <-
lift $ insertRepo now name msummary obiidCreate
-- Insert the Create activity to author's outbox
repoHash <- encodeKeyHashid repoID
docCreate <- lift $ insertCreateToOutbox senderHash now blinded name msummary obiidCreate repoHash
-- Deliver the Create activity to local recipients, and schedule
-- delivery for unavailable remote recipients
remoteRecipsHttpCreate <- do
let sieve =
makeRecipientSet [] [LocalStagePersonFollowers senderHash]
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 repo's creator
let repoOutboxID = actorOutbox repoActor
grantID <- lift $ insertEmptyOutboxItem repoOutboxID now
lift $ insertCollab repoID grantID
-- Insert a Grant activity to repo's outbox
let grantRecipActors = [LocalActorPerson senderHash]
grantRecipStages = [LocalStagePersonFollowers senderHash]
docGrant <-
lift $ insertGrantToOutbox senderHash repoHash obiidCreate grantID grantRecipActors grantRecipStages
-- Deliver the Grant activity to local recipients, and schedule
-- delivery for unavailable remote recipients
remoteRecipsHttpGrant <- do
remoteRecips <-
lift $ deliverLocal' True (LocalActorRepo repoHash) repoActorID grantID $
makeRecipientSet grantRecipActors grantRecipStages
checkFederation remoteRecips
lift $ deliverRemoteDB'' [] grantID [] remoteRecips
-- Insert follow record
obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
obiidAccept <- lift $ insertEmptyOutboxItem repoOutboxID now
lift $ insert_ $ Follow (personActor personUser) (actorFollowers repoActor) True obiidFollow obiidAccept
-- Insert a Follow activity to sender's outbox, and an Accept to the
-- repo's outbox
luFollow <- lift $ insertFollowToOutbox senderHash repoHash obiidFollow
lift $ insertAcceptToOutbox senderHash repoHash obiidAccept luFollow
-- Deliver the Follow and Accept by simply manually inserting them to
-- repo and sender inboxes respectively
lift $ do
ibiidF <- insert $ InboxItem False now
insert_ $ InboxItemLocal (actorInbox repoActor) obiidFollow ibiidF
ibiidA <- insert $ InboxItem False now
insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
-- Return instructions for HTTP delivery to remote recipients
return
( obiidCreate
, repoHash
, deliverRemoteHttp' fwdHosts obiidCreate docCreate remoteRecipsHttpCreate
, deliverRemoteHttp' [] grantID docGrant remoteRecipsHttpGrant
)
-- Insert new repo to filesystem
lift $ createRepo newRepoHash
-- Launch asynchronous HTTP delivery of Create and Grant
lift $ do
forkWorker "createRepositoryC: async HTTP Create delivery" deliverHttpCreate
forkWorker "createRepositoryC: async HTTP Grant delivery" deliverHttpGrant
return obiid
where
parseDetail (AP.ActorDetail typ muser mname msummary) = do
unless (typ == AP.ActorTypeRepo) $
error "createRepositoryC: Create object isn't a Repository"
verifyNothingE muser "Repository can't have a username"
name <- fromMaybeE mname "Repository doesn't specify name"
return (name, msummary)
insertRepo now name msummary createID = do
actor@(Entity actorID _) <-
insertActor now name (fromMaybe "" msummary)
repoID <- insert Repo
{ repoVcs = vcs
, repoProject = Nothing
, repoMainBranch = "main"
, repoCollabUser = Nothing
, repoCollabAnon = Nothing
, repoActor = actorID
, repoCreate = createID
}
return (repoID, actor)
insertCreateToOutbox senderHash now blinded name msummary obiidCreate repoHash = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
obikhid <- encodeKeyHashid obiidCreate
let rdetail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeRepo
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = msummary
}
rlocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ RepoR repoHash
, AP.actorInbox = encodeRouteLocal $ RepoInboxR repoHash
, AP.actorOutbox = Nothing
, AP.actorFollowers = Nothing
, AP.actorFollowing = Nothing
, AP.actorPublicKeys = []
, AP.actorSshKeys = []
}
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 = CreateRepository rdetail vcs (Just (hLocal, rlocal))
, createTarget = Nothing
}
}
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
return create
insertCollab repoID grantID = do
collabID <- insert Collab
insert_ $ CollabTopicRepo collabID repoID
insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID pidUser
insert_ $ CollabFulfillsLocalTopicCreation collabID
insertGrantToOutbox adminHash repoHash 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 $
RepoOutboxItemR repoHash obikhidGrant
, activityActor = encodeRouteLocal $ RepoR repoHash
, activityCapability = Nothing
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activityFulfills =
[encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
, activitySpecific = GrantActivity Grant
{ grantObject = Left RoleAdmin
, grantContext = encodeRouteHome $ RepoR repoHash
, grantTarget = encodeRouteHome $ PersonR adminHash
}
}
update obiidGrant [OutboxItemActivity =. persistJSONObjectFromDoc grant]
return grant
insertFollowToOutbox senderHash repoHash obiidFollow = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost
obikhid <- encodeKeyHashid obiidFollow
let luFollow = encodeRouteLocal $ PersonOutboxItemR senderHash obikhid
recips = [encodeRouteHome $ RepoR repoHash]
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 $ RepoR repoHash
, AP.followContext = Nothing
, AP.followHide = False
}
}
update obiidFollow [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return luFollow
insertAcceptToOutbox senderHash repoHash 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 $ RepoOutboxItemR repoHash obikhid
, activityActor = encodeRouteLocal $ RepoR repoHash
, activityCapability = Nothing
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activityFulfills = []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hLocal luFollow
, acceptResult = Nothing
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
createRepo repoHash = do
root <- askRepoRootDir
liftIO $ createDirectoryIfMissing True root
host <- asksSite siteInstanceHost
case vcs of
VCSDarcs -> do
hook <- getsYesod $ appPostApplyHookFile . appSettings
liftIO $
D.createRepo
root
(keyHashidText repoHash)
hook
(renderAuthority host)
VCSGit -> do
hook <- getsYesod $ appPostReceiveHookFile . appSettings
liftIO $
G.createRepo
root
(keyHashidText repoHash)
hook
(renderAuthority host)
createTicketTrackerC
:: Entity Person
-> Actor

26
src/Vervis/Client.hs
View file

@ -30,6 +30,7 @@ module Vervis.Client
--, unresolve
--, offerMR
createDeck
, createRepo
)
where
@ -619,3 +620,28 @@ createDeck senderHash name desc = do
}
return (Nothing, AP.Audience recips [] [] [] [] [], detail)
createRepo
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> KeyHashid Person
-> Text
-> Text
-> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail)
createRepo senderHash name desc = do
encodeRouteHome <- getEncodeRouteHome
let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash]
(_, _, _, audLocal, audRemote) = collectAudience [audAuthor]
recips = map encodeRouteHome audLocal ++ audRemote
detail = AP.ActorDetail
{ AP.actorType = AP.ActorTypeRepo
, AP.actorUsername = Nothing
, AP.actorName = Just name
, AP.actorSummary = Just desc
}
return (Nothing, AP.Audience recips [] [] [] [] [], detail)

43
src/Vervis/Form/Repo.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -16,53 +16,41 @@
module Vervis.Form.Repo
( NewRepo (..)
, newRepoForm
, NewRepoCollab (..)
, newRepoCollabForm
, editRepoForm
--, NewRepoCollab (..)
--, newRepoCollabForm
--, editRepoForm
)
where
import Data.Text (Text)
import Database.Persist
import Yesod.Form.Fields
import Yesod.Form.Functions
import Yesod.Form.Types
import Vervis.Field.Repo
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Development.PatchMediaType
import Vervis.Foundation
import Vervis.Model
data NewRepo = NewRepo
{ nrpIdent :: RpIdent
, nrpVcs :: VersionControlSystem
, nrpProj :: Maybe ProjectId
, nrpDesc :: Maybe Text
, nrpRole :: Maybe RoleId
{ nrpName :: Text
, nrpDesc :: Text
, nrpVcs :: VersionControlSystem
}
newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo
newRepoAForm sid mjid = NewRepo
<$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
newRepoForm :: Form NewRepo
newRepoForm = renderDivs $ NewRepo
<$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing
<*> areq (selectFieldList vcsList) "Version control system*" Nothing
<*> aopt (selectProjectForNew sid) "Project" (Just mjid)
<*> aopt textField "Description" Nothing
<*> aopt selectRole "Custom role" Nothing
where
vcsList :: [(Text, VersionControlSystem)]
vcsList =
[ ("Darcs", VCSDarcs)
, ("Git" , VCSGit)
]
selectRole =
selectField $
optionsPersistKey [RoleSharer ==. sid] [] $
rl2text . roleIdent
newRepoForm :: SharerId -> Maybe ProjectId -> Form NewRepo
newRepoForm sid mjid = renderDivs $ newRepoAForm sid mjid
{-
data NewRepoCollab = NewRepoCollab
{ ncPerson :: PersonId
, ncRole :: Maybe RoleId
@ -111,3 +99,4 @@ editRepoAForm sid (Entity rid repo) = Repo
editRepoForm :: SharerId -> Entity Repo -> Form Repo
editRepoForm s r = renderDivs $ editRepoAForm s r
-}

15
src/Vervis/Handler/Deck.hs
View file

@ -89,6 +89,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
@ -303,20 +304,10 @@ getDeckNewR = do
((_result, widget), enctype) <- runFormPost newProjectForm
defaultLayout $(widgetFile "project/new")
runForm here form = do
((result, widget), enctype) <- runFormPost $ newProjectForm
case result of
FormMissing -> do
setMessage "Field(s) missing"
redirect here
FormFailure _l -> do
setMessage "Operation failed, see below"
redirect here
FormSuccess v -> return (v, widget, enctype)
postDeckNewR :: Handler Html
postDeckNewR = do
(NewProject name desc, _widget, _enctype) <- runForm DeckNewR newProjectForm
(NewProject name desc, _widget, _enctype) <-
runFormPostRedirect DeckNewR newProjectForm
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID

2
src/Vervis/Handler/Person.hs
View file

@ -282,6 +282,8 @@ postPersonOutboxR personHash = do
-}
AP.CreateTicketTracker detail mlocal ->
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
AP.CreateRepository detail vcs mlocal ->
createRepositoryC eperson actorDB summary audience detail vcs mlocal mtarget
_ -> throwE "Unsupported Create 'object' type"
AP.InviteActivity invite ->
inviteC eperson actorDB mcap summary audience invite

104
src/Vervis/Handler/Repo.hs
View file

@ -108,7 +108,7 @@ import System.IO
import System.Process
import Text.Blaze.Html (Html)
import Text.Pandoc.Highlighting
import Yesod.Auth (requireAuthId)
import Yesod.Auth
import Yesod.Core hiding (joinPath)
import Yesod.Core.Content
import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
@ -143,6 +143,7 @@ import Data.Either.Local
import Data.Git.Local
import Database.Persist.Local
import Text.FilePath.Local (breakExt)
import Yesod.Form.Local
import Yesod.Persist.Local
import qualified Data.Git.Local as G (createRepo)
@ -153,6 +154,7 @@ import Vervis.API
import Vervis.Federation.Auth
import Vervis.Federation.Collab
import Vervis.FedURI
import Vervis.Form.Repo
import Vervis.Foundation
import Vervis.Path
import Vervis.Model
@ -165,6 +167,7 @@ import Vervis.SourceTree
import Vervis.Style
import Vervis.Web.Actor
import qualified Vervis.Client as C
import qualified Vervis.Formatting as F
import qualified Vervis.Hook as H
@ -406,86 +409,33 @@ getRepoCommitR repoHash ref = do
getRepoNewR :: Handler Html
getRepoNewR = do
error "Temporarily disabled"
--Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
--((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
--defaultLayout $(widgetFile "repo/new")
((_result, widget), enctype) <- runFormPost newRepoForm
defaultLayout $(widgetFile "repo/new")
postRepoNewR :: Handler Html
postRepoNewR = do
error "Temporarily disabled"
{-
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
case result of
FormSuccess nrp -> do
now <- liftIO getCurrentTime
parent <- askSharerDir user
liftIO $ createDirectoryIfMissing True parent
let repoName =
unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
host <- asksSite siteInstanceHost
case nrpVcs nrp of
VCSDarcs -> do
hook <- getsYesod $ appPostApplyHookFile . appSettings
liftIO $
D.createRepo
parent
repoName
hook
(renderAuthority host)
(shr2text user)
(rp2text $ nrpIdent nrp)
VCSGit -> do
hook <- getsYesod $ appPostReceiveHookFile . appSettings
liftIO $
G.createRepo
parent
repoName
hook
(renderAuthority host)
(shr2text user)
(rp2text $ nrpIdent nrp)
pid <- requireAuthId
runDB $ do
ibid <- insert Inbox
obid <- insert Outbox
fsid <- insert FollowerSet
let repo = Repo
{ repoIdent = nrpIdent nrp
, repoSharer = sid
, repoVcs = nrpVcs nrp
, repoProject = nrpProj nrp
, repoDesc = nrpDesc nrp
, repoMainBranch = "master"
, repoCollabUser = Nothing
, repoCollabAnon = Nothing
, repoInbox = ibid
, repoOutbox = obid
, repoFollowers = fsid
}
rid <- insert repo
(NewRepo name desc vcs, _widget, _enctype) <-
runFormPostRedirect RepoNewR newRepoForm
obiid <-
insert $
OutboxItem
obid
(persistJSONObjectFromDoc $ Doc host emptyActivity)
now
cid <- insert Collab
for_ (nrpRole nrp) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
insert_ $ CollabTopicLocalRepo cid rid
insert_ $ CollabSenderLocal cid obiid
insert_ $ CollabRecipLocal cid pid
setMessage "Repo added."
redirect $ RepoR user (nrpIdent nrp)
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/new")
FormFailure _l -> do
setMessage "Repo creation failed, see errors below"
defaultLayout $(widgetFile "repo/new")
-}
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createRepo personHash name desc
actor <- runDB $ getJust $ personActor person
result <-
runExceptT $ createRepositoryC personEntity actor maybeSummary audience detail vcs Nothing Nothing
case result of
Left e -> do
setMessage $ toHtml e
redirect RepoNewR
Right createID -> do
maybeRepoID <- runDB $ getKeyBy $ UniqueRepoCreate createID
case maybeRepoID of
Nothing -> error "Can't find the newly created repo"
Just repoID -> do
repoHash <- encodeKeyHashid repoID
setMessage "New repository created"
redirect $ RepoR repoHash
postRepoDeleteR :: KeyHashid Repo -> Handler Html
postRepoDeleteR repoHash = do

16
src/Vervis/Persist/Actor.hs
View file

@ -17,6 +17,7 @@ module Vervis.Persist.Actor
( getLocalActor
, verifyLocalActivityExistsInDB
, getRemoteActorURI
, insertActor
)
where
@ -77,3 +78,18 @@ getRemoteActorURI actor = do
ObjURI
(instanceHost inztance)
(remoteObjectIdent object)
insertActor now name desc = do
ibid <- insert Inbox
obid <- insert Outbox
fsid <- insert FollowerSet
let actor = Actor
{ actorName = name
, actorDesc = desc
, actorCreatedAt = now
, actorInbox = ibid
, actorOutbox = obid
, actorFollowers = fsid
}
actorID <- insert actor
return $ Entity actorID actor

12
src/Web/ActivityPub.hs
View file

@ -1440,6 +1440,7 @@ data CreateObject u
= CreateNote (Authority u) (Note u)
| CreateTicket (Authority u) (Ticket u)
| CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
| CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
parseCreateObject o
@ -1450,12 +1451,22 @@ parseCreateObject o
fail "type isn't TicketTracker"
ml <- parseActorLocal o
return $ CreateTicketTracker d ml
<|> do d <- parseActorDetail o
unless (actorType d == ActorTypeRepo) $
fail "type isn't Repository"
vcs <- o .: "versionControlSystem"
ml <- parseActorLocal o
return $ CreateRepository d vcs ml
encodeCreateObject :: UriMode u => CreateObject u -> Series
encodeCreateObject (CreateNote h note) = toSeries h note
encodeCreateObject (CreateTicket h ticket) = toSeries h ticket
encodeCreateObject (CreateTicketTracker d ml) =
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
encodeCreateObject (CreateRepository d vcs ml)
= encodeActorDetail d
<> "versionControlSystem" .= vcs
<> maybe mempty (uncurry encodeActorLocal) ml
data Create u = Create
{ createObject :: CreateObject u
@ -1473,6 +1484,7 @@ parseCreate o a luActor = do
unless (a == h && luActor == ticketAttributedTo ticket) $
fail "Create actor != note attrib"
CreateTicketTracker _ _ -> return ()
CreateRepository _ _ _ -> return ()
Create obj <$> o .:? "target"
encodeCreate :: UriMode u => Create u -> Series

33
src/Yesod/Form/Local.hs Normal file
View file

@ -0,0 +1,33 @@
{- This file is part of Vervis.
-
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Yesod.Form.Local
( runFormPostRedirect
)
where
import Yesod.Core.Handler
import Yesod.Form
runFormPostRedirect here form = do
((result, widget), enctype) <- runFormPost form
case result of
FormMissing -> do
setMessage "Field(s) missing"
redirect here
FormFailure _l -> do
setMessage "Operation failed, see below"
redirect here
FormSuccess v -> return (v, widget, enctype)

4
templates/repo/new.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{ReposR user} enctype=#{enctype}>
<form method=POST action=@{RepoNewR} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

3
vervis.cabal
View file

@ -115,6 +115,7 @@ library
Yesod.Auth.Unverified.Creds
Yesod.Auth.Unverified.Internal
Yesod.FedURI
Yesod.Form.Local
Yesod.Hashids
Yesod.MonadSite
Yesod.Paginate.Local
@ -163,7 +164,7 @@ library
--Vervis.Form.Group
-- Vervis.Form.Key
Vervis.Form.Project
--Vervis.Form.Repo
Vervis.Form.Repo
--Vervis.Form.Role
--Vervis.Form.Ticket
-- Vervis.Form.Workflow