SSH key deletion button

README.md

@@ -63,7 +63,7 @@ an overview of more-or-less what's left to do before the first release.
         [/] Web
         [ ] SSH
       [ ] Delete repo
-        [ ] Web
+        [/] Web
         [ ] SSH
       [/] Clone
         [/] HTTP
@@ -82,7 +82,7 @@ an overview of more-or-less what's left to do before the first release.
         [/] Web
         [ ] SSH
       [ ] Delete repo
-        [ ] Web
+        [/] Web
         [ ] SSH
       [ ] Clone
         [ ] HTTP

config/routes

@@ -38,7 +38,7 @@
 
 /u/#Text/k                              KeysR             GET POST
 /u/#Text/k/!new                         KeyNewR           GET
-/u/#Text/k/#Text                        KeyR              GET
+/u/#Text/k/#Text                        KeyR              GET DELETE POST
 
 /u/#Text/r                              ReposR            GET POST
 /u/#Text/r/!new                         RepoNewR          GET

src/Vervis/Handler/Key.hs

@@ -18,6 +18,8 @@ module Vervis.Handler.Key
     , postKeysR
     , getKeyNewR
     , getKeyR
+    , deleteKeyR
+    , postKeyR
     )
 where
 
@@ -31,7 +33,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 import Database.Persist
 import Text.Blaze.Html (Html, toHtml)
 import Yesod.Core (defaultLayout)
-import Yesod.Core.Handler (setMessage, redirectUltDest)
+import Yesod.Core.Handler
 import Yesod.Core.Widget (setTitle)
 import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
@@ -65,7 +67,7 @@ postKeysR user = do
         FormSuccess key -> do
             runDB $ insert_ key
             setMessage "Key added."
-            redirectUltDest HomeR
+            redirect $ KeysR user
         FormMissing -> do
             setMessage "Field(s) missing"
             defaultLayout $(widgetFile "key/key-new")
@@ -96,3 +98,20 @@ getKeyR user tag = do
         setTitle $ toHtml $
             intercalate " > " ["Vervis", "People", user, "Keys", tag]
         $(widgetFile "key/key")
+
+deleteKeyR :: Text -> Text -> Handler Html
+deleteKeyR user tag = do
+    runDB $ do
+        Entity sid _s <- getBy404 $ UniqueSharerIdent user
+        Entity pid _p <- getBy404 $ UniquePersonIdent sid
+        Entity kid _k <- getBy404 $ UniqueSshKey pid tag
+        delete kid
+    setMessage "Key deleted."
+    redirect $ KeysR user
+
+postKeyR :: Text -> Text -> Handler Html
+postKeyR user tag = do
+    mmethod <- lookupPostParam "_method"
+    case mmethod of
+        Just "DELETE" -> deleteKeyR user tag
+        _             -> notFound

templates/key/key.hamlet

@@ -12,6 +12,11 @@ $# 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/>.
 
+<p>
+  <form method=POST action=@{KeyR user tag}>
+    <input type=hidden name=_method value=DELETE>
+    <input type=submit value="Delete this key">
+
 <table>
   <tr>
     <td>Algorithm