gale client

root / ConfigFile.hs

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
{-# LANGUAGE ScopedTypeVariables #-}
module ConfigFile(
    configLookupBool,
    configLookup,
    configLookupList,
    configLookupElse,
    -- new interface
    configGet,
    configSetup,
    reloadConfigFiles,
    mapConfig,
    configFile,
    configEnv,
    configDefault,
    configShow,
    toConfig,
    defaultConfig,
    parseConfigFile


    ) where

import qualified Control.Exception as E
import Data.Char
import System.Environment
import System.IO.Unsafe

import CacheIO
import ErrorLog
import Data.Monoid

newtype Config = Config (String -> IO [(String,(String,String))])
type ConfigFile = [(String, String)]

toConfig = Config

-- dealing with global config settings


{-# NOTINLINE config_default #-}
config_default :: JVar Config
config_default = unsafePerformIO (newJVar mempty)


configSetup :: Config -> IO ()
configSetup c = writeVal config_default c >> reloadConfigFiles

defaultConfig :: IO Config
defaultConfig = readVal config_default

configGet :: String -> IO [(String,(String,String))]
configGet k = do
        Config c <- defaultConfig
        v <- c k
        mapM fixUp v where
            fixUp (w,(k,v)) = do
                v' <- conv v
                return (w,(k,v'))
            conv v = case (span (/= '$') v) of
                (xs,"") -> return xs
                (xs,('$':'$':ys)) -> conv ys >>= \r -> return (xs ++ "$" ++ r)
                (xs,('$':c:ys)) | isDigit c -> conv ys >>= \r -> return (xs ++ ['$',c] ++ r)
                (xs,('$':ys)) -> case span isPropName ys of
                    (pn,ys) -> do
                        n <- configLookupElse pn ""
                        r <- conv ys
                        return (xs ++ n ++ r)
                _ -> error "shouldn't happen"


-- | reload all configuration files emit a config signal.
reloadConfigFiles :: IO ()
reloadConfigFiles = writeVal config_files_var [] {->> signal configSignal ()-}




{-# NOTINLINE config_files_var #-}
config_files_var :: JVar [(String,ConfigFile)]
config_files_var = unsafePerformIO (newJVar [])


basicLookup n cl k = return [ (n,(k,v)) | (k',v) <- cl, k == k']

configDefault :: [(String,String)] -> Config
configDefault cl = Config $ \k -> basicLookup "default" cl k

configFile :: String -> Config
configFile fn = Config $ \k -> do
    cf <- readVal config_files_var
    case lookup fn cf of
        Just cl -> basicLookup fn cl k
        Nothing -> do
            cl <- E.catch (fmap parseConfigFile $ readFile fn) (\(_ :: E.IOException) -> return [])
            mapVal config_files_var ((fn,cl):)
            basicLookup fn cl k

configEnv :: Config
configEnv = Config $ \k -> do
    ev <- E.catch (fmap return $ getEnv k) (\(_ :: E.IOException) -> return [])
    return $ fmap (\v -> ("enviornment", (k,v))) ev

mapConfig :: (String -> String) -> Config -> Config
mapConfig f (Config c) = Config $ \s -> c (f s)

instance Monoid Config where
    mempty =  Config $ \_ -> return []
    mappend (Config c1) (Config c2) = Config $ \s -> do
        x <- c1 s
        y <- c2 s
        return (x ++ y)

configShow :: [String] -> Config -> IO String
configShow ss (Config c) = do
    v <- mapM c ss
    return $ unlines $ map p $ zip ss v where
        p (k,((w,(k',v))):_) = k ++ " " ++ v ++ "\n#  in " ++ w ++
            if k' /= k then " as " ++ k' else ""
        p (k,[]) = "#" ++ k ++ " Not Found."


-- types of config sources:
-- enviornment
-- enviornment after transformation of query
-- file
-- default





isPropName c = isAlphaNum c || c `elem` "-_"

parseConfigFile :: String -> ConfigFile
parseConfigFile s = concatMap bl (fixup $ lines (uncomment s)) where
    uncomment ('#':xs) = uncomment (dropWhile (/= '\n') xs)
    uncomment ('-':'-':xs) = uncomment (dropWhile (/= '\n') xs)
    uncomment (x:xs) = x:uncomment xs
    uncomment [] = []
    fixup (x:y@(c:_):xs) | isSpace c = fixup ((x ++ y):xs)
    fixup (x:xs) = x: fixup xs
    fixup [] = []
    bl s = let (n,r) = span isPropName (dropWhile isSpace s) in
        if null n then [] else [(n,dropWhile isSpace r)]

{-

{-# NOINLINE config_file_var #-}
config_file_var :: SVar ConfigFile
config_file_var = unsafePerformIO $ newSVar []


loadStdConfiguration :: String -> IO ()
loadStdConfiguration f = do
    c <- getConfiguration f
    writeSVar config_file_var c
    return ()

getConfiguration :: String -> IO ConfigFile
getConfiguration s = do
    e <- getEnv "HOME"
    c <- readFile (e ++ "/" ++ s)
    return $ parseConfigFile c
-}

configLookupBool k = do
    x <- configLookup k
    case x of
        Just s | cond -> return True where
            cond = (map toLower s) `elem` ["true", "yes", "on", "y", "t"]
        _ -> return False


configLookup k = do
    vs <- configGet k
    case vs of
        ((_,(_,v)):_) -> return $ Just v
        [] -> return Nothing


configLookupList k = do
    vs <- configGet k
    return $ [ y| (_,(_,y)) <- vs]

configLookupElse k e = do
    v <- configLookup k
    case v of
        Just v -> return v
        Nothing -> return e