1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-17 07:36:20 +09:00
vervis/src/Vervis/Handler/Project.hs

343 lines
13 KiB
Haskell
Raw Normal View History

2016-02-17 21:53:53 +00:00
{- This file is part of Vervis.
-
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
2016-02-17 21:53:53 +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.Project
2016-02-17 21:53:53 +00:00
( getProjectsR
, postProjectsR
, getProjectNewR
2016-02-17 21:53:53 +00:00
, getProjectR
, putProjectR
, postProjectR
, getProjectEditR
, getProjectDevsR
, postProjectDevsR
, getProjectDevNewR
, getProjectDevR
, deleteProjectDevR
, postProjectDevR
, getProjectTeamR
, getProjectFollowersR
2016-02-17 21:53:53 +00:00
)
where
2016-05-14 11:36:45 +00:00
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Database.Persist
import Database.Esqueleto hiding (delete, (%), (==.))
2016-05-14 11:36:45 +00:00
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
import Yesod.Core
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
2016-05-14 11:36:45 +00:00
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
2016-05-14 11:36:45 +00:00
import qualified Database.Esqueleto as E
2016-02-17 21:53:53 +00:00
import Network.FedURI
import Web.ActivityPub hiding (Project (..))
import Yesod.ActivityPub
import Yesod.FedURI
import qualified Web.ActivityPub as AP
import Data.Either.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.API
import Vervis.Federation
import Vervis.Form.Project
2016-05-14 11:36:45 +00:00
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
2016-05-14 11:36:45 +00:00
import Vervis.Model.Repo
import Vervis.Settings
import Vervis.Widget.Sharer
import Vervis.Widget.Workflow
2016-02-17 21:53:53 +00:00
getProjectsR :: ShrIdent -> Handler Html
2016-02-17 21:53:53 +00:00
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")
2016-02-17 21:53:53 +00:00
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
2019-06-09 16:21:23 +00:00
ibid <- insert Inbox
2019-06-16 21:34:06 +00:00
obid <- insert Outbox
fsid <- insert FollowerSet
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
2019-06-09 16:21:23 +00:00
, projectInbox = ibid
2019-06-16 21:34:06 +00:00
, projectOutbox = obid
, projectFollowers = fsid
}
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 = 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)
route2fed <- getEncodeRouteHome
route2local <- getEncodeRouteLocal
let projectAP = AP.Project
{ AP.projectActor = Actor
{ actorId = route2local $ ProjectR shar proj
, actorType = ActorTypeProject
, actorUsername = Nothing
, actorName =
Just $ fromMaybe (prj2text proj) $ projectName project
, actorSummary = projectDesc project
, actorInbox = route2local $ ProjectInboxR shar proj
, actorOutbox =
Just $ route2local $ ProjectOutboxR shar proj
, actorFollowers =
Just $ route2local $ ProjectFollowersR shar proj
, actorFollowing = Nothing
, actorPublicKeys =
[ Left $ route2local ActorKey1R
, Left $ route2local ActorKey2R
]
, actorSshKeys = []
}
, AP.projectTeam = route2local $ ProjectTeamR shar proj
}
followButton =
followW
(ProjectFollowR shar proj)
(ProjectUnfollowR shar proj)
(return $ projectFollowers project)
provideHtmlAndAP projectAP $(widgetFile "project/one")
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 ?. RoleId
on $ person ^. PersonIdent E.==. sharer ^. SharerId
on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId
where_ $ collab ^. ProjectCollabProject E.==. val jid
return (sharer, role ?. RoleIdent)
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 roleIdent <$> 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
getProjectTeamR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectTeamR shr prj = do
memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
_jid <- getKeyBy404 $ UniqueProject prj 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 = ProjectTeamR shr prj
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 $ redirect (here, [("prettyjson", "true")])
getProjectFollowersR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectFollowersR shr prj = getFollowersCollection here getFsid
where
here = ProjectFollowersR shr prj
getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid
return $ projectFollowers j