2016-02-27 05:41:36 +00:00
|
|
|
{- This file is part of Vervis.
|
|
|
|
-
|
2019-01-29 22:24:32 +00:00
|
|
|
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
2016-02-27 05:41:36 +00:00
|
|
|
-
|
|
|
|
- ♡ 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
|
|
|
|
( getReposR
|
|
|
|
, postReposR
|
|
|
|
, getRepoNewR
|
|
|
|
, getRepoR
|
2016-06-05 21:11:05 +00:00
|
|
|
, putRepoR
|
2016-05-13 19:23:56 +00:00
|
|
|
, deleteRepoR
|
|
|
|
, postRepoR
|
2016-06-05 21:11:05 +00:00
|
|
|
, getRepoEditR
|
2016-04-12 00:19:04 +00:00
|
|
|
, getRepoSourceR
|
2016-05-05 16:30:30 +00:00
|
|
|
, getRepoHeadChangesR
|
2019-08-28 15:31:40 +00:00
|
|
|
, getRepoBranchR
|
2016-05-05 16:30:30 +00:00
|
|
|
, getRepoChangesR
|
2018-05-17 15:46:57 +00:00
|
|
|
, getRepoPatchR
|
2016-05-29 14:13:25 +00:00
|
|
|
, getRepoDevsR
|
|
|
|
, postRepoDevsR
|
|
|
|
, getRepoDevNewR
|
|
|
|
, getRepoDevR
|
|
|
|
, deleteRepoDevR
|
|
|
|
, postRepoDevR
|
2016-05-13 10:58:42 +00:00
|
|
|
, getDarcsDownloadR
|
2019-09-09 00:27:45 +00:00
|
|
|
, getRepoTeamR
|
|
|
|
, getRepoFollowersR
|
2019-05-27 13:28:57 +00:00
|
|
|
|
|
|
|
, getHighlightStyleR
|
2019-09-05 12:02:42 +00:00
|
|
|
, postPostReceiveR
|
2016-02-27 05:41:36 +00:00
|
|
|
)
|
|
|
|
where
|
|
|
|
|
2019-09-09 00:27:45 +00:00
|
|
|
import Control.Exception hiding (Handler)
|
2016-05-23 20:46:54 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import Control.Monad.Logger (logWarn)
|
2019-09-09 00:27:45 +00:00
|
|
|
import Data.Bifunctor
|
2016-04-09 15:45:00 +00:00
|
|
|
import Data.Git.Graph
|
2016-04-30 20:14:56 +00:00
|
|
|
import Data.Git.Harder
|
2016-04-12 00:19:04 +00:00
|
|
|
import Data.Git.Named (RefName (..))
|
2016-03-03 08:15:54 +00:00
|
|
|
import Data.Git.Ref (toHex)
|
2016-05-04 11:44:06 +00:00
|
|
|
import Data.Git.Repository
|
2016-05-04 17:17:47 +00:00
|
|
|
import Data.Git.Storage (withRepo)
|
2016-04-12 10:06:21 +00:00
|
|
|
import Data.Git.Storage.Object (Object (..))
|
2019-09-09 00:27:45 +00:00
|
|
|
import Data.Git.Types (Blob (..), Person (..), entName)
|
2016-04-09 15:45:00 +00:00
|
|
|
import Data.Graph.Inductive.Graph (noNodes)
|
|
|
|
import Data.Graph.Inductive.Query.Topsort
|
2016-04-12 23:10:46 +00:00
|
|
|
import Data.List (inits)
|
2016-05-23 20:46:54 +00:00
|
|
|
import Data.Text (Text, unpack)
|
2019-09-09 00:27:45 +00:00
|
|
|
import Data.Text.Encoding
|
2016-03-03 08:15:54 +00:00
|
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
2016-06-05 21:11:05 +00:00
|
|
|
import Data.Traversable (for)
|
2019-09-09 00:27:45 +00:00
|
|
|
import Database.Persist
|
|
|
|
import Database.Persist.Sql
|
2016-03-03 08:15:54 +00:00
|
|
|
import Data.Hourglass (timeConvert)
|
2016-05-13 19:23:56 +00:00
|
|
|
import Formatting (sformat, stext, (%))
|
|
|
|
import System.Directory
|
2016-03-03 08:15:54 +00:00
|
|
|
import System.Hourglass (dateCurrent)
|
2016-05-23 20:46:54 +00:00
|
|
|
import Text.Blaze.Html (Html)
|
2019-05-27 13:28:57 +00:00
|
|
|
import Text.Pandoc.Highlighting
|
2016-06-07 05:17:54 +00:00
|
|
|
import Yesod.Auth (requireAuthId)
|
2019-05-27 18:30:48 +00:00
|
|
|
import Yesod.Core
|
2019-05-27 13:28:57 +00:00
|
|
|
import Yesod.Core.Content
|
2016-05-23 20:46:54 +00:00
|
|
|
import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
|
|
|
|
import Yesod.Form.Functions (runFormPost)
|
|
|
|
import Yesod.Form.Types (FormResult (..))
|
|
|
|
import Yesod.Persist.Core (runDB, getBy404)
|
2016-03-03 08:15:54 +00:00
|
|
|
|
2019-09-09 00:27:45 +00:00
|
|
|
import qualified Data.ByteString.Lazy as BL (ByteString)
|
2016-05-23 20:46:54 +00:00
|
|
|
import qualified Data.CaseInsensitive as CI (foldedCase)
|
2016-04-09 15:45:00 +00:00
|
|
|
import qualified Data.DList as D
|
2016-04-12 00:19:04 +00:00
|
|
|
import qualified Data.Set as S (member)
|
2019-09-09 00:27:45 +00:00
|
|
|
import qualified Data.Text as T
|
2016-04-12 10:06:21 +00:00
|
|
|
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
|
2019-09-09 00:27:45 +00:00
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
|
|
import Data.MediaType
|
|
|
|
import Web.ActivityPub hiding (Repo)
|
|
|
|
import Yesod.ActivityPub
|
|
|
|
import Yesod.FedURI
|
|
|
|
import Yesod.Hashids
|
|
|
|
import Yesod.MonadSite
|
|
|
|
import Yesod.RenderSource
|
|
|
|
|
|
|
|
import qualified Web.ActivityPub as AP
|
2016-04-09 15:45:00 +00:00
|
|
|
|
2016-03-03 08:15:54 +00:00
|
|
|
import Data.ByteString.Char8.Local (takeLine)
|
2019-09-09 00:27:45 +00:00
|
|
|
import Data.Either.Local
|
2016-05-04 17:17:47 +00:00
|
|
|
import Data.Git.Local
|
2019-09-09 00:27:45 +00:00
|
|
|
import Database.Persist.Local
|
2016-04-17 17:55:23 +00:00
|
|
|
import Text.FilePath.Local (breakExt)
|
2019-09-09 00:27:45 +00:00
|
|
|
import Yesod.Persist.Local
|
|
|
|
|
|
|
|
import qualified Data.Git.Local as G (createRepo)
|
|
|
|
import qualified Darcs.Local.Repository as D (createRepo)
|
|
|
|
|
|
|
|
import Vervis.API
|
2016-02-27 05:41:36 +00:00
|
|
|
import Vervis.Form.Repo
|
2016-03-03 08:15:54 +00:00
|
|
|
import Vervis.Foundation
|
2016-05-13 10:11:17 +00:00
|
|
|
import Vervis.Handler.Repo.Darcs
|
|
|
|
import Vervis.Handler.Repo.Git
|
2016-03-03 08:15:54 +00:00
|
|
|
import Vervis.Path
|
|
|
|
import Vervis.Model
|
2016-05-23 20:46:54 +00:00
|
|
|
import Vervis.Model.Ident
|
2016-05-03 00:33:49 +00:00
|
|
|
import Vervis.Model.Repo
|
2016-05-13 08:49:19 +00:00
|
|
|
import Vervis.Paginate
|
2016-04-13 16:17:34 +00:00
|
|
|
import Vervis.Readme
|
2016-03-03 08:15:54 +00:00
|
|
|
import Vervis.Settings
|
2016-05-05 07:29:19 +00:00
|
|
|
import Vervis.SourceTree
|
2016-04-12 14:44:43 +00:00
|
|
|
import Vervis.Style
|
2016-05-06 10:29:02 +00:00
|
|
|
import Vervis.Widget.Repo
|
2016-05-31 01:52:04 +00:00
|
|
|
import Vervis.Widget.Sharer
|
2016-02-27 05:41:36 +00:00
|
|
|
|
2016-05-23 20:46:54 +00:00
|
|
|
import qualified Vervis.Formatting as F
|
2019-09-09 00:27:45 +00:00
|
|
|
import qualified Vervis.Hook as H
|
2016-05-04 11:44:06 +00:00
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
getReposR :: ShrIdent -> Handler Html
|
2016-04-12 17:37:31 +00:00
|
|
|
getReposR user = do
|
2019-09-09 00:27:45 +00:00
|
|
|
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
|
2016-05-23 20:46:54 +00:00
|
|
|
defaultLayout $(widgetFile "repo/list")
|
2016-02-27 05:41:36 +00:00
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
postReposR :: ShrIdent -> Handler Html
|
2016-04-12 17:37:31 +00:00
|
|
|
postReposR user = do
|
2016-05-30 13:10:02 +00:00
|
|
|
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
2016-06-06 17:29:54 +00:00
|
|
|
((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
2016-02-27 05:41:36 +00:00
|
|
|
case result of
|
2016-05-30 13:10:02 +00:00
|
|
|
FormSuccess nrp -> do
|
2016-05-04 11:44:06 +00:00
|
|
|
parent <- askSharerDir user
|
2019-09-05 12:02:42 +00:00
|
|
|
liftIO $ createDirectoryIfMissing True parent
|
|
|
|
let repoName =
|
|
|
|
unpack $ CI.foldedCase $ unRpIdent $ nrpIdent nrp
|
|
|
|
case nrpVcs nrp of
|
|
|
|
VCSDarcs -> liftIO $ D.createRepo parent repoName
|
|
|
|
VCSGit -> do
|
|
|
|
hook <- getsYesod $ appPostReceiveHookFile . appSettings
|
|
|
|
liftIO $
|
|
|
|
G.createRepo
|
|
|
|
parent
|
|
|
|
repoName
|
|
|
|
hook
|
|
|
|
(shr2text user)
|
|
|
|
(rp2text $ nrpIdent nrp)
|
2016-06-07 05:17:54 +00:00
|
|
|
pid <- requireAuthId
|
2016-05-30 13:10:02 +00:00
|
|
|
runDB $ do
|
2019-09-09 00:27:45 +00:00
|
|
|
ibid <- insert Inbox
|
2019-09-11 08:12:20 +00:00
|
|
|
obid <- insert Outbox
|
2019-09-09 00:27:45 +00:00
|
|
|
fsid <- insert FollowerSet
|
2016-05-30 13:10:02 +00:00
|
|
|
let repo = Repo
|
|
|
|
{ repoIdent = nrpIdent nrp
|
|
|
|
, repoSharer = sid
|
|
|
|
, repoVcs = nrpVcs nrp
|
|
|
|
, repoProject = nrpProj nrp
|
|
|
|
, repoDesc = nrpDesc nrp
|
|
|
|
, repoMainBranch = "master"
|
2019-01-29 22:24:32 +00:00
|
|
|
, repoCollabUser = Nothing
|
|
|
|
, repoCollabAnon = Nothing
|
2019-09-09 00:27:45 +00:00
|
|
|
, repoInbox = ibid
|
2019-09-11 08:12:20 +00:00
|
|
|
, repoOutbox = obid
|
2019-09-09 00:27:45 +00:00
|
|
|
, repoFollowers = fsid
|
2016-05-30 13:10:02 +00:00
|
|
|
}
|
|
|
|
rid <- insert repo
|
2016-06-01 07:35:22 +00:00
|
|
|
let collab = RepoCollab
|
|
|
|
{ repoCollabRepo = rid
|
|
|
|
, repoCollabPerson = pid
|
|
|
|
, repoCollabRole = nrpRole nrp
|
2016-05-30 13:10:02 +00:00
|
|
|
}
|
|
|
|
insert_ collab
|
2016-05-04 11:44:06 +00:00
|
|
|
setMessage "Repo added."
|
|
|
|
redirect $ ReposR user
|
2016-02-27 05:41:36 +00:00
|
|
|
FormMissing -> do
|
|
|
|
setMessage "Field(s) missing"
|
2016-05-23 20:46:54 +00:00
|
|
|
defaultLayout $(widgetFile "repo/new")
|
2016-05-04 11:44:06 +00:00
|
|
|
FormFailure _l -> do
|
|
|
|
setMessage "Repo creation failed, see errors below"
|
2016-05-23 20:46:54 +00:00
|
|
|
defaultLayout $(widgetFile "repo/new")
|
2016-02-27 05:41:36 +00:00
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
getRepoNewR :: ShrIdent -> Handler Html
|
2016-04-12 17:37:31 +00:00
|
|
|
getRepoNewR user = do
|
2016-05-30 13:10:02 +00:00
|
|
|
Entity sid _sharer <- runDB $ getBy404 $ UniqueSharer user
|
2016-06-06 17:29:54 +00:00
|
|
|
((_result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
|
2016-05-23 20:46:54 +00:00
|
|
|
defaultLayout $(widgetFile "repo/new")
|
2016-02-27 05:41:36 +00:00
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
selectRepo :: ShrIdent -> RpIdent -> AppDB Repo
|
2016-05-05 16:30:30 +00:00
|
|
|
selectRepo shar repo = do
|
2016-05-23 20:46:54 +00:00
|
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
2016-05-05 16:30:30 +00:00
|
|
|
Entity _rid r <- getBy404 $ UniqueRepo repo sid
|
|
|
|
return r
|
|
|
|
|
2019-09-09 00:27:45 +00:00
|
|
|
getRepoR :: ShrIdent -> RpIdent -> Handler TypedContent
|
|
|
|
getRepoR shr rp = do
|
|
|
|
repo <- runDB $ selectRepo shr rp
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
|
|
let repoAP = AP.Repo
|
|
|
|
{ AP.repoActor = Actor
|
|
|
|
{ actorId = encodeRouteLocal $ RepoR shr rp
|
|
|
|
, actorType = ActorTypeRepo
|
|
|
|
, actorUsername = Nothing
|
|
|
|
, actorName = Just $ rp2text rp
|
|
|
|
, actorSummary = repoDesc repo
|
|
|
|
, actorInbox = encodeRouteLocal $ RepoInboxR shr rp
|
2019-09-11 08:12:20 +00:00
|
|
|
, actorOutbox =
|
|
|
|
Just $ encodeRouteLocal $ RepoOutboxR shr rp
|
2019-09-09 00:27:45 +00:00
|
|
|
, actorFollowers =
|
|
|
|
Just $ encodeRouteLocal $ RepoFollowersR shr rp
|
2019-09-11 08:12:20 +00:00
|
|
|
, actorPublicKeys =
|
|
|
|
[ Left $ encodeRouteLocal ActorKey1R
|
|
|
|
, Left $ encodeRouteLocal ActorKey2R
|
|
|
|
]
|
2019-09-09 00:27:45 +00:00
|
|
|
}
|
|
|
|
, AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
|
|
|
|
}
|
|
|
|
dir = case repoVcs repo of
|
|
|
|
VCSDarcs -> []
|
|
|
|
VCSGit -> [repoMainBranch repo]
|
|
|
|
provideHtmlAndAP repoAP $ redirect $ RepoSourceR shr rp dir
|
2016-05-05 07:29:19 +00:00
|
|
|
|
2016-06-05 21:11:05 +00:00
|
|
|
putRepoR :: ShrIdent -> RpIdent -> Handler Html
|
|
|
|
putRepoR shr rp = do
|
|
|
|
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
|
2019-01-29 22:24:32 +00:00
|
|
|
_ -> Just (sid, er)
|
2016-06-05 21:11:05 +00:00
|
|
|
case mer of
|
|
|
|
Nothing -> do
|
|
|
|
setMessage "Repo used as a wiki, can't move between projects."
|
|
|
|
redirect $ RepoR shr rp
|
2019-01-29 22:24:32 +00:00
|
|
|
Just (sid, er@(Entity rid _)) -> do
|
|
|
|
((result, widget), enctype) <- runFormPost $ editRepoForm sid er
|
2016-06-05 21:11:05 +00:00
|
|
|
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")
|
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
|
2016-05-13 19:23:56 +00:00
|
|
|
deleteRepoR shar repo = do
|
|
|
|
runDB $ do
|
2016-05-23 20:46:54 +00:00
|
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
2016-05-13 19:23:56 +00:00
|
|
|
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
|
2016-05-23 20:46:54 +00:00
|
|
|
( "Deleted repo " % F.sharer % "/" % F.repo
|
2016-05-13 19:23:56 +00:00
|
|
|
% " from DB but repo dir doesn't exist"
|
|
|
|
)
|
|
|
|
shar repo
|
|
|
|
setMessage "Repo deleted."
|
|
|
|
redirect HomeR
|
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
postRepoR :: ShrIdent -> RpIdent -> Handler Html
|
2016-05-13 19:23:56 +00:00
|
|
|
postRepoR shar repo = do
|
|
|
|
mmethod <- lookupPostParam "_method"
|
|
|
|
case mmethod of
|
2016-06-05 21:11:05 +00:00
|
|
|
Just "PUT" -> putRepoR shar repo
|
2016-05-13 19:23:56 +00:00
|
|
|
Just "DELETE" -> deleteRepoR shar repo
|
|
|
|
_ -> notFound
|
|
|
|
|
2016-06-05 21:11:05 +00:00
|
|
|
getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
|
|
|
|
getRepoEditR shr rp = do
|
2019-01-29 22:24:32 +00:00
|
|
|
(sid, er) <- runDB $ do
|
|
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
|
|
er <- getBy404 $ UniqueRepo rp sid
|
|
|
|
return (sid, er)
|
|
|
|
((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
|
2016-06-05 21:11:05 +00:00
|
|
|
defaultLayout $(widgetFile "repo/edit")
|
|
|
|
|
2016-05-23 12:24:14 +00:00
|
|
|
getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
|
2016-05-05 16:30:30 +00:00
|
|
|
getRepoSourceR shar repo refdir = do
|
|
|
|
repository <- runDB $ selectRepo shar repo
|
2016-05-05 07:29:19 +00:00
|
|
|
case repoVcs repository of
|
2016-05-05 16:30:30 +00:00
|
|
|
VCSDarcs -> getDarcsRepoSource repository shar repo refdir
|
2016-05-05 07:29:19 +00:00
|
|
|
VCSGit -> case refdir of
|
|
|
|
[] -> notFound
|
2016-05-05 16:30:30 +00:00
|
|
|
(ref:dir) -> getGitRepoSource repository shar repo ref dir
|
|
|
|
|
2018-03-31 22:04:33 +00:00
|
|
|
getRepoHeadChangesR :: ShrIdent -> RpIdent -> Handler TypedContent
|
2016-05-05 16:30:30 +00:00
|
|
|
getRepoHeadChangesR user repo = do
|
|
|
|
repository <- runDB $ selectRepo user repo
|
|
|
|
case repoVcs repository of
|
|
|
|
VCSDarcs -> getDarcsRepoHeadChanges user repo
|
|
|
|
VCSGit -> getGitRepoHeadChanges repository user repo
|
|
|
|
|
2019-08-28 15:31:40 +00:00
|
|
|
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
|
|
|
|
|
2018-03-31 22:04:33 +00:00
|
|
|
getRepoChangesR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
|
2016-05-05 16:30:30 +00:00
|
|
|
getRepoChangesR shar repo ref = do
|
|
|
|
repository <- runDB $ selectRepo shar repo
|
|
|
|
case repoVcs repository of
|
|
|
|
VCSDarcs -> getDarcsRepoChanges shar repo ref
|
|
|
|
VCSGit -> getGitRepoChanges shar repo ref
|
2016-05-29 14:13:25 +00:00
|
|
|
|
2019-08-06 13:23:11 +00:00
|
|
|
getRepoPatchR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent
|
2018-05-17 15:46:57 +00:00
|
|
|
getRepoPatchR shr rp ref = do
|
|
|
|
repository <- runDB $ selectRepo shr rp
|
|
|
|
case repoVcs repository of
|
2018-07-07 16:05:10 +00:00
|
|
|
VCSDarcs -> getDarcsPatch shr rp ref
|
2018-05-17 23:33:37 +00:00
|
|
|
VCSGit -> getGitPatch shr rp ref
|
2018-05-17 15:46:57 +00:00
|
|
|
|
2016-05-29 14:13:25 +00:00
|
|
|
getRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
2016-05-31 01:52:04 +00:00
|
|
|
getRepoDevsR shr rp = do
|
|
|
|
devs <- runDB $ do
|
|
|
|
rid <- do
|
|
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
|
|
Entity r _ <- getBy404 $ UniqueRepo rp s
|
|
|
|
return r
|
2019-09-09 00:27:45 +00:00
|
|
|
E.select $ E.from $ \ (collab `E.InnerJoin`
|
|
|
|
person `E.InnerJoin`
|
|
|
|
sharer `E.LeftOuterJoin`
|
|
|
|
role) -> do
|
|
|
|
E.on $ collab E.^. RepoCollabRole E.==. role E.?. RoleId
|
|
|
|
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
|
|
|
E.on $ collab E.^. RepoCollabPerson E.==. person E.^. PersonId
|
|
|
|
E.where_ $ collab E.^. RepoCollabRepo E.==. E.val rid
|
|
|
|
return (sharer, role E.?. RoleIdent)
|
2016-05-31 01:52:04 +00:00
|
|
|
defaultLayout $(widgetFile "repo/collab/list")
|
2016-05-29 14:13:25 +00:00
|
|
|
|
|
|
|
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
|
2016-05-31 01:52:04 +00:00
|
|
|
postRepoDevsR shr rp = do
|
2016-06-06 17:29:54 +00:00
|
|
|
(sid, mjid, rid) <- runDB $ do
|
2016-05-31 01:52:04 +00:00
|
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
2016-06-05 13:59:48 +00:00
|
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
2016-06-06 17:29:54 +00:00
|
|
|
return (s, repoProject repository, r)
|
|
|
|
((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid
|
2016-05-31 01:52:04 +00:00
|
|
|
case result of
|
|
|
|
FormSuccess nc -> do
|
|
|
|
runDB $ do
|
2016-06-01 07:35:22 +00:00
|
|
|
let collab = RepoCollab
|
|
|
|
{ repoCollabRepo = rid
|
|
|
|
, repoCollabPerson = ncPerson nc
|
|
|
|
, repoCollabRole = ncRole nc
|
2016-05-31 01:52:04 +00:00
|
|
|
}
|
|
|
|
insert_ collab
|
|
|
|
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")
|
2016-05-29 14:13:25 +00:00
|
|
|
|
|
|
|
getRepoDevNewR :: ShrIdent -> RpIdent -> Handler Html
|
2016-05-31 01:52:04 +00:00
|
|
|
getRepoDevNewR shr rp = do
|
2016-06-06 17:29:54 +00:00
|
|
|
(sid, mjid, rid) <- runDB $ do
|
2016-05-31 01:52:04 +00:00
|
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
2016-06-05 13:59:48 +00:00
|
|
|
Entity r repository <- getBy404 $ UniqueRepo rp s
|
2016-06-06 17:29:54 +00:00
|
|
|
return (s, repoProject repository, r)
|
2016-06-05 13:59:48 +00:00
|
|
|
((_result, widget), enctype) <-
|
2016-06-06 17:29:54 +00:00
|
|
|
runFormPost $ newRepoCollabForm sid mjid rid
|
2016-05-31 01:52:04 +00:00
|
|
|
defaultLayout $(widgetFile "repo/collab/new")
|
2016-05-29 14:13:25 +00:00
|
|
|
|
|
|
|
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
2016-05-31 01:52:04 +00:00
|
|
|
getRepoDevR shr rp dev = do
|
2019-01-29 22:24:32 +00:00
|
|
|
mrl <- runDB $ do
|
2016-05-31 01:52:04 +00:00
|
|
|
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
|
2016-06-01 07:35:22 +00:00
|
|
|
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid
|
2019-05-31 15:02:57 +00:00
|
|
|
fmap roleIdent <$> traverse getJust (repoCollabRole collab)
|
2016-05-31 01:52:04 +00:00
|
|
|
defaultLayout $(widgetFile "repo/collab/one")
|
2016-05-29 14:13:25 +00:00
|
|
|
|
|
|
|
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
2016-05-30 14:32:20 +00:00
|
|
|
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
|
2016-06-01 07:35:22 +00:00
|
|
|
Entity cid _collab <- getBy404 $ UniqueRepoCollab rid pid
|
2016-05-30 14:32:20 +00:00
|
|
|
delete cid
|
|
|
|
setMessage "Collaborator removed."
|
|
|
|
redirect $ RepoDevsR shr rp
|
2016-05-29 14:13:25 +00:00
|
|
|
|
|
|
|
postRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
|
2016-05-30 14:32:20 +00:00
|
|
|
postRepoDevR shr rp dev = do
|
|
|
|
mmethod <- lookupPostParam "_method"
|
|
|
|
case mmethod of
|
|
|
|
Just "DELETE" -> deleteRepoDevR shr rp dev
|
|
|
|
_ -> notFound
|
2019-05-27 13:28:57 +00:00
|
|
|
|
2019-09-09 00:27:45 +00:00
|
|
|
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
|
|
|
|
}
|
|
|
|
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
|
|
|
|
|
2019-05-27 19:54:11 +00:00
|
|
|
getHighlightStyleR :: Text -> Handler TypedContent
|
|
|
|
getHighlightStyleR styleName =
|
|
|
|
case lookup (unpack styleName) highlightingStyles of
|
2019-05-27 18:30:48 +00:00
|
|
|
Nothing -> notFound
|
|
|
|
Just style ->
|
|
|
|
return $ TypedContent typeCss $ toContent $ styleToCss style
|
2019-09-05 12:02:42 +00:00
|
|
|
|
2019-09-09 00:27:45 +00:00
|
|
|
postPostReceiveR :: Handler Text
|
|
|
|
postPostReceiveR = do
|
|
|
|
push <- requireCheckJsonBody
|
|
|
|
(pushAP, shr, rp) <- push2ap push
|
|
|
|
user <- runDB $ do
|
|
|
|
p <- getJustEntity $ toSqlKey $ H.pushUser push
|
|
|
|
s <- getJust $ personIdent $ entityVal p
|
|
|
|
return (p, s)
|
|
|
|
let shrUser = sharerIdent $ snd user
|
|
|
|
summary <- do
|
|
|
|
let mbranch = H.pushBranch push
|
|
|
|
total = pushCommitsTotal pushAP
|
|
|
|
withUrlRenderer
|
|
|
|
[hamlet|
|
|
|
|
<p>
|
|
|
|
<a href=@{SharerR shrUser}>#{shr2text shrUser}
|
|
|
|
\ pushed #{total} #
|
|
|
|
\ #{commitsText mbranch total} to repo #
|
|
|
|
<a href=@{RepoR shr rp}>#{rp2text rp}</a>^{branchText shr rp mbranch}.
|
|
|
|
|]
|
|
|
|
eid <- pushCommitsC user summary pushAP shr rp
|
|
|
|
case eid of
|
|
|
|
Left e -> liftIO $ throwIO $ userError $ T.unpack e
|
|
|
|
Right obiid -> do
|
|
|
|
renderUrl <- askUrlRender
|
|
|
|
obikhid <- encodeKeyHashid obiid
|
|
|
|
return $
|
|
|
|
"Push activity published: " <>
|
|
|
|
renderUrl (SharerOutboxItemR shrUser obikhid)
|
|
|
|
where
|
|
|
|
push2ap (H.Push secret _ sharer repo mbranch mbefore after early mlate) = do
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
|
|
let shr = text2shr sharer
|
|
|
|
rp = text2rp repo
|
|
|
|
commit2ap' = commit2ap shr rp
|
|
|
|
(commitsLast, commitsFirst) <-
|
|
|
|
runDB $ case mlate of
|
|
|
|
Nothing -> (,) <$> traverse commit2ap' early <*> pure Nothing
|
|
|
|
Just (_omitted, late) ->
|
|
|
|
(,) <$> traverse commit2ap' late
|
|
|
|
<*> (Just <$> traverse commit2ap' early)
|
|
|
|
return
|
|
|
|
( Push
|
|
|
|
{ pushCommitsLast = commitsLast
|
|
|
|
, pushCommitsFirst = commitsFirst
|
|
|
|
, pushCommitsTotal =
|
|
|
|
case mlate of
|
|
|
|
Nothing -> length early
|
|
|
|
Just (omitted, late) ->
|
|
|
|
length early + omitted + length late
|
|
|
|
, pushTarget =
|
|
|
|
encodeRouteLocal $
|
|
|
|
case mbranch of
|
|
|
|
Nothing -> RepoR shr rp
|
|
|
|
Just b -> RepoBranchR shr rp b
|
|
|
|
, pushHashBefore = mbefore
|
|
|
|
, pushHashAfter = after
|
|
|
|
}
|
|
|
|
, shr
|
|
|
|
, rp
|
|
|
|
)
|
|
|
|
where
|
|
|
|
commit2ap shr rp (H.Commit (wauthor, wtime) mcommitted hash title desc) = do
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
|
|
author <- authorByEmail wauthor
|
|
|
|
mcommitter <- traverse (authorByEmail . fst) mcommitted
|
|
|
|
return Commit
|
|
|
|
{ commitId = encodeRouteLocal $ RepoPatchR shr rp hash
|
|
|
|
, commitRepository = encodeRouteLocal $ RepoR shr rp
|
|
|
|
, commitAuthor = second (encodeRouteHome . SharerR) author
|
|
|
|
, commitCommitter =
|
|
|
|
second (encodeRouteHome . SharerR) <$> mcommitter
|
|
|
|
, commitTitle = title
|
|
|
|
, commitHash = Hash $ encodeUtf8 hash
|
|
|
|
, commitDescription =
|
|
|
|
if T.null desc
|
|
|
|
then Nothing
|
|
|
|
else Just desc
|
|
|
|
, commitWritten = wtime
|
|
|
|
, commitCommitted = snd <$> mcommitted
|
|
|
|
}
|
|
|
|
where
|
|
|
|
authorByEmail (H.Author name email) = do
|
|
|
|
mperson <- getValBy $ UniquePersonEmail email
|
|
|
|
case mperson of
|
|
|
|
Nothing -> return $ Left $ Author name email
|
|
|
|
Just person ->
|
|
|
|
Right . sharerIdent <$> getJust (personIdent person)
|
|
|
|
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 shr rp (Just branch) =
|
|
|
|
[hamlet|
|
|
|
|
, branch #
|
|
|
|
<a href=@{RepoBranchR shr rp branch}>#{branch}
|
|
|
|
|]
|