Validators.hs

{-# LANGUAGE OverloadedStrings #-}

module Festung.Frontend.Validators
  ( validateVaultName
  ) where

import qualified Data.Text   as Text
import           Data.Char   (isPrint, isAscii)
import           Text.Printf (printf)


type ErrorMessage = Text.Text


validateVaultName :: Text.Text -> Maybe ErrorMessage
validateVaultName vaultName =
    -- XXX(Antoine): I'm not sure whether this should be read from the config
    --               or not. Anyhow, I want to avoid values that could reach the
    --               limits the file system (in this case the Maximum filename length)
    --               <https://en.wikipedia.org/wiki/Comparison_of_file_systems#Limits>
    --               This is only intented to support ext4, btrfs, zfs and ReiserFS.
    let maxVaultNameLength = 128
        hasChar c = Text.any (== c) vaultName
        maybeHead l =
            if null l then Nothing
            else Just (head l)

        -- We don't accept slashes and dots for obvious security reasons (we
        -- don't want people to be able to traverse directories.)
        hasSlash = hasChar '/'
        hasDot = hasChar '.'

        -- This might just be cargocult, we just don't want people to use weird
        -- characters for their vault names.
        isAllAscii = Text.all isAscii vaultName
        isAllPrintable = Text.all isPrint vaultName

        isTooLong = maxVaultNameLength < Text.length vaultName

    in
    -- XXX(Antoine): This is unreadable
    fmap (Text.pack . snd) $ maybeHead $ filter fst
        [ (hasSlash, "Vault names can't contain slashes")
        , (hasDot, "Vault names can't contain dots")
        , (not isAllAscii, "Vault names have to be ascii characters")
        , (not isAllPrintable, "Vault names have to have printable names")
        , (isTooLong, printf "We do not accept vault names longer than %d characters" maxVaultNameLength)
        ]