Ticket dependency add/remove and some fixes to recursive SQL
This commit is contained in:
parent
ddd4393825
commit
5c153b0294
16 changed files with 231 additions and 19 deletions
|
@ -109,7 +109,9 @@
|
|||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int TicketMessageR GET POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepR POST DELETE
|
||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET
|
||||
|
||||
/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET
|
||||
|
|
|
@ -23,5 +23,7 @@ import Prelude
|
|||
import Database.Persist
|
||||
|
||||
class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where
|
||||
sourceParam :: e -> Key n
|
||||
sourceField :: EntityField e (Key n)
|
||||
destParam :: e -> Key n
|
||||
destField :: EntityField e (Key n)
|
||||
|
|
|
@ -18,6 +18,8 @@ module Database.Persist.Local.Sql
|
|||
, rawSqlWithGraph
|
||||
, dummyFromFst
|
||||
, dummyFromSnd
|
||||
, destParamFromProxy
|
||||
, sourceParamFromProxy
|
||||
, destFieldFromProxy
|
||||
, sourceFieldFromProxy
|
||||
, (?:)
|
||||
|
@ -27,7 +29,7 @@ where
|
|||
|
||||
import Prelude
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.Trans.Reader (ReaderT, ask)
|
||||
import Data.Int (Int64)
|
||||
import Data.Monoid ((<>))
|
||||
|
@ -37,7 +39,7 @@ import Database.Persist
|
|||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
import qualified Data.Text as T (null, unpack, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
|
@ -55,6 +57,20 @@ dummyFromFst _ = Nothing
|
|||
dummyFromSnd :: Proxy (a, b) -> Maybe b
|
||||
dummyFromSnd _ = Nothing
|
||||
|
||||
destParamFromProxy
|
||||
:: PersistEntityGraph node edge
|
||||
=> Proxy (node, edge)
|
||||
-> edge
|
||||
-> Key node
|
||||
destParamFromProxy _ = destParam
|
||||
|
||||
sourceParamFromProxy
|
||||
:: PersistEntityGraph node edge
|
||||
=> Proxy (node, edge)
|
||||
-> edge
|
||||
-> Key node
|
||||
sourceParamFromProxy _ = sourceParam
|
||||
|
||||
destFieldFromProxy
|
||||
:: PersistEntityGraph node edge
|
||||
=> Proxy (node, edge)
|
||||
|
|
|
@ -157,7 +157,7 @@ xmconnectsm' follow filter msource mdest mlen proxy = do
|
|||
Just _ -> mconcat
|
||||
[ " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
, " = ANY(?)"
|
||||
]
|
||||
, " UNION ALL "
|
||||
, case follow of
|
||||
|
@ -174,10 +174,10 @@ xmconnectsm' follow filter msource mdest mlen proxy = do
|
|||
, " FROM ", dbname temp
|
||||
, case mdest of
|
||||
Nothing -> ""
|
||||
Just _ -> " WHERE ", temp ^* tid, " IN ?"
|
||||
Just _ -> " WHERE " <> temp ^* tid <> " = ANY(?)"
|
||||
, case mlen of
|
||||
Nothing -> ""
|
||||
Just _ -> " AND array_length(", temp ^* tpath, ", 1) <= ?"
|
||||
Just _ -> " AND array_length(" <> temp ^* tpath <> ", 1) <= ?"
|
||||
, " )"
|
||||
]
|
||||
toP = fmap toPersistValue
|
||||
|
|
|
@ -251,13 +251,14 @@ trrFix
|
|||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key edge
|
||||
-> Key edge
|
||||
=> edge
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Int64
|
||||
trrFix from to proxy = do
|
||||
trrFix edge proxy = do
|
||||
conn <- ask
|
||||
let tNode = entityDef $ dummyFromFst proxy
|
||||
let from = sourceParamFromProxy proxy edge
|
||||
to = destParamFromProxy proxy edge
|
||||
tNode = entityDef $ dummyFromFst proxy
|
||||
tEdge = entityDef $ dummyFromSnd proxy
|
||||
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||
|
|
|
@ -15,18 +15,26 @@
|
|||
|
||||
module Vervis.Field.Ticket
|
||||
( selectAssigneeFromProject
|
||||
, selectTicketDep
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Database.Esqueleto
|
||||
import Yesod.Form.Fields (selectField, optionsPairs)
|
||||
import Data.Text (Text)
|
||||
import Database.Esqueleto hiding ((%))
|
||||
import Formatting
|
||||
import Yesod.Form.Fields (selectField, optionsPairs, optionsPersistKey)
|
||||
import Yesod.Form.Functions (checkBool, checkM)
|
||||
import Yesod.Form.Types (Field)
|
||||
import Yesod.Persist.Core (runDB)
|
||||
|
||||
import qualified Database.Persist as P
|
||||
|
||||
import Database.Persist.Sql.Graph.Connects (uconnects)
|
||||
import Vervis.Foundation (Handler)
|
||||
import Vervis.GraphProxy (ticketDepGraph)
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident (shr2text)
|
||||
|
||||
|
@ -44,3 +52,25 @@ selectAssigneeFromProject pid jid = selectField $ do
|
|||
person ^. PersonId !=. val pid
|
||||
return (sharer ^. SharerIdent, person ^. PersonId)
|
||||
optionsPairs $ map (shr2text . unValue *** unValue) l
|
||||
|
||||
checkNotSelf :: TicketId -> Field Handler TicketId -> Field Handler TicketId
|
||||
checkNotSelf tidP =
|
||||
checkBool (/= tidP) ("A ticket can’t depend on itself" :: Text)
|
||||
|
||||
checkDep :: TicketId -> Field Handler TicketId -> Field Handler TicketId
|
||||
checkDep tidP = checkM $ \ tidC -> do
|
||||
uconn <- runDB $ uconnects tidP tidC Nothing ticketDepGraph
|
||||
return $ if uconn
|
||||
then Left ("There is already a dependency between the tickets" :: Text)
|
||||
else Right tidC
|
||||
|
||||
-- | Select a ticket from a project, but exclude the given ticket ID. When
|
||||
-- processing the form, verify there is no depedndency between the tickets
|
||||
-- (i.e. neither is reachable from the other).
|
||||
selectTicketDep :: ProjectId -> TicketId -> Field Handler TicketId
|
||||
selectTicketDep jid tid =
|
||||
checkDep tid $
|
||||
checkNotSelf tid $
|
||||
selectField $
|
||||
optionsPersistKey [TicketProject P.==. jid, TicketId P.!=. tid] [] $
|
||||
\ t -> sformat (int % " :: " % stext) (ticketNumber t) (ticketTitle t)
|
||||
|
|
|
@ -20,6 +20,7 @@ module Vervis.Form.Ticket
|
|||
, assignTicketForm
|
||||
, claimRequestForm
|
||||
, ticketFilterForm
|
||||
, ticketDepForm
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -104,3 +105,9 @@ ticketFilterAForm = TicketFilter
|
|||
|
||||
ticketFilterForm :: Form TicketFilter
|
||||
ticketFilterForm = renderDivs ticketFilterAForm
|
||||
|
||||
ticketDepAForm :: ProjectId -> TicketId -> AForm Handler TicketId
|
||||
ticketDepAForm jid tid = areq (selectTicketDep jid tid) "Dependency" Nothing
|
||||
|
||||
ticketDepForm :: ProjectId -> TicketId -> Form TicketId
|
||||
ticketDepForm jid tid = renderDivs $ ticketDepAForm jid tid
|
||||
|
|
|
@ -178,6 +178,9 @@ instance Yesod App where
|
|||
(TicketMessageR _ _ _ _ , True) -> personAny
|
||||
(TicketTopReplyR _ _ _ , _ ) -> personAny
|
||||
(TicketReplyR _ _ _ _ , _ ) -> personAny
|
||||
(TicketDepsR s j _ , True) -> projOp ProjOpAddTicketDep s j
|
||||
(TicketDepNewR s j _ , _ ) -> projOp ProjOpAddTicketDep s j
|
||||
(TicketDepR s j _ _ , True) -> projOp ProjOpRemoveTicketDep s j
|
||||
_ -> return Authorized
|
||||
where
|
||||
nobody :: Handler AuthResult
|
||||
|
@ -495,6 +498,12 @@ instance YesodBreadcrumbs App where
|
|||
TicketDepsR shr prj num -> ( "Dependencies"
|
||||
, Just $ TicketR shr prj num
|
||||
)
|
||||
TicketDepNewR shr prj num -> ( "New dependency"
|
||||
, Just $ TicketDepsR shr prj num
|
||||
)
|
||||
TicketDepR shr prj pnum cnum -> ( T.pack $ '#' : show cnum
|
||||
, Just $ TicketDepsR shr prj pnum
|
||||
)
|
||||
TicketReverseDepsR shr prj num -> ( "Dependants"
|
||||
, Just $ TicketR shr prj num
|
||||
)
|
||||
|
|
45
src/Vervis/GraphProxy.hs
Normal file
45
src/Vervis/GraphProxy.hs
Normal file
|
@ -0,0 +1,45 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016 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/>.
|
||||
-}
|
||||
|
||||
-- | Persistent graphs are specified using the 'PersistEntityGraph' typeclass,
|
||||
-- using value functions which specify fields. But the DB schema is known at
|
||||
-- development time, and a specific graph needs to be picked statically. Since
|
||||
-- the 'persistent' package doesn't have compile-time (e.g. type-level)
|
||||
-- representation of the schema (but instead converts from TH directly to
|
||||
-- datatypes), the graph related functions use a 'Proxy' which specifies the
|
||||
-- graph using the type.
|
||||
--
|
||||
-- I don't know enough about type systems and advanced type features and GHC
|
||||
-- extensions, to tell whether a better solution is possible. For now, this is
|
||||
-- how things work.
|
||||
--
|
||||
-- This module is a helper for easily specifying graphs instead of typing the
|
||||
-- proxy type directly each time, which may be long and cumbersome.
|
||||
module Vervis.GraphProxy
|
||||
( GraphProxy
|
||||
, ticketDepGraph
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Vervis.Model
|
||||
|
||||
type GraphProxy n e = Proxy (n, e)
|
||||
|
||||
ticketDepGraph :: GraphProxy Ticket TicketDependency
|
||||
ticketDepGraph = Proxy
|
|
@ -41,6 +41,10 @@ module Vervis.Handler.Ticket
|
|||
, getTicketTopReplyR
|
||||
, getTicketReplyR
|
||||
, getTicketDepsR
|
||||
, postTicketDepsR
|
||||
, getTicketDepNewR
|
||||
, postTicketDepR
|
||||
, deleteTicketDepR
|
||||
, getTicketReverseDepsR
|
||||
)
|
||||
where
|
||||
|
@ -57,7 +61,7 @@ import Data.Time.Calendar (Day (..))
|
|||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||
import Data.Traversable (for)
|
||||
import Database.Esqueleto hiding ((==.), (=.), (+=.), update)
|
||||
import Database.Esqueleto hiding ((==.), (=.), (+=.), update, delete)
|
||||
import Database.Persist
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||||
|
@ -70,9 +74,11 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
|
|||
import qualified Data.Text as T (filter, intercalate, pack)
|
||||
import qualified Database.Esqueleto as E ((==.))
|
||||
|
||||
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
|
||||
import Vervis.Form.Ticket
|
||||
import Vervis.Foundation
|
||||
import Vervis.Handler.Discussion
|
||||
import Vervis.GraphProxy (ticketDepGraph)
|
||||
import Vervis.MediaType (MediaType (Markdown))
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
@ -576,5 +582,60 @@ getTicketDeps forward shr prj num = do
|
|||
getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketDepsR = getTicketDeps True
|
||||
|
||||
postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
postTicketDepsR shr prj num = do
|
||||
(jid, tid) <- runDB $ do
|
||||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||||
Entity tid _ <- getBy404 $ UniqueTicket jid num
|
||||
return (jid, tid)
|
||||
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
||||
case result of
|
||||
FormSuccess ctid -> do
|
||||
runDB $ do
|
||||
let td = TicketDependency
|
||||
{ ticketDependencyParent = tid
|
||||
, ticketDependencyChild = ctid
|
||||
}
|
||||
insert_ td
|
||||
trrFix td ticketDepGraph
|
||||
setMessage "Ticket dependency added."
|
||||
redirect $ TicketR shr prj num
|
||||
FormMissing -> do
|
||||
setMessage "Field(s) missing."
|
||||
defaultLayout $(widgetFile "ticket/dep/new")
|
||||
FormFailure _l -> do
|
||||
setMessage "Submission failed, see errors below."
|
||||
defaultLayout $(widgetFile "ticket/dep/new")
|
||||
|
||||
getTicketDepNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketDepNewR shr prj num = do
|
||||
(jid, tid) <- runDB $ do
|
||||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||||
Entity tid _ <- getBy404 $ UniqueTicket jid num
|
||||
return (jid, tid)
|
||||
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
||||
defaultLayout $(widgetFile "ticket/dep/new")
|
||||
|
||||
postTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||||
postTicketDepR shr prj pnum cnum = do
|
||||
mmethod <- lookupPostParam "_method"
|
||||
case mmethod of
|
||||
Just "DELETE" -> deleteTicketDepR shr prj pnum cnum
|
||||
_ -> notFound
|
||||
|
||||
deleteTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||||
deleteTicketDepR shr prj pnum cnum = do
|
||||
runDB $ do
|
||||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||||
Entity ptid _ <- getBy404 $ UniqueTicket jid pnum
|
||||
Entity ctid _ <- getBy404 $ UniqueTicket jid cnum
|
||||
Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
|
||||
delete tdid
|
||||
setMessage "Ticket dependency removed."
|
||||
redirect $ TicketDepsR shr prj pnum
|
||||
|
||||
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||
getTicketReverseDepsR = getTicketDeps False
|
||||
|
|
|
@ -24,6 +24,7 @@ import Database.Persist.Quasi
|
|||
import Database.Persist.Sql (fromSqlKey)
|
||||
import Yesod.Auth.HashDB (HashDBUser (..))
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Vervis.Model.Group
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Repo
|
||||
|
@ -53,3 +54,9 @@ instance Hashable RepoRoleId where
|
|||
instance Hashable ProjectRoleId where
|
||||
hashWithSalt salt = hashWithSalt salt . fromSqlKey
|
||||
hash = hash . fromSqlKey
|
||||
|
||||
instance PersistEntityGraph Ticket TicketDependency where
|
||||
sourceParam = ticketDependencyParent
|
||||
sourceField = TicketDependencyParent
|
||||
destParam = ticketDependencyChild
|
||||
destField = TicketDependencyChild
|
||||
|
|
|
@ -33,6 +33,8 @@ data ProjectOperation
|
|||
| ProjOpUnclaimTicket
|
||||
| ProjOpAssignTicket
|
||||
| ProjOpUnassignTicket
|
||||
| ProjOpAddTicketDep
|
||||
| ProjOpRemoveTicketDep
|
||||
deriving (Eq, Show, Read, Enum, Bounded)
|
||||
|
||||
derivePersistField "ProjectOperation"
|
||||
|
|
|
@ -71,16 +71,16 @@ getProjectRoleAncestorWithOpQ op role = do
|
|||
ProjectRoleInheritParent
|
||||
ProjectRoleInheritChild
|
||||
(\ temp -> mconcat
|
||||
[ "SELECT ", qcols
|
||||
, " FROM ", dbname temp, ", ", tAcc
|
||||
, " WHERE "
|
||||
[ "SELECT ??"
|
||||
, " FROM ", dbname temp, " INNER JOIN ", tAcc
|
||||
, " ON "
|
||||
, dbname temp, ".", field ProjectRoleInheritParent
|
||||
, " = "
|
||||
, tAcc, ".", field ProjectAccessRole
|
||||
, " AND "
|
||||
, " WHERE "
|
||||
, tAcc, ".", field ProjectAccessOp
|
||||
, " = ?"
|
||||
, " LIMIT TO 1"
|
||||
, " LIMIT 1"
|
||||
]
|
||||
)
|
||||
[toPersistValue op]
|
||||
|
|
|
@ -18,6 +18,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<th>Author
|
||||
<th>Title
|
||||
<th>Done
|
||||
$if forward
|
||||
<th>Remove dependency
|
||||
$forall (Value number, Entity _ author, Value title, Value done) <- rows
|
||||
<tr>
|
||||
<td>
|
||||
|
@ -28,3 +30,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<a href=@{TicketR shr prj number}>#{title}
|
||||
<td>
|
||||
#{done}
|
||||
$if forward
|
||||
<td>
|
||||
<form method=POST action=@{TicketDepR shr prj num number}>
|
||||
<input type=hidden name=_method value=DELETE>
|
||||
<input type=submit value="Remove">
|
||||
|
||||
$if forward
|
||||
<p>
|
||||
<a href=@{TicketDepNewR shr prj num}>
|
||||
Add new…
|
||||
|
|
17
templates/ticket/dep/new.hamlet
Normal file
17
templates/ticket/dep/new.hamlet
Normal file
|
@ -0,0 +1,17 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016 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/>.
|
||||
|
||||
<form method=POST action=@{TicketDepsR shr prj num} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<input type=submit>
|
|
@ -119,6 +119,7 @@ library
|
|||
Vervis.Foundation
|
||||
Vervis.Git
|
||||
Vervis.GitOld
|
||||
Vervis.GraphProxy
|
||||
Vervis.Handler.Common
|
||||
Vervis.Handler.Discussion
|
||||
Vervis.Handler.Git
|
||||
|
|
Loading…
Reference in a new issue