UI: Take SSH public key in 1 field, then split into key type and content

src/Vervis/Field/Key.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,25 +15,21 @@
 
 module Vervis.Field.Key
     ( nameField
-    , algoField
+    , sshKeyField
-    , contentField
     )
 where
 
 import Data.ByteString (ByteString)
-import Data.ByteString.Base64 (decode)
 import Data.Char (isDigit)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding
-import Data.Text.Encoding.Error (lenientDecode)
 import Database.Esqueleto
 import Database.Persist (checkUnique)
-import Yesod.Form.Fields (textField)
+import Yesod.Form
-import Yesod.Form.Functions (check, checkBool, checkM, convertField)
-import Yesod.Form.Types (Field)
 import Yesod.Persist.Core (runDB)
 
+import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.Text as T
 
@@ -43,11 +39,26 @@ import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident (text2ky)
 
-mkBsField :: Field Handler Text -> Field Handler ByteString
+sshKeyField :: Field Handler (ByteString, ByteString)
-mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode)
+sshKeyField = checkMMap (pure . parseKey) renderKey textField
-
+    where
-bsField :: Field Handler ByteString
+    parseKey t =
-bsField = mkBsField textField
+        case T.words t of
+            a:c:_ ->
+                (,) <$> parseAlgo a
+                    <*> parseContent c
+            _ -> Left "Key type or content is missing"
+        where
+        parseAlgo t =
+            let b = encodeUtf8 t
+            in  if b `elem` supportedKeyAlgos
+                    then Right b
+                    else Left $ "Key type not supported: " <> t
+        parseContent t =
+            case B64.decode $ encodeUtf8 t of
+                Left s -> Left $ T.pack s
+                Right b -> Right b
+    renderKey (a, c) = T.concat [decodeUtf8 a, " ", decodeUtf8 c]
 
 checkNameUnique :: PersonId -> Field Handler Text -> Field Handler Text
 checkNameUnique pid = checkM $ \ ident -> do
@@ -64,28 +75,3 @@ checkNameUnique pid = checkM $ \ ident -> do
 
 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 ByteString -> Field Handler ByteString
-checkContent =
-    {-let lasts = (== '=')
-        rest c = isAsciiLetter c || isDigit c || c == '+' || c == '/'
-        ok b = BC.all rest $ BC.dropWhileEnd lasts b
-        msg :: Text
-        msg = "Must be a base64-encoded public SSH key"-}
-    check $ \ t ->
-        case decode t of
-            Left s  -> Left $ T.pack s
-            Right b -> Right b
-
-contentField :: Field Handler ByteString
-contentField = checkContent bsField

src/Vervis/Form/Key.hs

@@ -28,11 +28,15 @@ import Vervis.Model
 import Vervis.Model.Ident
 
 newKeyAForm :: PersonId -> AForm Handler SshKey
-newKeyAForm pid = SshKey
+newKeyAForm pid = mk
     <$> (text2ky <$> areq (nameField pid) "Name*"      Nothing)
-    <*> pure pid
+    <*> areq              sshKeyField     "Content*"   (Just defKey)
-    <*> areq algoField       "Algorithm*" Nothing
+    where
-    <*> areq contentField    "Content*"   Nothing
+    mk n (a, c) = SshKey n pid a c
+    defKey =
+        ( "ssh-rsa"
+        , "VGhpcyBpcyBub3QgYSBrZXksIHBsZWFzZSBwYXN0ZSBhIHJlYWwgb25lIDopCg=="
+        )
 
 newKeyForm :: PersonId -> Form SshKey
 newKeyForm = renderDivs . newKeyAForm