1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-02-18 01:17:17 +09:00
vervis/src/Vervis/Patch.hs

233 lines
7.4 KiB
Haskell
Raw Normal View History

2018-05-18 19:44:14 +00:00
{- This file is part of Vervis.
-
- Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
2018-05-18 19:44:14 +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.Patch
( getSharerProposal
, getSharerProposal404
, getRepoProposal
, getRepoProposal404
2018-05-18 19:44:14 +00:00
)
where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Yesod.Core
2018-05-18 19:44:14 +00:00
import Yesod.Hashids
2018-05-18 19:44:14 +00:00
import Data.Either.Local
import Database.Persist.Local
2018-05-18 19:44:14 +00:00
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
getResolved
:: MonadIO m
=> LocalTicketId
-> ReaderT SqlBackend m
(Maybe
( Entity TicketResolve
, Either (Entity TicketResolveLocal) (Entity TicketResolveRemote)
)
)
getResolved ltid = do
metr <- getBy $ UniqueTicketResolve ltid
for metr $ \ etr@(Entity trid _) ->
(etr,) <$>
requireEitherAlt
(getBy $ UniqueTicketResolveLocal trid)
(getBy $ UniqueTicketResolveRemote trid)
"No TRX"
"Both TRL and TRR"
getSharerProposal
:: MonadIO m
=> ShrIdent
-> TicketAuthorLocalId
-> ReaderT SqlBackend m
( Maybe
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either
( Entity TicketContextLocal
, Entity TicketRepoLocal
)
( Entity TicketProjectRemote
, Maybe (Entity TicketProjectRemoteAccept)
)
, Maybe
( Entity TicketResolve
, Either
(Entity TicketResolveLocal)
(Entity TicketResolveRemote)
)
, NonEmpty BundleId
)
)
getSharerProposal shr talid = runMaybeT $ do
pid <- do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniquePersonIdent sid
tal <- MaybeT $ get talid
guard $ ticketAuthorLocalAuthor tal == pid
let ltid = ticketAuthorLocalTicket tal
lt <- lift $ getJust ltid
let tid = localTicketTicket lt
t <- lift $ getJust tid
bnids <-
MaybeT $
nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
repo <-
requireEitherAlt
(do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid
for mtcl $ \ etcl@(Entity tclid _) -> do
etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid
mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
unless (isJust mtup1 == isJust mtup2) $
error "TUP points to unrelated TAL and TCL!"
guard $ not $ isJust mtup1
return (etcl, etrl)
)
(do mtpr <- lift $ getBy $ UniqueTicketProjectRemote talid
lift $ for mtpr $ \ etpr@(Entity tprid _) ->
(etpr,) <$> getBy (UniqueTicketProjectRemoteAccept tprid)
)
"MR doesn't have context"
"MR has both local and remote context"
mresolved <- lift $ getResolved ltid
return (Entity talid tal, Entity ltid lt, Entity tid t, repo, mresolved, bnids)
getSharerProposal404
:: ShrIdent
-> KeyHashid TicketAuthorLocal
-> AppDB
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either
( Entity TicketContextLocal
, Entity TicketRepoLocal
)
( Entity TicketProjectRemote
, Maybe (Entity TicketProjectRemoteAccept)
)
, Maybe
( Entity TicketResolve
, Either
(Entity TicketResolveLocal)
(Entity TicketResolveRemote)
)
, NonEmpty BundleId
)
getSharerProposal404 shr talkhid = do
talid <- decodeKeyHashid404 talkhid
mpatch <- getSharerProposal shr talid
case mpatch of
Nothing -> notFound
Just patch -> return patch
getRepoProposal
:: MonadIO m
=> ShrIdent
-> RpIdent
-> LocalTicketId
-> ReaderT SqlBackend m
( Maybe
( Entity Sharer
, Entity Repo
, Entity Ticket
, Entity LocalTicket
, Entity TicketContextLocal
, Entity TicketRepoLocal
, Either
(Entity TicketAuthorLocal, Entity TicketUnderProject)
(Entity TicketAuthorRemote)
, Maybe
( Entity TicketResolve
, Either
(Entity TicketResolveLocal)
(Entity TicketResolveRemote)
)
, NonEmpty BundleId
)
)
getRepoProposal shr rp ltid = runMaybeT $ do
es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr
er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid
lt <- MaybeT $ get ltid
let tid = localTicketTicket lt
t <- MaybeT $ get tid
etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid
etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid
guard $ ticketRepoLocalRepo trl == rid
bnids <-
MaybeT $
nonEmpty <$> selectKeysList [BundleTicket ==. tid] [Desc BundleId]
author <-
requireEitherAlt
(do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid
for mtal $ \ tal@(Entity talid _) -> do
tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tclid
tup@(Entity tupid2 _) <- MaybeT $ getBy $ UniqueTicketUnderProjectAuthor talid
unless (tupid1 == tupid2) $
error "TAL and TPL used by different TUPs!"
return (tal, tup)
)
(lift $ getBy $ UniqueTicketAuthorRemote tclid)
"MR doesn't have author"
"MR has both local and remote author"
mresolved <- lift $ getResolved ltid
return (es, er, Entity tid t, Entity ltid lt, etcl, etrl, author, mresolved, bnids)
getRepoProposal404
:: ShrIdent
-> RpIdent
-> KeyHashid LocalTicket
-> AppDB
( Entity Sharer
, Entity Repo
, Entity Ticket
, Entity LocalTicket
, Entity TicketContextLocal
, Entity TicketRepoLocal
, Either
(Entity TicketAuthorLocal, Entity TicketUnderProject)
(Entity TicketAuthorRemote)
, Maybe
( Entity TicketResolve
, Either
(Entity TicketResolveLocal)
(Entity TicketResolveRemote)
)
, NonEmpty BundleId
)
getRepoProposal404 shr rp ltkhid = do
ltid <- decodeKeyHashid404 ltkhid
mpatch <- getRepoProposal shr rp ltid
case mpatch of
Nothing -> notFound
Just patch -> return patch