C2S & UI: Allow creation of a new Repo

src/Darcs/Local/Repository.hs

@@ -73,17 +73,15 @@ initialRepoTree repo =
 createRepo
     :: FilePath
     -- ^ Parent directory which already exists
-    -> String
+    -> Text
-    -- ^ Name of new repo, i.e. new directory to create under the parent
+    -- ^ 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
+createRepo parent repo cmd authority = do
-    let path = parent </> name
+    let path = parent </> T.unpack repo
     createDirectory path
     let settings = proc "darcs" ["init", "--no-working-dir", "--repodir", path]
     (_, _, _, ph) <- createProcess settings

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 :: FilePath -> Text -> Text -> DirTree Text
-initialRepoTree hook authority repo dir =
+initialRepoTree hook authority repo =
-    Dir dir
+    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
+    -> Text
-    -- ^ Name of new repo, i.e. new directory to create under the parent
+    -- ^ 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
+createRepo path repo cmd authority = do
-    let tree = path :/ initialRepoTree cmd authority repo name
+    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
 

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 (..))
-import Data.List.NonEmpty (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 System.Directory
-import Network.HTTP.Types.URI
-import Text.Blaze.Html (preEscapedToHtml)
 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

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)

src/Vervis/Form/Repo.hs

@@ -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 (..)
+    --, NewRepoCollab (..)
-    , newRepoCollabForm
+    --, newRepoCollabForm
-    , editRepoForm
+    --, 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
+    { nrpName :: Text
-    , nrpVcs   :: VersionControlSystem
+    , nrpDesc :: Text
-    , nrpProj  :: Maybe ProjectId
+    , nrpVcs  :: VersionControlSystem
-    , nrpDesc  :: Maybe Text
-    , nrpRole  :: Maybe RoleId
     }
 
-newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo
+newRepoForm :: Form NewRepo
-newRepoAForm sid mjid = NewRepo
+newRepoForm = renderDivs $ NewRepo
-    <$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
+    <$> 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
+-}

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

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

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"
+    ((_result, widget), enctype) <- runFormPost newRepoForm
-    --Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
+    defaultLayout $(widgetFile "repo/new")
-    --((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
-    --defaultLayout $(widgetFile "repo/new")
 
 postRepoNewR :: Handler Html
 postRepoNewR = do
-    error "Temporarily disabled"
+    (NewRepo name desc vcs, _widget, _enctype) <-
-    {-
+        runFormPostRedirect RepoNewR newRepoForm
-    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
 
-                obiid <-
+    personEntity@(Entity personID person) <- requireAuth
-                    insert $
+    personHash <- encodeKeyHashid personID
-                        OutboxItem
+    (maybeSummary, audience, detail) <- C.createRepo personHash name desc
-                            obid
+    actor <- runDB $ getJust $ personActor person
-                            (persistJSONObjectFromDoc $ Doc host emptyActivity)
+    result <-
-                            now
+        runExceptT $ createRepositoryC personEntity actor maybeSummary audience detail vcs Nothing Nothing
-                cid <- insert Collab
+
-                for_ (nrpRole nrp) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
+    case result of
-                insert_ $ CollabTopicLocalRepo cid rid
+        Left e -> do
-                insert_ $ CollabSenderLocal cid obiid
+            setMessage $ toHtml e
-                insert_ $ CollabRecipLocal cid pid
+            redirect RepoNewR
-            setMessage "Repo added."
+        Right createID -> do
-            redirect $ RepoR user (nrpIdent nrp)
+            maybeRepoID <- runDB $ getKeyBy $ UniqueRepoCreate createID
-        FormMissing -> do
+            case maybeRepoID of
-            setMessage "Field(s) missing"
+                Nothing -> error "Can't find the newly created repo"
-            defaultLayout $(widgetFile "repo/new")
+                Just repoID -> do
-        FormFailure _l -> do
+                    repoHash <- encodeKeyHashid repoID
-            setMessage "Repo creation failed, see errors below"
+                    setMessage "New repository created"
-            defaultLayout $(widgetFile "repo/new")
+                    redirect $ RepoR repoHash
-    -}
 
 postRepoDeleteR :: KeyHashid Repo -> Handler Html
 postRepoDeleteR repoHash = do

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

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

src/Yesod/Form/Local.hs

@@ -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)

templates/repo/new.hamlet

@@ -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">

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