{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif

-- |
-- Module: Configuration.Utils.Validation
-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@alephcloud.com>
-- Stability: experimental
--
-- Utilities for validating configuration values
--
module Configuration.Utils.Validation
( ConfigValidation

-- * Networking
, validateHttpOrHttpsUrl
, validateHttpUrl
, validateHttpsUrl
, validateUri
, validateAbsoluteUri
, validateAbsoluteUriFragment
, validateIPv4
, validateIPv6
, validatePort

-- * Monoids, Foldables and Co
, validateNonEmpty
, validateLength
, validateMinLength
, validateMaxLength
, validateMinMaxLength

-- * Files
, validateFilePath
, validateFile
, validateFileReadable
, validateFileWritable
, validateExecutable
, validateDirectory
, validateConfigFile

-- * Boolean Values
, validateFalse
, validateTrue
, validateBool

-- * Numeric Values
, validateNonNegative
, validatePositive
, validateNonPositive
, validateNegative
, validateNonNull

-- * Orders
, validateLess
, validateLessEq
, validateGreater
, validateGreaterEq
, validateRange
) where

import Configuration.Utils.Internal

#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad.Error.Class
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Writer.Class

import qualified Data.Foldable as F
#if ! MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Monoid.Unicode
import qualified Data.Text as T

import Network.URI

import Prelude.Unicode

import System.Directory

-- | A validation function. The type in the 'MonadWriter' is excpected to
-- be a 'Foldable' structure for collecting warnings.
--
type ConfigValidation α λ =  μ . (MonadIO μ, Functor μ, Applicative μ, MonadError T.Text μ, MonadWriter (λ T.Text) μ)  α  μ ()

-- -------------------------------------------------------------------------- --
-- Networking

-- | Validates that a value is an HTTP or HTTPS URL
--
validateHttpOrHttpsUrl
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateHttpOrHttpsUrl configName uri =
    case parseURI uri of
        Nothing  throwError $
            "the value "  T.pack uri  " for "  configName  " is not a valid URI"
        Just u  unless (uriScheme u  "http:" || uriScheme u  "https:")  throwError $
            "the value "  T.pack uri  " for "  configName  " is not an HTTP or HTTPS URL"

-- | Validates that a value is an HTTP URL
--
validateHttpUrl
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateHttpUrl configName uri =
    case parseURI uri of
        Nothing  throwError $
            "the value "  T.pack uri  " for "  configName  " is not a valid URI"
        Just u  unless (uriScheme u  "http:")  throwError $
            "the value "  T.pack uri  " for "  configName  " is not an HTTP URL"

-- | Validates that a value is an HTTPS URL
--
validateHttpsUrl
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateHttpsUrl configName uri =
    case parseURI uri of
        Nothing  throwError $
            "the value "  T.pack uri  " for "  configName  " is not a valid URI"
        Just u  unless (uriScheme u  "https:")  throwError $
            "the value "  T.pack uri  " for "  configName  " is not an HTTPS URL"

-- | Validates that a value is an URI without a fragment identifier
--
validateUri
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateUri configName uri =
    unless (isURIReference uri)  throwError $
        "The value "  T.pack uri  " for "  configName  " is not a valid URI"

-- | Validates that a value is an absolute URI without a fragment identifier
--
validateAbsoluteUri
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateAbsoluteUri configName uri =
    unless (isAbsoluteURI uri)  throwError $
        "The value "  T.pack uri  " for "  configName  " is not a valid URI"

-- | Validates that a value is an absolute URI with an optional fragment
-- identifier
--
validateAbsoluteUriFragment
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateAbsoluteUriFragment configName uri =
    unless (isURI uri)  throwError $
        "The value "  T.pack uri  " for "  configName  " is not a valid URI"

validateIPv4
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateIPv4 configName ipv4 =
    unless (isIPv4address ipv4)  throwError $
        "The value "  T.pack ipv4  " for "  configName  " is not a valid IPv4 address"

validateIPv6
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     String
     m ()
validateIPv6 configName ipv6 =
    unless (isIPv6address ipv6)  throwError $
        "The value "  T.pack ipv6  " for "  configName  " is not a valid IPv6 address"

validatePort
     (MonadError T.Text m, Integral n, Show n)
     T.Text
        -- ^ configuration property name that is used in the error message
     n
     m ()
validatePort configName p =
    unless (p > 1 && p < 65535)  throwError $
        "port value "  T.pack (show p)  " for "  configName  " is not valid port number"

-- -------------------------------------------------------------------------- --
-- Monoids, Foldables, and Co

validateNonEmpty
     (MonadError T.Text m, Eq α, Monoid α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validateNonEmpty configName x =
    when (x  mempty)  throwError $
        "value for "  configName  " must not be empty"

validateLength
     (MonadError T.Text m, F.Foldable φ)
     T.Text
        -- ^ configuration property name that is used in the error message
     Int
        -- ^ exact length of the validated value
     φ α
     m ()
validateLength configName len x =
    unless (length (F.toList x)  len)  throwError $
        "value for "  configName  " must be of length exactly "  sshow len

validateMaxLength
     (MonadError T.Text m, F.Foldable φ)
     T.Text
        -- ^ configuration property name that is used in the error message
     Int
        -- ^ maximum length of the validated value
     φ α
     m ()
validateMaxLength configName u x =
    unless (length (F.toList x)  u)  throwError $
        "value for "  configName  " must be of length at most "  sshow u

validateMinLength
     (MonadError T.Text m, F.Foldable φ)
     T.Text
        -- ^ configuration property name that is used in the error message
     Int
        -- ^ minimum length of the validated value
     φ α
     m ()
validateMinLength configName l x =
    unless (length (F.toList x)  l)  throwError $
        "value for "  configName  " must be of length at least "  sshow l

validateMinMaxLength
     (MonadError T.Text m, F.Foldable φ)
     T.Text
        -- ^ configuration property name that is used in the error message
     Int
        -- ^ minimum length of the validated value
     Int
        -- ^ maximum length of the validated value
     φ α
     m ()
validateMinMaxLength configName l u x =
    unless (len  l && len  u)  throwError $
        "the length of the value for "  configName 
        " must be at least "  sshow l  " and at most "  sshow u
  where
    len = length $ F.toList x

-- -------------------------------------------------------------------------- --
-- Files

validateFilePath
     MonadError T.Text m
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateFilePath configName file =
    when (null file)  throwError $
        "file path for "  configName  " must not be empty"

validateFile
     (MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateFile configName file = do
    exists  liftIO $ doesFileExist file
    unless exists  throwError $
        "the file "  T.pack file  " for "  configName  " does not exist"

validateFileReadable
     (MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateFileReadable configName file = do
    validateFile configName file
    liftIO (getPermissions file) >>= \x  unless (readable x)  throwError $
        "the file "  T.pack file  " for "  configName  " is not readable"

validateFileWritable
     (MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateFileWritable configName file = do
    validateFile configName file
    liftIO (getPermissions file) >>= \x  unless (writable x)  throwError $
        "the file "  T.pack file  " for "  configName  " is not writable"

validateFileExecutable
     (MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateFileExecutable configName file = do
    validateFile configName file
    liftIO (getPermissions file) >>= \x  unless (executable x)  throwError $
        "the file "  T.pack file  " for "  configName  " is not excutable"

validateDirectory
     (MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateDirectory configName dir = do
    exists  liftIO $ doesDirectoryExist dir
    unless exists  throwError $
        "the directory "  T.pack dir  " for "  configName  " does not exist"

-- | Validates if the given executable name can be found in the system
-- and can be executed.
--
validateExecutable
     (Functor m, MonadError T.Text m, MonadIO m)
     T.Text
        -- ^ configuration property name that is used in the error message
     FilePath
     m ()
validateExecutable configName file = do
    execFile  (file <$ validateFile configName file) `catchError` \_ ->
        liftIO (findExecutable file) >>= \case
            Nothing  throwError $
                "the executable "  T.pack file  " for "  configName  " could not be found in the system;"
                 " you may check your SearchPath and PATH variable settings"
            Just f  return f
    validateFileExecutable configName execFile

-- | Validate that the input is a config file
--
validateConfigFile
     (MonadIO m, MonadError T.Text m)
     String
     m ()
validateConfigFile filepath =
    validateFileReadable "config-file" filepath
#ifdef REMOTE_CONFIGS
    `catchError` \_ ->
    validateHttpOrHttpsUrl "config-file" filepath
#endif

-- -------------------------------------------------------------------------- --
-- Boolean Values

validateFalse
     (MonadError T.Text m)
     T.Text
        -- ^ configuration property name that is used in the error message
     Bool
     m ()
validateFalse configName = validateBool configName False

validateTrue
     (MonadError T.Text m)
     T.Text
        -- ^ configuration property name that is used in the error message
     Bool
     m ()
validateTrue configName = validateBool configName True

validateBool
     (MonadError T.Text m)
     T.Text
        -- ^ configuration property name that is used in the error message
     Bool
        -- ^ expected value
     Bool
     m ()
validateBool configName expected x = unless (x  expected)  throwError $
    "expected "  configName  " to be "  sshow expected  ", but was "  sshow x

-- -------------------------------------------------------------------------- --
-- Numeric Values

validateNonNegative
     (MonadError T.Text m, Ord α, Num α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validateNonNegative configName x =
    when (x < 0)  throwError $
        "value for "  configName  " must not be negative"

validatePositive
     (MonadError T.Text m, Ord α, Num α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validatePositive configName x =
    when (x  0)  throwError $
        "value for "  configName  " must be positive"

validateNonPositive
     (MonadError T.Text m, Ord α, Num α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validateNonPositive configName x =
    when (x > 0)  throwError $
        "value for "  configName  " must not be positive"

validateNegative
     (MonadError T.Text m, Ord α, Num α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validateNegative configName x =
    when (x  0)  throwError $
        "value for "  configName  " must be negative"

validateNonNull
     (MonadError T.Text m, Eq α, Num α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
     m ()
validateNonNull configName x = when (x  0)  throwError $
    "value for "  configName  " must not be zero"

-- -------------------------------------------------------------------------- --
-- Orders

validateLess
     (MonadError T.Text m, Ord α, Show α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
        -- ^ a strict upper bound for the configuration value
     α
     m ()
validateLess configName upper x = unless (x < upper)  throwError $
    "value for "  configName  " must be strictly less than "  sshow upper  ", but was "  sshow x

validateLessEq
     (MonadError T.Text m, Ord α, Show α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
        -- ^ a upper bound for the configuration value
     α
     m ()
validateLessEq configName upper x = unless (x  upper)  throwError $
    "value for "  configName  " must be less or equal than "  sshow upper  ", but was "  sshow x

validateGreater
     (MonadError T.Text m, Ord α, Show α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
        -- ^ a strict lower bound for the configuration value
     α
     m ()
validateGreater configName lower x = unless (x > lower)  throwError $
    "value for "  configName  " must be strictly greater than "  sshow lower  ", but was "  sshow x

validateGreaterEq
     (MonadError T.Text m, Ord α, Show α)
     T.Text
        -- ^ configuration property name that is used in the error message
     α
        -- ^ a lower bound for the configuration value
     α
     m ()
validateGreaterEq configName lower x = unless (x  lower)  throwError $
    "value for "  configName  " must be greater or equal than "  sshow lower  ", but was "  sshow x

validateRange
     (MonadError T.Text m, Ord α, Show α)
     T.Text
        -- ^ configuration property name that is used in the error message
     (α, α)
        -- ^ the valid range for the configuration value
     α
     m ()
validateRange configName (lower,upper) x = unless (x  lower  x  upper)  throwError $
    "value for "  configName  " must be within the range of ("  sshow lower  ", "  sshow upper  "), but was "  sshow x