diff --git a/src/Vervis/Field/Key.hs b/src/Vervis/Field/Key.hs index b265749..4d25872 100644 --- a/src/Vervis/Field/Key.hs +++ b/src/Vervis/Field/Key.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,25 +15,21 @@ module Vervis.Field.Key ( nameField - , algoField - , contentField + , sshKeyField ) 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.Error (lenientDecode) +import Data.Text.Encoding import Database.Esqueleto import Database.Persist (checkUnique) -import Yesod.Form.Fields (textField) -import Yesod.Form.Functions (check, checkBool, checkM, convertField) -import Yesod.Form.Types (Field) +import Yesod.Form 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 -mkBsField = convertField encodeUtf8 (decodeUtf8With lenientDecode) - -bsField :: Field Handler ByteString -bsField = mkBsField textField +sshKeyField :: Field Handler (ByteString, ByteString) +sshKeyField = checkMMap (pure . parseKey) renderKey textField + where + parseKey t = + 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 diff --git a/src/Vervis/Form/Key.hs b/src/Vervis/Form/Key.hs index 263ad69..ef0a28b 100644 --- a/src/Vervis/Form/Key.hs +++ b/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 algoField "Algorithm*" Nothing - <*> areq contentField "Content*" Nothing + <*> areq sshKeyField "Content*" (Just defKey) + where + mk n (a, c) = SshKey n pid a c + defKey = + ( "ssh-rsa" + , "VGhpcyBpcyBub3QgYSBrZXksIHBsZWFzZSBwYXN0ZSBhIHJlYWwgb25lIDopCg==" + ) newKeyForm :: PersonId -> Form SshKey newKeyForm = renderDivs . newKeyAForm