mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-14 21:56:20 +09:00
1009 lines
37 KiB
Haskell
1009 lines
37 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018, 2019, 2020, 2022, 2023
|
|
- 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 Vervis.Handler.Repo
|
|
( getRepoR
|
|
, getRepoInboxR
|
|
, postRepoInboxR
|
|
, getRepoOutboxR
|
|
, getRepoOutboxItemR
|
|
, getRepoFollowersR
|
|
|
|
, getDarcsDownloadR
|
|
, getGitRefDiscoverR
|
|
, postGitUploadRequestR
|
|
|
|
, getRepoSourceR
|
|
, getRepoBranchSourceR
|
|
, getRepoCommitsR
|
|
, getRepoBranchCommitsR
|
|
, getRepoCommitR
|
|
|
|
, getRepoMessageR
|
|
|
|
, getRepoNewR
|
|
, postRepoNewR
|
|
, postRepoDeleteR
|
|
, getRepoEditR
|
|
, postRepoEditR
|
|
, postRepoFollowR
|
|
, postRepoUnfollowR
|
|
|
|
, postPostReceiveR
|
|
|
|
, postRepoLinkR
|
|
|
|
, getRepoStampR
|
|
|
|
, getRepoCollabsR
|
|
|
|
|
|
|
|
|
|
|
|
{-
|
|
, getReposR
|
|
, putRepoR
|
|
, postRepoR
|
|
, getRepoBranchR
|
|
, getRepoDevsR
|
|
, postRepoDevsR
|
|
, getRepoDevNewR
|
|
, getRepoDevR
|
|
, deleteRepoDevR
|
|
, postRepoDevR
|
|
, getRepoTeamR
|
|
-}
|
|
|
|
, getHighlightStyleR
|
|
)
|
|
where
|
|
|
|
import Control.Exception hiding (Handler)
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Logger (logWarn)
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Bifunctor
|
|
import Data.Binary.Put
|
|
import Data.ByteString (ByteString)
|
|
import Data.Foldable
|
|
import Data.Git.Graph
|
|
import Data.Git.Harder
|
|
import Data.Git.Harder.Pack
|
|
import Data.Git.Named (RefName (..))
|
|
import Data.Git.Ref (toHex)
|
|
import Data.Git.Repository
|
|
import Data.Git.Storage (withRepo)
|
|
import Data.Git.Storage.Object (Object (..))
|
|
import Data.Git.Types (Blob (..), Person (..), entName)
|
|
import Data.Graph.Inductive.Graph (noNodes)
|
|
import Data.Graph.Inductive.Query.Topsort
|
|
import Data.List (inits)
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Maybe
|
|
import Data.String
|
|
import Data.Text (Text, unpack)
|
|
import Data.Text.Encoding
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
|
import Data.Time.Clock
|
|
import Data.Traversable (for)
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Data.Hourglass (timeConvert)
|
|
import Formatting (sformat, stext, (%))
|
|
import Network.Git.Transport.HTTP.Fetch.RefDiscovery
|
|
import Network.Git.Transport.HTTP.Fetch.UploadRequest
|
|
import Network.Git.Types
|
|
import Network.Wai (strictRequestBody)
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.Hourglass (dateCurrent)
|
|
import System.IO
|
|
import System.Process
|
|
import Text.Blaze.Html (Html)
|
|
import Text.Pandoc.Highlighting
|
|
import Yesod.Auth
|
|
import Yesod.Core hiding (joinPath)
|
|
import Yesod.Core.Content
|
|
import Yesod.Core.Handler
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.ByteString.Lazy.Internal as BLI
|
|
import qualified Data.CaseInsensitive as CI (foldedCase)
|
|
import qualified Data.DList as D
|
|
import qualified Data.Set as S (member)
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Data.MediaType
|
|
import Database.Persist.JSON
|
|
import Development.PatchMediaType
|
|
import Network.FedURI
|
|
import Web.Text
|
|
import Yesod.ActivityPub
|
|
import Yesod.FedURI
|
|
import Yesod.Hashids
|
|
import Yesod.MonadSite
|
|
import Yesod.RenderSource
|
|
|
|
import qualified Web.ActivityPub as AP
|
|
|
|
import Data.ByteString.Char8.Local (takeLine)
|
|
import Data.Either.Local
|
|
import Data.Git.Local
|
|
import Database.Persist.Local
|
|
import Text.FilePath.Local (breakExt)
|
|
import Web.Hashids.Local
|
|
import Yesod.Form.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.API
|
|
import Vervis.Federation.Auth
|
|
import Vervis.Federation.Collab
|
|
import Vervis.Federation.Offer
|
|
import Vervis.FedURI
|
|
import Vervis.Form.Repo
|
|
import Vervis.Foundation
|
|
import Vervis.Path
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Paginate
|
|
import Vervis.Persist.Actor
|
|
import Vervis.Readme
|
|
import Vervis.Recipient
|
|
import Vervis.Settings
|
|
import Vervis.SourceTree
|
|
import Vervis.Style
|
|
import Vervis.Web.Actor
|
|
import Vervis.Web.Darcs
|
|
import Vervis.Web.Delivery
|
|
import Vervis.Web.Git
|
|
|
|
import qualified Vervis.Client as C
|
|
import qualified Vervis.Formatting as F
|
|
import qualified Vervis.Hook as H
|
|
|
|
getRepoR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoR repoHash = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
(repo, actor, sigKeyIDs) <- runDB $ do
|
|
r <- get404 repoID
|
|
let aid = repoActor r
|
|
a <- getJust aid
|
|
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
|
|
return (r, a, sigKeys)
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
hashLoom <- getEncodeKeyHashid
|
|
hashSigKey <- getEncodeKeyHashid
|
|
perActor <- asksSite $ appPerActorKeys . appSettings
|
|
let repoAP = AP.Repo
|
|
{ AP.repoActor = AP.Actor
|
|
{ AP.actorLocal = AP.ActorLocal
|
|
{ AP.actorId = encodeRouteLocal $ RepoR repoHash
|
|
, AP.actorInbox = encodeRouteLocal $ RepoInboxR repoHash
|
|
, AP.actorOutbox =
|
|
Just $ encodeRouteLocal $ RepoOutboxR repoHash
|
|
, AP.actorFollowers =
|
|
Just $ encodeRouteLocal $ RepoFollowersR repoHash
|
|
, AP.actorFollowing = Nothing
|
|
, AP.actorPublicKeys =
|
|
map (Left . encodeRouteLocal) $
|
|
if perActor
|
|
then map (RepoStampR repoHash . hashSigKey) sigKeyIDs
|
|
else [ActorKey1R, ActorKey2R]
|
|
, AP.actorSshKeys = []
|
|
}
|
|
, AP.actorDetail = AP.ActorDetail
|
|
{ AP.actorType = AP.ActorTypeRepo
|
|
, AP.actorUsername = Nothing
|
|
, AP.actorName = Just $ actorName actor
|
|
, AP.actorSummary = Just $ actorDesc actor
|
|
}
|
|
}
|
|
, AP.repoTeam = Nothing
|
|
, AP.repoVcs = repoVcs repo
|
|
, AP.repoLoom =
|
|
encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo
|
|
, AP.repoClone = encodeRouteLocal (RepoR repoHash) :| []
|
|
, AP.repoCollaborators = encodeRouteLocal $ RepoCollabsR repoHash
|
|
}
|
|
|
|
next =
|
|
case repoVcs repo of
|
|
VCSDarcs -> RepoSourceR repoHash
|
|
VCSGit -> RepoBranchSourceR repoHash $ repoMainBranch repo
|
|
provideHtmlAndAP repoAP $ redirect $ next []
|
|
|
|
getRepoInboxR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoInboxR = getInbox RepoInboxR repoActor
|
|
|
|
postRepoInboxR :: KeyHashid Repo -> Handler ()
|
|
postRepoInboxR repoHash = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
postInbox $ LocalActorRepo repoID
|
|
|
|
{-
|
|
AP.AcceptActivity accept ->
|
|
repoAcceptF now recipRepoHash author body mfwd luActivity accept
|
|
{-
|
|
ApplyActivity (AP.Apply uObject uTarget) ->
|
|
repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget
|
|
AddActivity (AP.Add obj target) ->
|
|
case obj of
|
|
Right (AddBundle patches) ->
|
|
repoAddBundleF now shrRecip rpRecip remoteAuthor body mfwd luActivity patches target
|
|
_ -> return ("Unsupported add object type for repos", Nothing)
|
|
CreateActivity (Create obj mtarget) ->
|
|
case obj of
|
|
CreateNote _ note ->
|
|
(,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note
|
|
CreateTicket _ ticket ->
|
|
(,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
|
|
_ -> error "Unsupported create object type for repos"
|
|
-}
|
|
AP.FollowActivity follow ->
|
|
repoFollowF now recipRepoHash author body mfwd luActivity follow
|
|
AP.InviteActivity invite ->
|
|
topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity invite
|
|
AP.JoinActivity join ->
|
|
repoJoinF now recipRepoHash author body mfwd luActivity join
|
|
{-
|
|
OfferActivity (Offer obj target) ->
|
|
case obj of
|
|
OfferDep dep ->
|
|
repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
|
|
_ -> return ("Unsupported offer object type for repos", Nothing)
|
|
-}
|
|
AP.UndoActivity undo->
|
|
(,Nothing) <$> repoUndoF now recipRepoHash author body mfwd luActivity undo
|
|
_ -> return ("Unsupported activity type for repos", Nothing)
|
|
-}
|
|
|
|
getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoOutboxR = getOutbox RepoOutboxR RepoOutboxItemR repoActor
|
|
|
|
getRepoOutboxItemR
|
|
:: KeyHashid Repo -> KeyHashid OutboxItem -> Handler TypedContent
|
|
getRepoOutboxItemR = getOutboxItem RepoOutboxItemR repoActor
|
|
|
|
getRepoFollowersR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoFollowersR = getActorFollowersCollection RepoFollowersR repoActor
|
|
|
|
getDarcsDownloadR :: KeyHashid Repo -> [Text] -> Handler TypedContent
|
|
getDarcsDownloadR repoHash dir = do
|
|
repoPath <- askRepoDir repoHash
|
|
let filePath = repoPath </> "_darcs" </> joinPath (map T.unpack dir)
|
|
exists <- liftIO $ doesFileExist filePath
|
|
if exists
|
|
then sendFile typeOctet filePath
|
|
else notFound
|
|
|
|
getGitRefDiscoverR :: KeyHashid Repo -> Handler TypedContent
|
|
getGitRefDiscoverR repoHash = do
|
|
let typ = "application/x-git-upload-pack-advertisement"
|
|
path <- askRepoDir repoHash
|
|
let pathG = fromString path
|
|
seemsThere <- liftIO $ isRepo pathG
|
|
if seemsThere
|
|
then do
|
|
rq <- getRequest
|
|
case reqGetParams rq of
|
|
[("service", serv)] ->
|
|
if serv == "git-upload-pack"
|
|
then do
|
|
let settings =
|
|
( proc "git"
|
|
[ "upload-pack"
|
|
, "--stateless-rpc"
|
|
, "--advertise-refs"
|
|
, path
|
|
]
|
|
)
|
|
{ std_out = CreatePipe
|
|
}
|
|
(_, mh, _, _) <-
|
|
liftIO $ createProcess settings
|
|
let h = fromJust mh
|
|
refs <- liftIO $ B.hGetContents h
|
|
let content = runPut $ do
|
|
putService UploadPack
|
|
putByteString refs
|
|
setHeader "Cache-Control" "no-cache"
|
|
return $ TypedContent typ $ toContent content
|
|
else permissionDenied "Service not supported"
|
|
_ -> notFound
|
|
else notFound
|
|
|
|
postGitUploadRequestR :: KeyHashid Repo -> Handler TypedContent
|
|
postGitUploadRequestR repoHash = do
|
|
let typ = "application/x-git-upload-pack-result"
|
|
path <- askRepoDir repoHash
|
|
let pathG = fromString path
|
|
seemsThere <- liftIO $ isRepo pathG
|
|
if seemsThere
|
|
then do
|
|
getBody <- strictRequestBody <$> waiRequest
|
|
body <- liftIO getBody
|
|
let settings =
|
|
( proc "git"
|
|
[ "upload-pack"
|
|
, "--stateless-rpc"
|
|
, path
|
|
]
|
|
)
|
|
{ std_in = CreatePipe
|
|
, std_out = CreatePipe
|
|
}
|
|
(mhin, mhout, _, _) <- liftIO $ createProcess settings
|
|
let hin = fromJust mhin
|
|
hout = fromJust mhout
|
|
liftIO $ BL.hPut hin body >> hClose hin
|
|
setHeader "Cache-Control" "no-cache"
|
|
let loop = do
|
|
b <- liftIO $ B.hGet hout BLI.defaultChunkSize
|
|
unless (B.null b) $ do
|
|
sendChunkBS b
|
|
loop
|
|
respondSource typ loop
|
|
else notFound
|
|
|
|
getRepoSourceR :: KeyHashid Repo -> [Text] -> Handler Html
|
|
getRepoSourceR repoHash path = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
(repo, looms, actor) <- runDB $ do
|
|
r <- get404 repoID
|
|
ls <-
|
|
case repoLoom r of
|
|
Just _ -> pure []
|
|
Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId]
|
|
(r,ls,) <$> getJust (repoActor r)
|
|
|
|
case repoVcs repo of
|
|
VCSDarcs -> getDarcsRepoSource repo actor repoHash path looms
|
|
VCSGit -> notFound
|
|
|
|
getRepoBranchSourceR :: KeyHashid Repo -> Text -> [Text] -> Handler Html
|
|
getRepoBranchSourceR repoHash branch path = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
(repo, looms, actor) <- runDB $ do
|
|
r <- get404 repoID
|
|
ls <-
|
|
case repoLoom r of
|
|
Just _ -> pure []
|
|
Nothing -> selectKeysList [LoomRepo ==. repoID] [Desc LoomId]
|
|
(r,ls,) <$> getJust (repoActor r)
|
|
case repoVcs repo of
|
|
VCSDarcs -> notFound
|
|
VCSGit -> getGitRepoSource repo actor repoHash branch path looms
|
|
|
|
getRepoCommitsR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoCommitsR repoHash = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
repo <- runDB $ get404 repoID
|
|
case repoVcs repo of
|
|
VCSDarcs -> getDarcsRepoChanges repoHash
|
|
VCSGit -> selectRep $ do
|
|
AP.provideAP (notFound :: Handler ())
|
|
provideRepType typeHtml
|
|
((redirect $ RepoBranchCommitsR repoHash $ repoMainBranch repo) :: Handler ())
|
|
|
|
getRepoBranchCommitsR :: KeyHashid Repo -> Text -> Handler TypedContent
|
|
getRepoBranchCommitsR repoHash branch = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
repo <- runDB $ get404 repoID
|
|
case repoVcs repo of
|
|
VCSDarcs -> notFound
|
|
VCSGit -> getGitRepoChanges repoHash branch
|
|
|
|
getRepoCommitR :: KeyHashid Repo -> Text -> Handler TypedContent
|
|
getRepoCommitR repoHash ref = do
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
repo <- runDB $ get404 repoID
|
|
case repoVcs repo of
|
|
VCSDarcs -> getDarcsPatch repoHash ref
|
|
VCSGit -> getGitPatch repoHash ref
|
|
|
|
getRepoMessageR
|
|
:: KeyHashid Repo -> KeyHashid LocalMessage -> Handler TypedContent
|
|
getRepoMessageR _ _ = notFound
|
|
|
|
getRepoNewR :: Handler Html
|
|
getRepoNewR = do
|
|
((_result, widget), enctype) <- runFormPost newRepoForm
|
|
defaultLayout $(widgetFile "repo/new")
|
|
|
|
postRepoNewR :: Handler Html
|
|
postRepoNewR = do
|
|
NewRepo name desc vcs <- runFormPostRedirect RepoNewR newRepoForm
|
|
|
|
personEntity@(Entity personID person) <- requireAuth
|
|
personHash <- encodeKeyHashid personID
|
|
(maybeSummary, audience, detail) <- C.createRepo personHash name desc
|
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
|
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateRepository detail vcs Nothing) Nothing
|
|
actor <- runDB $ getJust $ personActor person
|
|
result <-
|
|
runExceptT $ createRepositoryC personEntity actor Nothing localRecips remoteRecips fwdHosts action 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
|
|
error "Temporarily disabled"
|
|
{-
|
|
runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity rid _r <- getBy404 $ UniqueRepo repo sid
|
|
delete rid
|
|
path <- askRepoDir shar repo
|
|
exists <- liftIO $ doesDirectoryExist path
|
|
if exists
|
|
then liftIO $ removeDirectoryRecursive path
|
|
else
|
|
$logWarn $ sformat
|
|
( "Deleted repo " % F.sharer % "/" % F.repo
|
|
% " from DB but repo dir doesn't exist"
|
|
)
|
|
shar repo
|
|
setMessage "Repo deleted."
|
|
redirect HomeR
|
|
-}
|
|
|
|
getRepoEditR :: KeyHashid Repo -> Handler Html
|
|
getRepoEditR repoHash = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
(sid, er) <- runDB $ do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
er <- getBy404 $ UniqueRepo rp sid
|
|
return (sid, er)
|
|
((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
-}
|
|
|
|
postRepoEditR :: KeyHashid Repo -> Handler Html
|
|
postRepoEditR repoHash = do
|
|
error "Temporarily disabled"
|
|
{-
|
|
mer <- runDB $ do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
er@(Entity rid r) <- getBy404 $ UniqueRepo rp sid
|
|
mwiki <- for (repoProject r) $ \ jid -> do
|
|
project <- getJust jid
|
|
return $ (== rid) <$> projectWiki project
|
|
return $ case mwiki of
|
|
Just (Just True) -> Nothing
|
|
_ -> Just (sid, er)
|
|
case mer of
|
|
Nothing -> do
|
|
setMessage "Repo used as a wiki, can't move between projects."
|
|
redirect $ RepoR shr rp
|
|
Just (sid, er@(Entity rid _)) -> do
|
|
((result, widget), enctype) <- runFormPost $ editRepoForm sid er
|
|
case result of
|
|
FormSuccess repository' -> do
|
|
runDB $ replace rid repository'
|
|
setMessage "Repository updated."
|
|
redirect $ RepoR shr rp
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing."
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
FormFailure _l -> do
|
|
setMessage "Repository update failed, see errors below."
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
-}
|
|
|
|
postRepoFollowR :: KeyHashid Repo -> Handler ()
|
|
postRepoFollowR _ = error "Temporarily disabled"
|
|
|
|
postRepoUnfollowR :: KeyHashid Repo -> Handler ()
|
|
postRepoUnfollowR _ = error "Temporarily disabled"
|
|
|
|
postPostReceiveR :: Handler Text
|
|
postPostReceiveR = do
|
|
-- Parse the push object that the hook sent
|
|
push <- requireCheckJsonBody
|
|
|
|
errorOrPush <- runExceptT $ do
|
|
|
|
-- Compose an ActivityPub Push activity
|
|
(pushAP, repoID, repoHash) <- lift $ push2ap push
|
|
|
|
-- Find repo and person in DB
|
|
let pusherID = toSqlKey $ H.pushUser push
|
|
(Entity actorID actor, pusher) <- runDBExcept $ do
|
|
|
|
repoActorEntity <- do
|
|
repo <- getE repoID "Repo not found in DB"
|
|
lift $ getJustEntity $ repoActor repo
|
|
|
|
person <- getE pusherID "Pusher person not found in DB"
|
|
let actorID = personActor person
|
|
actor <- lift $ getJust actorID
|
|
let pusher = (Entity pusherID person, actor)
|
|
|
|
return (repoActorEntity, pusher)
|
|
|
|
-- Compose summary and audience
|
|
let repoName = actorName actor
|
|
summary <-
|
|
lift $ renderHTML <$> makeSummary push pushAP repoHash repoName pusher
|
|
let audience = [AudLocal [] [LocalStageRepoFollowers repoHash]]
|
|
(localRecips, remoteRecips, fwdHosts, action) <-
|
|
lift $ C.makeServerInput Nothing (Just summary) audience (AP.PushActivity pushAP)
|
|
|
|
-- Publish and deliver Push activity
|
|
now <- liftIO getCurrentTime
|
|
runDBExcept $ do
|
|
pushID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
|
|
luPush <- lift $ updateOutboxItem (LocalActorRepo repoID) pushID action
|
|
deliverHttpPush <-
|
|
deliverActivityDB
|
|
(LocalActorRepo repoHash) actorID localRecips remoteRecips
|
|
fwdHosts pushID action
|
|
return (luPush, deliverHttpPush)
|
|
|
|
-- HTTP delivery to remote recipients
|
|
case errorOrPush of
|
|
Left e -> liftIO $ throwIO $ userError $ T.unpack e
|
|
Right (luPush, deliverHttpPush) -> do
|
|
forkWorker "PostReceiveR: async HTTP Push delivery" deliverHttpPush
|
|
hLocal <- asksSite siteInstanceHost
|
|
return $
|
|
"Push activity published: " <>
|
|
renderObjURI (ObjURI hLocal luPush)
|
|
|
|
where
|
|
|
|
push2ap (H.Push secret personNum repo mbranch mbefore after early mlate) = do
|
|
secret' <- asksSite appHookSecret
|
|
unless (secret == H.hookSecretText secret') $
|
|
error "Inavlid hook secret"
|
|
repoID <- do
|
|
ctx <- asksSite siteHashidsContext
|
|
case decodeInt64 ctx $ TE.encodeUtf8 repo of
|
|
Nothing -> error "Invalid repo keyhashid"
|
|
Just repoNum -> return $ toSqlKey repoNum
|
|
repoHash <- do
|
|
repoHash <- encodeKeyHashid repoID
|
|
unless (keyHashidText repoHash == repo) $
|
|
error "decode-encode repo hash returned a different value"
|
|
return repoHash
|
|
let commit2ap' = commit2ap repoHash
|
|
(commitsLast, commitsFirst) <-
|
|
runDB $ case mlate of
|
|
Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
|
|
Just (_omitted, late) ->
|
|
(,) <$> traverse commit2ap' late
|
|
<*> (Just <$> traverse commit2ap' early)
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let pusherID = toSqlKey personNum
|
|
pusherHash <- encodeKeyHashid pusherID
|
|
let luRepo = encodeRouteLocal $ RepoR repoHash
|
|
return
|
|
( AP.Push
|
|
{ AP.pushCommitsLast = commitsLast
|
|
, AP.pushCommitsFirst = commitsFirst
|
|
, AP.pushCommitsTotal =
|
|
case mlate of
|
|
Nothing -> length early
|
|
Just (omitted, late) ->
|
|
length early + omitted + length late
|
|
, AP.pushTarget =
|
|
case mbranch of
|
|
Nothing -> Left luRepo
|
|
Just b ->
|
|
Right $ AP.Branch b ("refs/heads/" <> b) luRepo
|
|
, AP.pushAttrib = encodeRouteHome $ PersonR pusherHash
|
|
, AP.pushHashBefore = mbefore
|
|
, AP.pushHashAfter = after
|
|
}
|
|
, repoID
|
|
, repoHash
|
|
)
|
|
where
|
|
commit2ap repoHash (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
author <- authorByEmail wauthor
|
|
mcommitter <- traverse (authorByEmail . fst) mcommitted
|
|
return AP.Commit
|
|
{ AP.commitId = encodeRouteLocal $ RepoCommitR repoHash hash
|
|
, AP.commitRepository = encodeRouteLocal $ RepoR repoHash
|
|
, AP.commitAuthor = second (encodeRouteHome . PersonR) author
|
|
, AP.commitCommitter =
|
|
second (encodeRouteHome . PersonR) <$> mcommitter
|
|
, AP.commitTitle = title
|
|
, AP.commitHash = AP.Hash $ TE.encodeUtf8 hash
|
|
, AP.commitDescription =
|
|
if T.null desc
|
|
then Nothing
|
|
else Just desc
|
|
, AP.commitWritten = wtime
|
|
, AP.commitCommitted = snd <$> mcommitted
|
|
}
|
|
where
|
|
authorByEmail (H.Author name email) = do
|
|
mperson <- getKeyBy $ UniquePersonEmail email
|
|
case mperson of
|
|
Nothing -> return $ Left $ AP.Author name email
|
|
Just person -> Right <$> encodeKeyHashid person
|
|
|
|
makeSummary push pushAP repoHash repoName (Entity personID person, actor) = do
|
|
let mbranch = H.pushBranch push
|
|
total = AP.pushCommitsTotal pushAP
|
|
lasts = AP.pushCommitsLast pushAP
|
|
rest firsts = total - length firsts - length lasts
|
|
hashText (AP.Hash b) = decodeUtf8 b
|
|
commitW c =
|
|
[hamlet|
|
|
<a href=@{RepoCommitR repoHash $ hashText $ AP.commitHash c}>
|
|
#{AP.commitTitle c}
|
|
|]
|
|
personHash <- encodeKeyHashid personID
|
|
withUrlRenderer
|
|
[hamlet|
|
|
<p>
|
|
<a href=@{PersonR personHash}>
|
|
#{actorName actor} ~#{username2text $ personUsername person}
|
|
\ pushed #{total} #
|
|
\ #{commitsText mbranch total} to repo #
|
|
<a href=@{RepoR repoHash}>^#{keyHashidText repoHash} #{repoName}</a>^{branchText repoHash mbranch}:
|
|
<ul>
|
|
$maybe firsts <- AP.pushCommitsFirst pushAP
|
|
$forall c <- firsts
|
|
<li>^{commitW c}
|
|
<li>#{rest firsts}
|
|
$forall c <- lasts
|
|
<li>^{commitW c}
|
|
|]
|
|
|
|
commitsText :: Maybe a -> Int -> Text
|
|
commitsText Nothing n =
|
|
if n > 1
|
|
then "patches"
|
|
else "patch"
|
|
commitsText (Just _) n =
|
|
if n > 1
|
|
then "commits"
|
|
else "commit"
|
|
|
|
--branchText :: ShrIdent -> RpIdent -> Maybe Text -> HtmlUrl (Route App)
|
|
branchText _ Nothing = const mempty
|
|
branchText r (Just branch) =
|
|
[hamlet|
|
|
, branch #
|
|
<a href=@{RepoBranchCommitsR r branch}>#{branch}
|
|
|]
|
|
|
|
postRepoLinkR :: KeyHashid Repo -> KeyHashid Loom -> Handler Html
|
|
postRepoLinkR repoHash loomHash = do
|
|
Entity personID person <- requireAuth
|
|
|
|
repoID <- decodeKeyHashid404 repoHash
|
|
|
|
result <- runExceptT $ runDBExcept $ do
|
|
repo <- lift $ get404 repoID
|
|
unless (isNothing $ repoLoom repo) $ throwE "Repo already has a loom"
|
|
|
|
loomID <- decodeKeyHashidE loomHash "Invalid loom hash"
|
|
loom <- getE loomID "No such loom in DB"
|
|
|
|
-- Make sure both repo and loom have a single, full-access collab,
|
|
-- granted to the logged-in person
|
|
maybeApproved <- lift $ runMaybeT $ do
|
|
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
|
collabID <-
|
|
case collabs of
|
|
[Entity _ c] -> return $ collabTopicRepoCollab c
|
|
_ -> mzero
|
|
CollabRecipLocal _ recipID <-
|
|
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
|
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
|
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
|
|
guard $ recipID == personID
|
|
|
|
collabs' <- lift $ selectList [CollabTopicLoomLoom ==. loomID] []
|
|
collabID' <-
|
|
case collabs' of
|
|
[Entity _ c] -> return $ collabTopicLoomCollab c
|
|
_ -> mzero
|
|
CollabRecipLocal _ recipID' <-
|
|
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID'
|
|
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID'
|
|
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID'
|
|
guard $ recipID' == personID
|
|
|
|
return ()
|
|
|
|
unless (isJust maybeApproved) $
|
|
throwE "Repo and loom aren't both yours"
|
|
|
|
n <-
|
|
lift $ updateWhereCount
|
|
[RepoId ==. repoID, RepoLoom ==. Nothing]
|
|
[RepoLoom =. Just loomID]
|
|
case n of
|
|
0 -> throwE "Couldn't update the repo"
|
|
1 -> return ()
|
|
_ -> error $ "Unexpected, " ++ show n ++ " repos were updated"
|
|
|
|
case result of
|
|
Left e -> setMessage $ toHtml e
|
|
Right () -> setMessage "Repo successfully linked with loom!"
|
|
redirect $ RepoR repoHash
|
|
|
|
getRepoStampR :: KeyHashid Repo -> KeyHashid SigKey -> Handler TypedContent
|
|
getRepoStampR = servePerActorKey repoActor LocalActorRepo
|
|
|
|
getRepoCollabsR :: KeyHashid Repo -> Handler TypedContent
|
|
getRepoCollabsR repoHash = error "TODO getRepoCollabsR"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
{-
|
|
getReposR :: ShrIdent -> Handler Html
|
|
getReposR user = do
|
|
repos <- runDB $ E.select $ E.from $ \ (sharer, repo) -> do
|
|
E.where_ $
|
|
sharer E.^. SharerIdent E.==. E.val user E.&&.
|
|
sharer E.^. SharerId E.==. repo E.^. RepoSharer
|
|
E.orderBy [E.asc $ repo E.^. RepoIdent]
|
|
return $ repo E.^. RepoIdent
|
|
defaultLayout $(widgetFile "repo/list")
|
|
|
|
selectRepo :: ShrIdent -> RpIdent -> AppDB (Maybe (Sharer, Project, Workflow, Sharer), Repo)
|
|
selectRepo shar repo = do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
mj <- for (repoProject r) $ \ jid -> do
|
|
j <- get404 jid
|
|
s <- get404 $ projectSharer j
|
|
w <- get404 $ projectWorkflow j
|
|
sw <- get404 $ workflowSharer w
|
|
return (s, j, w, sw)
|
|
return (mj, r)
|
|
|
|
getRepoBranchR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
|
|
getRepoBranchR shar repo ref = do
|
|
(_, repository) <- runDB $ selectRepo shar repo
|
|
case repoVcs repository of
|
|
VCSDarcs -> notFound
|
|
VCSGit -> getGitRepoBranch shar repo ref
|
|
|
|
getRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
|
getRepoDevsR shr rp = do
|
|
devs <- runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
|
|
E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
|
|
E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
|
|
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
|
E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
|
|
E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
|
|
E.where_ $ topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid
|
|
return (sharer, role E.?. RoleIdent)
|
|
defaultLayout $(widgetFile "repo/collab/list")
|
|
|
|
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
|
postRepoDevsR shr rp = do
|
|
(sid, mjid, obid, rid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
|
return (s, repoProject repository, repoOutbox repository, r)
|
|
((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid
|
|
case result of
|
|
FormSuccess nc -> do
|
|
now <- liftIO getCurrentTime
|
|
host <- asksSite siteInstanceHost
|
|
runDB $ do
|
|
obiid <-
|
|
insert $
|
|
OutboxItem
|
|
obid
|
|
(persistJSONObjectFromDoc $ Doc host emptyActivity)
|
|
now
|
|
cid <- insert Collab
|
|
for_ (ncRole nc) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
|
|
insert_ $ CollabTopicLocalRepo cid rid
|
|
insert_ $ CollabSenderLocal cid obiid
|
|
insert_ $ CollabRecipLocal cid (ncPerson nc)
|
|
setMessage "Collaborator added."
|
|
redirect $ RepoDevsR shr rp
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
FormFailure _l -> do
|
|
setMessage "Operation failed, see errors below"
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
|
|
getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html
|
|
getRepoDevNewR shr rp = do
|
|
(sid, mjid, rid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
|
return (s, repoProject repository, r)
|
|
((_result, widget), enctype) <-
|
|
runFormPost $ newRepoCollabForm sid mjid rid
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
|
|
|
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
getRepoDevR shr rp dev = do
|
|
mrl <- runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
|
|
E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
|
|
E.where_ $
|
|
topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&.
|
|
recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
|
return $ recip E.^. CollabRecipLocalCollab
|
|
cid <-
|
|
case l of
|
|
[] -> notFound
|
|
[E.Value cid] -> return cid
|
|
_ -> error "Multiple collabs for repo+person"
|
|
mcrole <- getValBy $ UniqueCollabRoleLocal cid
|
|
for mcrole $
|
|
\ (CollabRoleLocal _cid rlid) -> roleIdent <$> getJust rlid
|
|
defaultLayout $(widgetFile "repo/collab/one")
|
|
|
|
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
deleteRepoDevR shr rp dev = do
|
|
runDB $ do
|
|
rid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
return r
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
collabs <- E.select $ E.from $ \ (recip `E.InnerJoin` topic) -> do
|
|
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalRepoCollab
|
|
E.where_ $
|
|
recip E.^. CollabRecipLocalPerson E.==. E.val pid E.&&.
|
|
topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid
|
|
return
|
|
( recip E.^. CollabRecipLocalId
|
|
, topic E.^. CollabTopicLocalRepoId
|
|
, recip E.^. CollabRecipLocalCollab
|
|
)
|
|
(E.Value crid, E.Value ctid, E.Value cid) <-
|
|
case collabs of
|
|
[] -> notFound
|
|
[c] -> return c
|
|
_ -> error "More than 1 collab for repo+person"
|
|
deleteWhere [CollabRoleLocalCollab ==. cid]
|
|
delete ctid
|
|
deleteWhere [CollabSenderLocalCollab ==. cid]
|
|
deleteWhere [CollabSenderRemoteCollab ==. cid]
|
|
delete crid
|
|
delete cid
|
|
setMessage "Collaborator removed."
|
|
redirect $ RepoDevsR shr rp
|
|
|
|
postRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
|
postRepoDevR shr rp dev = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteRepoDevR shr rp dev
|
|
_ -> notFound
|
|
|
|
getRepoTeamR :: ShrIdent -> RpIdent -> Handler TypedContent
|
|
getRepoTeamR shr rp = do
|
|
memberShrs <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
_rid <- getKeyBy404 $ UniqueRepo rp sid
|
|
id_ <-
|
|
requireEitherAlt
|
|
(getKeyBy $ UniquePersonIdent sid)
|
|
(getKeyBy $ UniqueGroup sid)
|
|
"Found sharer that is neither person nor group"
|
|
"Found sharer that is both person and group"
|
|
case id_ of
|
|
Left pid -> return [shr]
|
|
Right gid -> do
|
|
pids <-
|
|
map (groupMemberPerson . entityVal) <$>
|
|
selectList [GroupMemberGroup ==. gid] []
|
|
sids <-
|
|
map (personIdent . entityVal) <$>
|
|
selectList [PersonId <-. pids] []
|
|
map (sharerIdent . entityVal) <$>
|
|
selectList [SharerId <-. sids] []
|
|
|
|
let here = RepoTeamR shr rp
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
let team = Collection
|
|
{ collectionId = encodeRouteLocal here
|
|
, collectionType = CollectionTypeUnordered
|
|
, collectionTotalItems = Just $ length memberShrs
|
|
, collectionCurrent = Nothing
|
|
, collectionFirst = Nothing
|
|
, collectionLast = Nothing
|
|
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
|
|
, collectionContext = Nothing
|
|
}
|
|
provideHtmlAndAP team $ redirectToPrettyJSON here
|
|
|
|
getRepoFollowersR :: ShrIdent -> RpIdent -> Handler TypedContent
|
|
getRepoFollowersR shr rp = getFollowersCollection here getFsid
|
|
where
|
|
here = RepoFollowersR shr rp
|
|
getFsid = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
r <- getValBy404 $ UniqueRepo rp sid
|
|
return $ repoFollowers r
|
|
-}
|
|
|
|
getHighlightStyleR :: Text -> Handler TypedContent
|
|
getHighlightStyleR styleName =
|
|
case lookup (unpack styleName) highlightingStyles of
|
|
Nothing -> notFound
|
|
Just style ->
|
|
return $ TypedContent typeCss $ toContent $ styleToCss style
|