Add SSH key upload form

This commit is contained in:
fr33domlover 2016-03-08 02:52:46 +00:00
parent df55bf23c9
commit 4a6853e7e7
6 changed files with 173 additions and 4 deletions

86
src/Vervis/Field/Key.hs Normal file
View file

@ -0,0 +1,86 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- 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/>.
-}
module Vervis.Field.Key
( nameField
, algoField
, contentField
)
where
import Prelude
import Data.ByteString (ByteString)
import Data.Char (isDigit)
import Data.Maybe (isNothing)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Database.Persist (checkUnique)
import Yesod.Form.Fields (textField)
import Yesod.Form.Functions (checkBool, checkM, convertField)
import Yesod.Form.Types (Field)
import Yesod.Persist.Core (runDB)
import qualified Data.Text as T
import Data.Char.Local (isAsciiLetter)
import Network.SSH.Local (supportedKeyAlgos)
import Vervis.Foundation
import Vervis.Model
mkBsField :: Field Handler Text -> Field Handler ByteString
mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode)
bsField :: Field Handler ByteString
bsField = mkBsField textField
checkNameUnique :: PersonId -> Field Handler Text -> Field Handler Text
checkNameUnique pid = checkM $ \ name -> runDB $ do
let key = SshKey
{ sshKeyPerson = pid
, sshKeyName = name
, sshKeyAlgo = mempty
, sshKeyContent = mempty
}
muk <- checkUnique key
return $ if isNothing muk
then Right name
else Left ("You already have a key with this label" :: Text)
nameField :: PersonId -> Field Handler Text
nameField pid = checkNameUnique pid textField
checkAlgoSupported :: Field Handler ByteString -> Field Handler ByteString
checkAlgoSupported =
let ok = (`elem` supportedKeyAlgos)
msg :: Text
msg = "This algorithm isn't supported"
in checkBool ok msg
algoField :: Field Handler ByteString
algoField = checkAlgoSupported bsField
checkContent :: Field Handler Text -> Field Handler Text
checkContent =
let lasts = (== '=')
rest c = isAsciiLetter c || isDigit c || c == '+' || c == '/'
ok t = T.all rest $ T.dropWhileEnd lasts t
msg :: Text
msg = "Must be a base64-encoded public SSH key"
in checkBool ok msg
contentField :: Field Handler ByteString
contentField = mkBsField $ checkContent textField

33
src/Vervis/Form/Key.hs Normal file
View file

@ -0,0 +1,33 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- 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/>.
-}
module Vervis.Form.Key
( newKeyForm
)
where
import Vervis.Import
import Vervis.Field.Key
newKeyAForm :: PersonId -> AForm Handler SshKey
newKeyAForm pid = SshKey
<$> pure pid
<*> areq (nameField pid) "Name*" Nothing
<*> areq algoField "Algorithm*" Nothing
<*> areq contentField "Content*" Nothing
newKeyForm :: PersonId -> Form SshKey
newKeyForm = renderDivs . newKeyAForm

View file

@ -24,15 +24,20 @@ where
import Prelude import Prelude
import Data.ByteString.Base64 (encode) import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>))
import Data.Text (Text, intercalate) import Data.Text (Text, intercalate)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Database.Persist import Database.Persist
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Yesod.Core (defaultLayout) import Yesod.Core (defaultLayout)
import Yesod.Core.Handler (setMessage, redirectUltDest)
import Yesod.Core.Widget (setTitle) import Yesod.Core.Widget (setTitle)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404) import Yesod.Persist.Core (runDB, getBy404)
import Vervis.Form.Key
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Settings import Vervis.Settings
@ -50,10 +55,34 @@ getKeysR user = do
$(widgetFile "keys") $(widgetFile "keys")
postKeysR :: Text -> Handler Html postKeysR :: Text -> Handler Html
postKeysR _ = error "not impl" postKeysR user = do
pid <- runDB $ do
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
Entity p _person <- getBy404 $ UniquePersonIdent s
return p
((result, widget), enctype) <- runFormPost $ newKeyForm pid
case result of
FormSuccess key -> do
runDB $ insert_ key
setMessage "Key added."
redirectUltDest HomeR
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "key-new")
FormFailure _l -> do
setMessage "Invalid input, see below"
defaultLayout $(widgetFile "key-new")
getKeyNewR :: Text -> Handler Html getKeyNewR :: Text -> Handler Html
getKeyNewR _ = error "not impl" getKeyNewR user = do
pid <- runDB $ do
Entity s _sharer <- getBy404 $ UniqueSharerIdent user
Entity p _person <- getBy404 $ UniquePersonIdent s
return p
((_result, widget), enctype) <- runFormPost $ newKeyForm pid
defaultLayout $ do
setTitle $ toHtml $ "Vervis > People > " <> user <> " > New Key"
$(widgetFile "key-new")
getKeyR :: Text -> Text -> Handler Html getKeyR :: Text -> Text -> Handler Html
getKeyR user tag = do getKeyR user tag = do

View file

@ -51,8 +51,6 @@ postProjectsR ident = do
FormSuccess project -> do FormSuccess project -> do
runDB $ insert_ project runDB $ insert_ project
setMessage "Project added." setMessage "Project added."
--redirect $ ProjectsR ident
--redirect HomeR
redirectUltDest HomeR redirectUltDest HomeR
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"

21
templates/key-new.hamlet Normal file
View file

@ -0,0 +1,21 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# 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/>.
<h1>Vervis > People > #{user} > New Key
Enter the details and click "Submit" to add a new SSH key.
<form method=POST action=@{KeysR user} enctype=#{enctype}>
^{widget}
<input type=submit>

View file

@ -41,9 +41,11 @@ library
Data.List.Local Data.List.Local
Network.SSH.Local Network.SSH.Local
Vervis.Application Vervis.Application
Vervis.Field.Key
Vervis.Field.Person Vervis.Field.Person
Vervis.Field.Project Vervis.Field.Project
Vervis.Field.Repo Vervis.Field.Repo
Vervis.Form.Key
Vervis.Form.Person Vervis.Form.Person
Vervis.Form.Project Vervis.Form.Project
Vervis.Form.Repo Vervis.Form.Repo