mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-09 15:06:46 +09:00
94 lines
2.9 KiB
Haskell
94 lines
2.9 KiB
Haskell
{- 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.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 Database.Persist (checkUnique)
|
|
import Yesod.Form.Fields (textField)
|
|
import Yesod.Form.Functions (check, checkBool, checkM, convertField)
|
|
import Yesod.Form.Types (Field)
|
|
import Yesod.Persist.Core (runDB)
|
|
|
|
import qualified Data.ByteString.Char8 as BC
|
|
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 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
|
|
|
|
--TODO make the above work over ByteString and when passes the check, apply
|
|
--base64 conversion. delete my rel4 key from the DB and re-insert...
|
|
|
|
contentField :: Field Handler ByteString
|
|
contentField = checkContent bsField
|