{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: Configuration.Utils.Internal.ConfigFileReader
-- Description: Internal Tools for Parsing Configuration Files
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
module Configuration.Utils.Internal.ConfigFileReader
(
  parseConfigFiles
, readConfigFile
, ConfigFileFormat(..)

-- * Local Config Files
, loadLocal

#ifdef REMOTE_CONFIGS
-- * Remote Config Files
, isRemote
, loadRemote
, yamlMimeType
, jsonMimeType
, contentType
, requestHeaders
#endif
) where

import Configuration.Utils.ConfigFile
import Configuration.Utils.Internal
import Configuration.Utils.Validation

import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Monad.Except hiding (mapM_)

import qualified Data.ByteString.Char8 as B8
import qualified Data.CaseInsensitive as CI
import Data.Monoid.Unicode
import qualified Data.Text as T
import Data.Typeable
import qualified Data.Yaml as Yaml

import GHC.Generics

import Prelude hiding (concatMap, mapM_, any)
import Prelude.Unicode

#ifdef REMOTE_CONFIGS
import Configuration.Utils.Internal.HttpsCertPolicy

import Control.Exception.Enclosed
import Control.Monad.Trans.Control

import qualified Data.ByteString.Lazy as LB
import qualified Data.List as L
import Data.String
import qualified Data.Text.IO as T

import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types.Header as HTTP

import System.IO
#endif

-- -------------------------------------------------------------------------- --
-- Tools for parsing configuration files

#ifdef REMOTE_CONFIGS
type ConfigFileParser μ =
    ( Functor μ
    , Applicative μ
    , MonadIO μ
    , MonadBaseControl IO μ
    , MonadError T.Text μ
    )
#else
type ConfigFileParser μ =
    ( Functor μ
    , Applicative μ
    , MonadIO μ
    , MonadError T.Text μ
    )
#endif

parseConfigFiles
     (ConfigFileParser μ, FromJSON (α  α))
     ConfigFilesConfig
     α
        -- ^ default configuration value
     [ConfigFile]
        -- ^ list of configuration file paths
     μ α
parseConfigFiles conf = foldM $ \val file 
    readConfigFile conf file <*> pure val

readConfigFile
     (ConfigFileParser μ, FromJSON (α  α))
     ConfigFilesConfig
     ConfigFile
        -- ^ file path
     μ (α  α)
readConfigFile _conf file =
#ifdef REMOTE_CONFIGS
    if isRemote file then loadRemote _conf file else loadLocal file
#else
    loadLocal file
#endif

fileType  T.Text  ConfigFileFormat
fileType f
    | CI.foldCase ".yaml" `T.isSuffixOf` CI.foldCase f = Yaml
    | CI.foldCase ".yml" `T.isSuffixOf` CI.foldCase f = Yaml
    | CI.foldCase ".json" `T.isSuffixOf` CI.foldCase f = Json
    | CI.foldCase ".js" `T.isSuffixOf` CI.foldCase f = Json
    | otherwise = Other

loadLocal
     (Functor μ, MonadIO μ, MonadError T.Text μ, FromJSON (α  α))
     ConfigFile
        -- ^ file path
     μ (α  α)
loadLocal path = do
    validateFilePath "config-file" (T.unpack file)
    exists  (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e  case path of
        ConfigFileOptional _  return False
        ConfigFileRequired _  throwError $ "failed to read config file: "  e
    if exists
      then
        liftIO (parser (fileType file) file) >>= \case
            Left e  throwError $ "failed to parse configuration file "  file  ": "  sshow e
            Right r  return r
      else
        return id
  where
    file = getConfigFile path

    parser Json f = fmapL T.pack  eitherDecodeStrict' <$> B8.readFile (T.unpack f)
    parser _ f = fmapL sshow <$> Yaml.decodeFileEither (T.unpack f)

data ConfigFileFormat
    = Yaml
    | Json
    | Other
    deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)

instance NFData ConfigFileFormat

#ifdef REMOTE_CONFIGS
isRemote
     ConfigFile
     Bool
isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"]

yamlMimeType  IsString s  [s]
yamlMimeType = map fromString ["application/x-yaml", "text/yaml"]

-- | Defined in  RFC 4627
--
jsonMimeType  IsString s  [s]
jsonMimeType = map fromString ["application/json"]

contentType
     B8.ByteString
        -- ^ value of an HTTP @Content-Type@ header
     ConfigFileFormat
contentType headerValue
    | CI.foldCase "yaml" `B8.isInfixOf` CI.foldCase headerValue = Yaml
    | CI.foldCase "json" `B8.isInfixOf` CI.foldCase headerValue = Json
    | otherwise = Other

loadRemote
     (ConfigFileParser μ, FromJSON (α  α))
     ConfigFilesConfig
     ConfigFile
        -- ^ URL
     μ (α  α)
loadRemote conf path = do
    validateHttpOrHttpsUrl "config-file" (T.unpack url)
    result  (Just <$> doHttp) `catchAnyDeep` \e 
        case path of
            ConfigFileOptional _  do
                liftIO  T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file "  url  ": "  sshow e
                return Nothing
            ConfigFileRequired _  throwError $ "failed to download remote configuration file "  url  ": "  sshow e

    case result of
        Nothing  return id
        Just (format, d)  case (parser format) d of
            Left e  throwError $ "failed to parse remote configuration "  url  ": "  e
            Right r  return r
  where
    parser Json = fmapL T.pack  eitherDecodeStrict'
    parser _ = fmapL sshow  Yaml.decodeEither'

    url = getConfigFile path
    policy = _cfcHttpsPolicy conf
    doHttp = liftIO $ do
        request  (HTTP.parseUrl $ T.unpack url)
            <&> over requestHeaders ((:) acceptHeader)
        resp  httpWithValidationPolicy request policy
        let format = maybe Other contentType  L.lookup HTTP.hContentType $ HTTP.responseHeaders resp
        return (format, LB.toStrict (HTTP.responseBody resp))

    acceptHeader = (HTTP.hAccept, B8.intercalate "," (yamlMimeType  jsonMimeType))

requestHeaders  Lens' HTTP.Request HTTP.RequestHeaders
requestHeaders = lens HTTP.requestHeaders $ \s a  s { HTTP.requestHeaders = a }

#endif