SSH key deletion button

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