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

This commit is contained in:
fr33domlover 2022-09-26 12:51:06 +00:00
parent 206d140b95
commit cc9facdf5a
7 changed files with 51 additions and 70 deletions

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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}

View file

@ -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>

View file

@ -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

View file

@ -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