diff --git a/src/Vervis/Field/Key.hs b/src/Vervis/Field/Key.hs new file mode 100644 index 0000000..23a922b --- /dev/null +++ b/src/Vervis/Field/Key.hs @@ -0,0 +1,86 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Form/Key.hs b/src/Vervis/Form/Key.hs new file mode 100644 index 0000000..46fbf18 --- /dev/null +++ b/src/Vervis/Form/Key.hs @@ -0,0 +1,33 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Handler/Key.hs b/src/Vervis/Handler/Key.hs index 0723cab..45d0a20 100644 --- a/src/Vervis/Handler/Key.hs +++ b/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 diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 6a99990..b311edb 100644 --- a/src/Vervis/Handler/Project.hs +++ b/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" diff --git a/templates/key-new.hamlet b/templates/key-new.hamlet new file mode 100644 index 0000000..1d2cfe0 --- /dev/null +++ b/templates/key-new.hamlet @@ -0,0 +1,21 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + +

Vervis > People > #{user} > New Key + +Enter the details and click "Submit" to add a new SSH key. + +
+ ^{widget} + diff --git a/vervis.cabal b/vervis.cabal index 2a7042a..076169d 100644 --- a/vervis.cabal +++ b/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