mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-11 02:36:47 +09:00
9d5399d636
Since project actors are the ones sending inbox forwards, they need to announce keys and allow their HTTP Signatures to be verified.
272 lines
10 KiB
Haskell
272 lines
10 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2019 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.Project
|
|
( getProjectsR
|
|
, postProjectsR
|
|
, getProjectNewR
|
|
, getProjectR
|
|
, putProjectR
|
|
, postProjectR
|
|
, getProjectEditR
|
|
, getProjectDevsR
|
|
, postProjectDevsR
|
|
, getProjectDevNewR
|
|
, getProjectDevR
|
|
, deleteProjectDevR
|
|
, postProjectDevR
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Database.Persist
|
|
import Database.Esqueleto hiding (delete, (%), (==.))
|
|
import Text.Blaze.Html (Html)
|
|
import Yesod.Auth (requireAuthId)
|
|
import Yesod.Core
|
|
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core (runDB, get404, getBy404)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Network.FedURI
|
|
import Web.ActivityPub
|
|
import Yesod.FedURI
|
|
|
|
import Vervis.Form.Project
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Model.Repo
|
|
import Vervis.Settings
|
|
import Vervis.Widget.Sharer
|
|
import Vervis.Widget.Workflow
|
|
|
|
getProjectsR :: ShrIdent -> Handler Html
|
|
getProjectsR ident = do
|
|
projects <- runDB $ select $ from $ \ (sharer, project) -> do
|
|
where_ $
|
|
sharer ^. SharerIdent E.==. val ident &&.
|
|
sharer ^. SharerId E.==. project ^. ProjectSharer
|
|
orderBy [asc $ project ^. ProjectIdent]
|
|
return $ project ^. ProjectIdent
|
|
defaultLayout $(widgetFile "project/list")
|
|
|
|
postProjectsR :: ShrIdent -> Handler Html
|
|
postProjectsR shr = do
|
|
Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
|
|
((result, widget), enctype) <- runFormPost $ newProjectForm sid
|
|
case result of
|
|
FormSuccess np -> do
|
|
pid <- requireAuthId
|
|
runDB $ do
|
|
let project = Project
|
|
{ projectIdent = npIdent np
|
|
, projectSharer = sid
|
|
, projectName = npName np
|
|
, projectDesc = npDesc np
|
|
, projectWorkflow = npWflow np
|
|
, projectNextTicket = 1
|
|
, projectWiki = Nothing
|
|
, projectCollabAnon = Nothing
|
|
, projectCollabUser = Nothing
|
|
}
|
|
jid <- insert project
|
|
let collab = ProjectCollab
|
|
{ projectCollabProject = jid
|
|
, projectCollabPerson = pid
|
|
, projectCollabRole = npRole np
|
|
}
|
|
insert_ collab
|
|
setMessage "Project added."
|
|
redirect $ ProjectR shr (npIdent np)
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "project/new")
|
|
FormFailure _l -> do
|
|
setMessage "Project creation failed, see below"
|
|
defaultLayout $(widgetFile "project/new")
|
|
|
|
getProjectNewR :: ShrIdent -> Handler Html
|
|
getProjectNewR shr = do
|
|
Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
|
|
((_result, widget), enctype) <- runFormPost $ newProjectForm sid
|
|
defaultLayout $(widgetFile "project/new")
|
|
|
|
getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
|
|
getProjectR shar proj = selectRep $ do
|
|
provideRep $ do
|
|
(project, workflow, wsharer, repos) <- runDB $ do
|
|
Entity sid s <- getBy404 $ UniqueSharer shar
|
|
Entity pid p <- getBy404 $ UniqueProject proj sid
|
|
w <- get404 $ projectWorkflow p
|
|
sw <-
|
|
if workflowSharer w == sid
|
|
then return s
|
|
else get404 $ workflowSharer w
|
|
rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
|
|
return (p, w, sw, rs)
|
|
defaultLayout $(widgetFile "project/one")
|
|
provideAP $ do
|
|
project <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity _pid p <- getBy404 $ UniqueProject proj sid
|
|
return p
|
|
route2fed <- getEncodeRouteFed
|
|
route2local <- getEncodeRouteLocal
|
|
let (host, me) = f2l $ route2fed $ ProjectR shar proj
|
|
return $ Doc host Actor
|
|
{ actorId = me
|
|
, actorType = ActorTypeProject
|
|
, actorUsername = Nothing
|
|
, actorName =
|
|
Just $ fromMaybe (prj2text proj) $ projectName project
|
|
, actorSummary = projectDesc project
|
|
, actorInbox = route2local $ ProjectInboxR shar proj
|
|
, actorPublicKeys =
|
|
[ Left $ route2local ActorKey1R
|
|
, Left $ route2local ActorKey2R
|
|
]
|
|
}
|
|
|
|
putProjectR :: ShrIdent -> PrjIdent -> Handler Html
|
|
putProjectR shr prj = do
|
|
(sid, ep@(Entity jid _)) <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharer shr
|
|
eproj <- getBy404 $ UniqueProject prj sid
|
|
return (sid, eproj)
|
|
((result, widget), enctype) <- runFormPost $ editProjectForm sid ep
|
|
case result of
|
|
FormSuccess project' -> do
|
|
runDB $ replace jid project'
|
|
setMessage "Project updated."
|
|
redirect $ ProjectR shr prj
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing."
|
|
defaultLayout $(widgetFile "project/edit")
|
|
FormFailure _l -> do
|
|
setMessage "Project update failed, see errors below."
|
|
defaultLayout $(widgetFile "project/edit")
|
|
|
|
postProjectR :: ShrIdent -> PrjIdent -> Handler Html
|
|
postProjectR shr prj = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "PUT" -> putProjectR shr prj
|
|
_ -> notFound
|
|
|
|
getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html
|
|
getProjectEditR shr prj = do
|
|
(sid, ep) <- runDB $ do
|
|
Entity sid _sharer <- getBy404 $ UniqueSharer shr
|
|
ep <- getBy404 $ UniqueProject prj sid
|
|
return (sid, ep)
|
|
((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
|
|
defaultLayout $(widgetFile "project/edit")
|
|
|
|
getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
|
|
getProjectDevsR shr prj = do
|
|
devs <- runDB $ do
|
|
jid <- do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
|
return jid
|
|
select $ from $ \ (collab `InnerJoin`
|
|
person `InnerJoin`
|
|
sharer `LeftOuterJoin`
|
|
role) -> do
|
|
on $ collab ^. ProjectCollabRole E.==. role ?. ProjectRoleId
|
|
on $ person ^. PersonIdent E.==. sharer ^. SharerId
|
|
on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId
|
|
where_ $ collab ^. ProjectCollabProject E.==. val jid
|
|
return (sharer, role ?. ProjectRoleIdent)
|
|
defaultLayout $(widgetFile "project/collab/list")
|
|
|
|
postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
|
|
postProjectDevsR shr rp = do
|
|
(sid, jid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity j _ <- getBy404 $ UniqueProject rp s
|
|
return (s, j)
|
|
((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
|
|
case result of
|
|
FormSuccess nc -> do
|
|
runDB $ do
|
|
let collab = ProjectCollab
|
|
{ projectCollabProject = jid
|
|
, projectCollabPerson = ncPerson nc
|
|
, projectCollabRole = ncRole nc
|
|
}
|
|
insert_ collab
|
|
setMessage "Collaborator added."
|
|
redirect $ ProjectDevsR shr rp
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "project/collab/new")
|
|
FormFailure _l -> do
|
|
setMessage "Operation failed, see errors below"
|
|
defaultLayout $(widgetFile "project/collab/new")
|
|
|
|
getProjectDevNewR :: ShrIdent -> PrjIdent -> Handler Html
|
|
getProjectDevNewR shr rp = do
|
|
(sid, jid) <- runDB $ do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity j _ <- getBy404 $ UniqueProject rp s
|
|
return (s, j)
|
|
((_result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
|
|
defaultLayout $(widgetFile "project/collab/new")
|
|
|
|
getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
|
|
getProjectDevR shr prj dev = do
|
|
mrl <- runDB $ do
|
|
jid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity j _ <- getBy404 $ UniqueProject prj s
|
|
return j
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid
|
|
fmap projectRoleIdent <$> traverse getJust (projectCollabRole collab)
|
|
defaultLayout $(widgetFile "project/collab/one")
|
|
|
|
deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
|
|
deleteProjectDevR shr rp dev = do
|
|
runDB $ do
|
|
jid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer shr
|
|
Entity j _ <- getBy404 $ UniqueProject rp s
|
|
return j
|
|
pid <- do
|
|
Entity s _ <- getBy404 $ UniqueSharer dev
|
|
Entity p _ <- getBy404 $ UniquePersonIdent s
|
|
return p
|
|
Entity cid _collab <- getBy404 $ UniqueProjectCollab jid pid
|
|
delete cid
|
|
setMessage "Collaborator removed."
|
|
redirect $ ProjectDevsR shr rp
|
|
|
|
postProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
|
|
postProjectDevR shr rp dev = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteProjectDevR shr rp dev
|
|
_ -> notFound
|