UI: Tweak and re-enable UI for uploading personal SSH keys
This commit is contained in:
parent
206d140b95
commit
cc9facdf5a
7 changed files with 51 additions and 70 deletions
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
key <- runFormPostRedirect KeysR $ newKeyForm pid
|
||||
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
|
||||
postKeyDeleteR :: KeyHashid SshKey -> Handler Html
|
||||
postKeyDeleteR keyHash = do
|
||||
pid <- requireAuthId
|
||||
keyID <- decodeKeyHashid404 keyHash
|
||||
runDB $ do
|
||||
Entity kid _k <- getBy404 $ UniqueSshKey pid tag
|
||||
delete kid
|
||||
key <- get404 keyID
|
||||
unless (sshKeyPerson key == pid) notFound
|
||||
delete keyID
|
||||
setMessage "Key deleted."
|
||||
redirect KeysR
|
||||
|
||||
postKeyR :: KyIdent -> Handler Html
|
||||
postKeyR tag = do
|
||||
mmethod <- lookupPostParam "_method"
|
||||
case mmethod of
|
||||
Just "DELETE" -> deleteKeyR tag
|
||||
_ -> notFound
|
||||
-}
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue