Add SSH key upload form

src/Vervis/Field/Key.hs

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

src/Vervis/Form/Key.hs

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

src/Vervis/Handler/Key.hs

@@ -24,15 +24,20 @@ where
 import Prelude
 
 import Data.ByteString.Base64 (encode)
+import Data.Monoid ((<>))
 import Data.Text (Text, intercalate)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import Database.Persist
 import Text.Blaze.Html (Html, toHtml)
 import Yesod.Core (defaultLayout)
+import Yesod.Core.Handler (setMessage, redirectUltDest)
 import Yesod.Core.Widget (setTitle)
+import Yesod.Form.Functions (runFormPost)
+import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, getBy404)
 
+import Vervis.Form.Key
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Settings
@@ -50,10 +55,34 @@ getKeysR user = do
         $(widgetFile "keys")
 
 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 _ = 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 user tag = do

src/Vervis/Handler/Project.hs

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

templates/key-new.hamlet

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

vervis.cabal

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