Repo settings page, allow repos to move between projects

config/routes

@@ -68,7 +68,8 @@
 
 /s/#ShrIdent/r                               ReposR            GET POST
 /s/#ShrIdent/r/!new                          RepoNewR          GET
-/s/#ShrIdent/r/#RpIdent                      RepoR             GET DELETE POST
+/s/#ShrIdent/r/#RpIdent                      RepoR             GET PUT DELETE POST
+/s/#ShrIdent/r/#RpIdent/edit                 RepoEditR         GET
 /s/#ShrIdent/r/#RpIdent/s/+Texts             RepoSourceR       GET
 /s/#ShrIdent/r/#RpIdent/c                    RepoHeadChangesR  GET
 /s/#ShrIdent/r/#RpIdent/c/#Text              RepoChangesR      GET

src/Vervis/Field/Repo.hs

@@ -15,17 +15,21 @@
 
 module Vervis.Field.Repo
     ( mkIdentField
+    , selectProjectForNew
+    , selectProjectForExisting
     )
 where
 
-import Vervis.Import hiding ((==.))
+import Vervis.Import hiding ((==.), on, isNothing)
 
 import Data.Char (isDigit)
 import Data.Char.Local (isAsciiLetter)
 import Data.Text (split)
 import Database.Esqueleto
 
-import Vervis.Model.Ident (text2rp)
+import qualified Database.Persist as P ((==.))
+
+import Vervis.Model.Ident (text2rp, prj2text)
 
 checkIdentTemplate :: Field Handler Text -> Field Handler Text
 checkIdentTemplate =
@@ -54,3 +58,38 @@ checkIdentUnique sid = checkM $ \ ident -> do
 
 mkIdentField :: SharerId -> Field Handler Text
 mkIdentField sid = checkIdentUnique sid . checkIdentTemplate $ textField
+
+-- | Select a project for a new repository to belong to. It can be any project
+-- of the same sharer who's sharing the repo.
+selectProjectForNew :: SharerId -> Field Handler ProjectId
+selectProjectForNew sid =
+    selectField $
+    optionsPersistKey [ProjectSharer P.==. sid] [] $
+    prj2text . projectIdent
+
+-- | Select a project for a repository to belong to. It can be any project of
+-- the same sharer who's sharing the repo.
+--
+-- However, there's an additional requirement that all repo collaborators are
+-- also project collaborators. I'm not sure I want this requirement, but it's
+-- easier to require it now and remove later, than require it later when the DB
+-- is already full of live repos and projects.
+--
+-- Also, a repo that is the wiki of the project can't be moved, but this is NOT
+-- CHECKED HERE. That's something to check before running the form, i.e. in the
+-- handler itself.
+selectProjectForExisting :: SharerId -> RepoId -> Field Handler ProjectId
+selectProjectForExisting sid rid = checkMembers $ selectProjectForNew sid
+    where
+    checkMembers = checkM $ \ jid -> do
+        l <- runDB $ select $ from $ \ (rc `LeftOuterJoin` pc) -> do
+            on $
+                rc ^. RepoCollabRepo       ==. val rid        &&.
+                pc ?. ProjectCollabProject ==. just (val jid) &&.
+                pc ?. ProjectCollabPerson  ==. just (rc ^. RepoCollabPerson)
+            where_ $ isNothing $ pc ?. ProjectCollabId
+            limit 1
+            return ()
+        return $ if null l
+            then Right jid
+            else Left ("Some repo members aren't project members" :: Text)

src/Vervis/Form/Project.hs

@@ -77,10 +77,10 @@ editProjectAForm :: Entity Project -> AForm Handler Project
 editProjectAForm (Entity jid project) = Project
     <$> pure                          (projectIdent project)
     <*> pure                          (projectSharer project)
-    <*> aopt textField "Name*"        (Just $ projectName project)
+    <*> aopt textField "Name"         (Just $ projectName project)
-    <*> aopt textField "Description*" (Just $ projectDesc project)
+    <*> aopt textField "Description"  (Just $ projectDesc project)
     <*> pure                          (projectNextTicket project)
-    <*> aopt selectWiki "Wiki*"       (Just $ projectWiki project)
+    <*> aopt selectWiki "Wiki"        (Just $ projectWiki project)
     where
     selectWiki =
         selectField $

src/Vervis/Form/Repo.hs

@@ -18,6 +18,7 @@ module Vervis.Form.Repo
     , newRepoForm
     , NewRepoCollab (..)
     , newRepoCollabForm
+    , editRepoForm
     )
 where
 
@@ -46,7 +47,7 @@ newRepoAForm
 newRepoAForm pid sid mpid = NewRepo
     <$> (text2rp <$> areq (mkIdentField sid) "Identifier*" Nothing)
     <*> areq (selectFieldList vcsList) "Version control system*" Nothing
-    <*> aopt selectProject "Project" (Just mpid)
+    <*> aopt (selectProjectForNew sid) "Project" (Just mpid)
     <*> aopt textField "Description" Nothing
     <*> areq selectRole "Your role*" Nothing
     where
@@ -55,10 +56,6 @@ newRepoAForm pid sid mpid = NewRepo
         [ ("Darcs", VCSDarcs)
         , ("Git"  , VCSGit)
         ]
-    selectProject =
-        selectField $
-        optionsPersistKey [ProjectSharer ==. sid] [Asc ProjectIdent] $
-        prj2text . projectIdent
     selectRole =
         selectField $
         optionsPersistKey [RepoRolePerson ==. pid] [] $
@@ -113,3 +110,20 @@ newRepoCollabAForm pid mjid rid = NewRepoCollab
 newRepoCollabForm
     :: PersonId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab
 newRepoCollabForm pid mjid rid = renderDivs $ newRepoCollabAForm pid mjid rid
+
+editRepoAForm :: Entity Repo -> AForm Handler Repo
+editRepoAForm (Entity rid repo) = Repo
+    <$> pure (repoIdent repo)
+    <*> pure (repoSharer repo)
+    <*> pure (repoVcs repo)
+    <*> aopt selectProject' "Project" (Just $ repoProject repo)
+    <*> aopt textField "Description" (Just $ repoDesc repo)
+    <*> let b = repoMainBranch repo
+        in  case repoVcs repo of
+                VCSDarcs -> pure b
+                VCSGit   -> areq textField "Main branch*" (Just b)
+    where
+    selectProject' = selectProjectForExisting (repoSharer repo) rid
+
+editRepoForm :: Entity Repo -> Form Repo
+editRepoForm r = renderDivs $ editRepoAForm r

src/Vervis/Foundation.hs

@@ -144,6 +144,7 @@ instance Yesod App where
         (ReposR shar             , True) -> person shar
         (RepoNewR user           , _   ) -> person user
         (RepoR shar _            , True) -> person shar
+        (RepoEditR shr _rp       , _   ) -> person shr
         (RepoDevsR shr _rp       , _   ) -> person shr
         (RepoDevNewR shr _rp     , _   ) -> person shr
         (RepoDevR shr _rp _dev   , _   ) -> person shr
@@ -329,6 +330,7 @@ instance YesodBreadcrumbs App where
         ReposR shar                      -> ("Repos", Just $ PersonR shar)
         RepoNewR shar                    -> ("New", Just $ ReposR shar)
         RepoR shar repo                  -> (rp2text repo, Just $ ReposR shar)
+        RepoEditR shr rp                 -> ("Edit", Just $ RepoR shr rp)
         RepoSourceR shar repo []         -> ("Files", Just $ RepoR shar repo)
         RepoSourceR shar repo refdir     -> ( last refdir
                                             , Just $

src/Vervis/Handler/Repo.hs

@@ -18,8 +18,10 @@ module Vervis.Handler.Repo
     , postReposR
     , getRepoNewR
     , getRepoR
+    , putRepoR
     , deleteRepoR
     , postRepoR
+    , getRepoEditR
     , getRepoSourceR
     , getRepoHeadChangesR
     , getRepoChangesR
@@ -51,6 +53,7 @@ import Data.List (inits)
 import Data.Text (Text, unpack)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
+import Data.Traversable (for)
 import Database.Esqueleto hiding (delete, (%))
 import Database.Persist (delete)
 import Data.Hourglass (timeConvert)
@@ -170,6 +173,35 @@ getRepoR shar repo = do
             getGitRepoSource
                 repository shar repo (repoMainBranch repository) []
 
+putRepoR :: ShrIdent -> RpIdent -> Handler Html
+putRepoR shr rp = do
+    mer <- runDB $ do
+        Entity sid _ <- getBy404 $ UniqueSharer shr
+        er@(Entity rid r) <- getBy404 $ UniqueRepo rp sid
+        mwiki <- for (repoProject r) $ \ jid -> do
+            project <- getJust jid
+            return $ (== rid) <$> projectWiki project
+        return $ case mwiki of
+            Just (Just True) -> Nothing
+            _                -> Just er
+    case mer of
+        Nothing -> do
+            setMessage "Repo used as a wiki, can't move between projects."
+            redirect $ RepoR shr rp
+        Just er@(Entity rid _) -> do
+            ((result, widget), enctype) <- runFormPost $ editRepoForm er
+            case result of
+                FormSuccess repository' -> do
+                    runDB $ replace rid repository'
+                    setMessage "Repository updated."
+                    redirect $ RepoR shr rp
+                FormMissing -> do
+                    setMessage "Field(s) missing."
+                    defaultLayout $(widgetFile "repo/edit")
+                FormFailure _l -> do
+                    setMessage "Repository update failed, see errors below."
+                    defaultLayout $(widgetFile "repo/edit")
+
 deleteRepoR :: ShrIdent -> RpIdent -> Handler Html
 deleteRepoR shar repo = do
     runDB $ do
@@ -193,9 +225,18 @@ postRepoR :: ShrIdent -> RpIdent -> Handler Html
 postRepoR shar repo = do
     mmethod <- lookupPostParam "_method"
     case mmethod of
+        Just "PUT"    -> putRepoR shar repo
         Just "DELETE" -> deleteRepoR shar repo
         _             -> notFound
 
+getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
+getRepoEditR shr rp = do
+    er <- runDB $ do
+        Entity s _ <- getBy404 $ UniqueSharer shr
+        getBy404 $ UniqueRepo rp s
+    ((_result, widget), enctype) <- runFormPost $ editRepoForm er
+    defaultLayout $(widgetFile "repo/edit")
+
 getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
 getRepoSourceR shar repo refdir = do
     repository <- runDB $ selectRepo shar repo

templates/repo/edit.hamlet

@@ -0,0 +1,18 @@
+$# 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=@{RepoR shr rp} enctype=#{enctype}>
+  <input type=hidden name=_method value=PUT>
+  ^{widget}
+  <input type=submit>