From e78f043f49a0bf7af9748494c8b75f5d09a84e62 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 16 Sep 2022 10:34:44 +0000 Subject: [PATCH] C2S & UI: Allow creation of a new Repo --- src/Darcs/Local/Repository.hs | 10 +- src/Data/Git/Local.hs | 22 +-- src/Vervis/API.hs | 314 +++++++++++++++++++++++++++++----- src/Vervis/Client.hs | 26 +++ src/Vervis/Form/Repo.hs | 43 ++--- src/Vervis/Handler/Deck.hs | 15 +- src/Vervis/Handler/Person.hs | 2 + src/Vervis/Handler/Repo.hs | 104 +++-------- src/Vervis/Persist/Actor.hs | 16 ++ src/Web/ActivityPub.hs | 12 ++ src/Yesod/Form/Local.hs | 33 ++++ templates/repo/new.hamlet | 4 +- vervis.cabal | 3 +- 13 files changed, 424 insertions(+), 180 deletions(-) create mode 100644 src/Yesod/Form/Local.hs diff --git a/src/Darcs/Local/Repository.hs b/src/Darcs/Local/Repository.hs index 0e54d61..5c120a1 100644 --- a/src/Darcs/Local/Repository.hs +++ b/src/Darcs/Local/Repository.hs @@ -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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index f16e22a..8c809db 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.hs @@ -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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 70eacc8..0b33fba 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 5e4e24f..d212785 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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) diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index a45e607..df26ae4 100644 --- a/src/Vervis/Form/Repo.hs +++ b/src/Vervis/Form/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - ♡ 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 +-} diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 346573e..81924e0 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index ee531a5..4fe9ee6 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 75ad7ee..d78a6b4 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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 diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index c85038e..e774a01 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 79e8eb7..b1b044e 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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 diff --git a/src/Yesod/Form/Local.hs b/src/Yesod/Form/Local.hs new file mode 100644 index 0000000..a9bec37 --- /dev/null +++ b/src/Yesod/Form/Local.hs @@ -0,0 +1,33 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ 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 + - . + -} + +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) diff --git a/templates/repo/new.hamlet b/templates/repo/new.hamlet index b1e473f..d1aef9c 100644 --- a/templates/repo/new.hamlet +++ b/templates/repo/new.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2022 by fr33domlover . $# $# ♡ 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 $# . -
+ ^{widget}
diff --git a/vervis.cabal b/vervis.cabal index bf5c807..8750b63 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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