forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Ticket dependency add/remove and some fixes to recursive SQL

Browse source
This commit is contained in:
fr33domlover 2016-07-28 16:40:10 +00:00
parent ddd4393825
commit 5c153b0294
16 changed files with 231 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
config/routes
View file

@ -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

2
src/Database/Persist/Local/Class/PersistEntityGraph.hs
View file

@ -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)

20
src/Database/Persist/Local/Sql.hs
View file

@ -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)

6
src/Database/Persist/Sql/Graph/Connects.hs
View file

@ -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

9
src/Database/Persist/Sql/Graph/TransitiveReduction.hs
View file

@ -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

34
src/Vervis/Field/Ticket.hs
View file

@ -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)

7
src/Vervis/Form/Ticket.hs
View file

@ -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

9
src/Vervis/Foundation.hs
View file

@ -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
View 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

63
src/Vervis/Handler/Ticket.hs
View file

@ -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

7
src/Vervis/Model.hs
View file

@ -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

2
src/Vervis/Model/Role.hs
View file

@ -33,6 +33,8 @@ data ProjectOperation
| ProjOpUnclaimTicket
| ProjOpAssignTicket
| ProjOpUnassignTicket
| ProjOpAddTicketDep
| ProjOpRemoveTicketDep
deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "ProjectOperation"

12
src/Vervis/Query.hs
View file

@ -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]

12
templates/ticket/dep/list.hamlet
View file

@ -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
View 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>

1
vervis.cabal
View file

@ -119,6 +119,7 @@ library
Vervis.Foundation
Vervis.Git
Vervis.GitOld
Vervis.GraphProxy
Vervis.Handler.Common
Vervis.Handler.Discussion
Vervis.Handler.Git