summaryrefslogtreecommitdiff
path: root/src/Configuration/Utils/Internal/ConfigFileReader.hs
blob: 1151f69f36c76f359cad51e2f02b592605cdecb1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
{-# 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
import Control.Monad.IO.Class
import Control.Monad.Error.Class

import qualified Data.ByteString.Char8 as B8
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.CaseInsensitive as CI
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 m =
    ( Functor m
    , Applicative m
    , MonadIO m
    , MonadBaseControl IO m
    , MonadError T.Text m
    )
#else
type ConfigFileParser m =
    ( Functor m
    , Applicative m
    , MonadIO m
    , MonadError T.Text m
    )
#endif

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

readConfigFile
    ∷ (ConfigFileParser m, FromJSON (a → a))
    ⇒ ConfigFilesConfig
    → ConfigFile
        -- ^ file path
    → m (a → a)
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
    | ".yaml" `T.isSuffixOf` T.toLower f = Yaml
    | ".yml" `T.isSuffixOf` T.toLower f = Yaml
    | ".json" `T.isSuffixOf` T.toLower f = Json
    | ".js" `T.isSuffixOf` T.toLower f = Json
    | otherwise = Other

loadLocal
    ∷ (Functor m, MonadIO m, MonadError T.Text m, FromJSON (a → a))
    ⇒ ConfigFile
        -- ^ file path
    → m (a → a)
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 m, FromJSON (a → a))
    ⇒ ConfigFilesConfig
    → ConfigFile
        -- ^ URL
    → m (a → a)
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