vervis/src/Vervis/Field/Key.hs

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