From cc9facdf5a174aae9414c450e29c7b82a17837ac Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 26 Sep 2022 12:51:06 +0000 Subject: [PATCH] UI: Tweak and re-enable UI for uploading personal SSH keys --- src/Vervis/Application.hs | 2 +- src/Vervis/Foundation.hs | 3 ++ src/Vervis/Handler/Key.hs | 82 ++++++++++++++------------------------- templates/key/list.hamlet | 15 ++++--- templates/key/one.hamlet | 6 ++- th/routes | 7 ++-- vervis.cabal | 6 +-- 7 files changed, 51 insertions(+), 70 deletions(-) diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 1372d57..7c9cba4 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 1e56fe7..2d2d18a 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Key.hs b/src/Vervis/Handler/Key.hs index 47badc1..af23167 100644 --- a/src/Vervis/Handler/Key.hs +++ b/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 diff --git a/templates/key/list.hamlet b/templates/key/list.hamlet index 35db52f..a5dd40a 100644 --- a/templates/key/list.hamlet +++ b/templates/key/list.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2022 by fr33domlover . $# $# ♡ 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 $# . -

These are your SSH keys. +

Your SSH keys -