Repo deletion button

config/routes

@@ -42,7 +42,7 @@
 
 /u/#Text/r                              ReposR            GET POST
 /u/#Text/r/!new                         RepoNewR          GET
-/u/#Text/r/#Text                        RepoR             GET
+/u/#Text/r/#Text                        RepoR             GET DELETE POST
 /u/#Text/r/#Text/s/+Texts               RepoSourceR       GET
 /u/#Text/r/#Text/c                      RepoHeadChangesR  GET
 /u/#Text/r/#Text/c/#Text                RepoChangesR      GET

src/Vervis/Foundation.hs

@@ -125,6 +125,8 @@ instance Yesod App where
         loggedInAs user "You can’t watch keys of other users"
     isAuthorized (KeyNewR user) _ =
         loggedInAs user "You can’t add keys for other users"
+    isAuthorized (RepoR shar _) True =
+        loggedInAs shar "You can’t modify repos for other users"
     isAuthorized (TicketNewR _ _) _ = loggedIn
     isAuthorized (TicketR user _ _) True =
         loggedInAs user "Only project members can modify this ticket"

src/Vervis/Handler/Repo.hs

@@ -18,6 +18,8 @@ module Vervis.Handler.Repo
     , postReposR
     , getRepoNewR
     , getRepoR
+    , deleteRepoR
+    , postRepoR
     , getRepoSourceR
     , getRepoHeadChangesR
     , getRepoChangesR
@@ -34,7 +36,7 @@ where
 -- [x] write the git and mkdir parts that actually create the repo
 -- [x] make repo view that shows a table of commits
 
-import ClassyPrelude.Conduit       hiding (last, unpack)
+import ClassyPrelude.Conduit       hiding (last, unpack, delete)
 import Yesod                       hiding (Header, parseTime, (==.))
 import Yesod.Auth
 
@@ -54,9 +56,10 @@ import Data.List (inits)
 import Data.Text (unpack)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
-import Database.Esqueleto
+import Database.Esqueleto hiding (delete, (%))
 import Data.Hourglass (timeConvert)
-import System.Directory (createDirectoryIfMissing)
+import Formatting (sformat, stext, (%))
+import System.Directory
 import System.Hourglass (dateCurrent)
 
 import qualified Data.DList as D
@@ -149,6 +152,32 @@ getRepoR shar repo = do
             getGitRepoSource
                 repository shar repo (repoMainBranch repository) []
 
+deleteRepoR :: Text -> Text -> Handler Html
+deleteRepoR shar repo = do
+    runDB $ do
+        Entity sid _s <- getBy404 $ UniqueSharerIdent shar
+        Entity rid _r <- getBy404 $ UniqueRepo repo sid
+        delete rid
+    path <- askRepoDir shar repo
+    exists <- liftIO $ doesDirectoryExist path
+    if exists
+        then liftIO $ removeDirectoryRecursive path
+        else
+            $logWarn $ sformat
+                ( "Deleted repo " % stext % "/" % stext
+                % " from DB but repo dir doesn't exist"
+                )
+                shar repo
+    setMessage "Repo deleted."
+    redirect HomeR
+
+postRepoR :: Text -> Text -> Handler Html
+postRepoR shar repo = do
+    mmethod <- lookupPostParam "_method"
+    case mmethod of
+        Just "DELETE" -> deleteRepoR shar repo
+        _             -> notFound
+
 getRepoSourceR :: Text -> Text -> [Text] -> Handler Html
 getRepoSourceR shar repo refdir = do
     repository <- runDB $ selectRepo shar repo

templates/repo/source-darcs.hamlet

@@ -15,6 +15,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 $maybe desc <- repoDesc repository
   <p>#{desc}
 
+<p>
+  <form method=POST action=@{RepoR user repo}>
+    <input type=hidden name=_method value=DELETE>
+    <input type=submit value="Delete this repo">
+
 <p>
   <a href=@{RepoHeadChangesR user repo}>Changes
 

templates/repo/source-git.hamlet

@@ -15,6 +15,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 $maybe desc <- repoDesc repository
   <p>#{desc}
 
+<p>
+  <form method=POST action=@{RepoR user repo}>
+    <input type=hidden name=_method value=DELETE>
+    <input type=submit value="Delete this repo">
+
 <p>
   <a href=@{RepoHeadChangesR user repo}>Commits