UI: Tweak and re-enable UI for uploading personal SSH keys

src/Vervis/Application.hs

@@ -109,7 +109,7 @@ import Vervis.Handler.Cloth
 import Vervis.Handler.Deck
 --import Vervis.Handler.Git
 import Vervis.Handler.Group
---import Vervis.Handler.Key
+import Vervis.Handler.Key
 import Vervis.Handler.Loom
 import Vervis.Handler.Person
 import Vervis.Handler.Repo

src/Vervis/Foundation.hs

@@ -807,6 +807,9 @@ instance YesodBreadcrumbs App where
         NotificationsR -> ("Notifications", Just HomeR)
         InboxDebugR    -> ("Inbox Debug", Just HomeR)
 
+        KeysR        -> ("SSH Keys", Just HomeR)
+        KeyDeleteR _ -> ("", Nothing)
+
         PublishOfferMergeR -> ("Open MR", Just HomeR)
         PublishMergeR      -> ("Apply MR", Just HomeR)
 

src/Vervis/Handler/Key.hs

@@ -16,10 +16,7 @@
 module Vervis.Handler.Key
     ( getKeysR
     , postKeysR
-    , getKeyNewR
-    , getKeyR
-    , deleteKeyR
-    , postKeyR
+    , postKeyDeleteR
     )
 where
 
@@ -29,8 +26,9 @@ import Data.Monoid ((<>))
 import Data.Text (Text, intercalate)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
+import Data.Traversable
 import Database.Persist
-import Network.HTTP.Types (StdMethod (DELETE))
+import Network.HTTP.Types.Method
 import Text.Blaze.Html (Html, toHtml)
 import Yesod.Auth (requireAuthId)
 import Yesod.Core
@@ -45,6 +43,7 @@ import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 
+import Yesod.Form.Local
 import Yesod.Persist.Local
 
 import Vervis.Form.Key
@@ -54,60 +53,39 @@ import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Widget (buttonW)
 
-{-
 getKeysR :: Handler Html
 getKeysR = do
     pid <- requireAuthId
-    keys <- runDB $ do
-        ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyIdent]
-        return $ map (\ (Entity _ k) -> sshKeyIdent k) ks
+    newW <- do
+        ((_, widget), enctype) <- runFormPost $ newKeyForm pid
+        return $(widgetFile "key/new")
+    keysW <- mconcat <$> do
+        keys <- runDB $ selectList [SshKeyPerson ==. pid] [Asc SshKeyIdent]
+        for keys $ \ (Entity keyID key) -> do
+            keyHash <- encodeKeyHashid keyID
+            return $ keyW keyHash key
     defaultLayout $(widgetFile "key/list")
+    where
+    keyW tag key =
+        let toText = decodeUtf8With lenientDecode
+            content = toText $ encode $ sshKeyContent key
+        in  $(widgetFile "key/one")
 
 postKeysR :: Handler Html
 postKeysR = do
     pid <- requireAuthId
-    ((result, widget), enctype) <- runFormPost $ newKeyForm pid
-    case result of
-        FormSuccess key -> do
-            runDB $ insert_ key
-            setMessage "Key added."
-            redirect KeysR
-        FormMissing -> do
-            setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "key/new")
-        FormFailure _l -> do
-            setMessage "Invalid input, see below"
-            defaultLayout $(widgetFile "key/new")
-
-getKeyNewR :: Handler Html
-getKeyNewR = do
-    pid <- requireAuthId
-    ((_result, widget), enctype) <- runFormPost $ newKeyForm pid
-    defaultLayout $(widgetFile "key/new")
-
-getKeyR :: KyIdent -> Handler Html
-getKeyR tag = do
-    pid <- requireAuthId
-    Entity _kid key <- runDB $ getBy404 $ UniqueSshKey pid tag
-    let toText = decodeUtf8With lenientDecode
-        content = toText $ encode $ sshKeyContent key
-    defaultLayout $(widgetFile "key/one")
--}
-
-{-
-deleteKeyR :: KyIdent -> Handler Html
-deleteKeyR tag = do
-    pid <- requireAuthId
-    runDB $ do
-        Entity kid _k <- getBy404 $ UniqueSshKey pid tag
-        delete kid
-    setMessage "Key deleted."
+    key <- runFormPostRedirect KeysR $ newKeyForm pid
+    runDB $ insert_ key
+    setMessage "Key added."
     redirect KeysR
 
-postKeyR :: KyIdent -> Handler Html
-postKeyR tag = do
-    mmethod <- lookupPostParam "_method"
-    case mmethod of
-        Just "DELETE" -> deleteKeyR tag
-        _             -> notFound
--}
+postKeyDeleteR :: KeyHashid SshKey -> Handler Html
+postKeyDeleteR keyHash = do
+    pid <- requireAuthId
+    keyID <- decodeKeyHashid404 keyHash
+    runDB $ do
+        key <- get404 keyID
+        unless (sshKeyPerson key == pid) notFound
+        delete keyID
+    setMessage "Key deleted."
+    redirect KeysR

templates/key/list.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,11 +12,10 @@ $# 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>These are your SSH keys.
+<h2>Your SSH keys
 
-<ul>
-  $forall key <- keys
-    <li>
-      <a href=@{KeyR key}>#{ky2text key}
-  <li>
-    <a href=@{KeyNewR}>Add new…
+^{keysW}
+
+<h2>Add a new SSH key
+
+^{newW}

templates/key/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018, 2022 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,8 +12,10 @@ $# 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/>.
 
+<h2>SSH Key #{ky2text $ sshKeyIdent key}
+
 <p>
-  ^{buttonW DELETE "Delete this key" (KeyR tag)}
+  ^{buttonW POST "Delete this key" (KeyDeleteR tag)}
 
 <table>
   <tr>

th/routes

@@ -33,10 +33,6 @@
 -- Current user
 -- ----------------------------------------------------------------------------
 
--- /k                                           KeysR                GET POST
--- /k/!new                                      KeyNewR              GET
--- /k/#KyIdent                                  KeyR                 GET DELETE POST
-
 -- /cr                                          ClaimRequestsPersonR GET
 
 -- ----------------------------------------------------------------------------
@@ -130,6 +126,9 @@
 -- /publish       PublishR       GET POST
 /inbox         InboxDebugR    GET
 
+/ssh-keys                         KeysR      GET POST
+/ssh-keys/#SshKeyKeyHashid/delete KeyDeleteR POST
+
 /publish/offer-merge PublishOfferMergeR GET POST
 /publish/merge       PublishMergeR      GET POST
 

vervis.cabal

@@ -156,7 +156,7 @@ library
                        Vervis.Federation.Util
                        Vervis.FedURI
                        Vervis.Fetch
-                       -- Vervis.Field.Key
+                       Vervis.Field.Key
                        Vervis.Field.Person
                        --Vervis.Field.Project
                        --Vervis.Field.Repo
@@ -166,7 +166,7 @@ library
                        -- Vervis.Field.Workflow
                        Vervis.Form.Discussion
                        --Vervis.Form.Group
-                       -- Vervis.Form.Key
+                       Vervis.Form.Key
                        Vervis.Form.Project
                        Vervis.Form.Repo
                        --Vervis.Form.Role
@@ -183,7 +183,7 @@ library
                        -- Vervis.Handler.Git
                        Vervis.Handler.Group
                        --Vervis.Handler.Inbox
-                       --Vervis.Handler.Key
+                       Vervis.Handler.Key
                        Vervis.Handler.Loom
                        Vervis.Handler.Person
                        Vervis.Handler.Repo