Configuration.curry 9.08 KB
Newer Older
1
2
3
4
5
6
7
8
--------------------------------------------------------------------------
--- This module supports the configuration of the analysis system
--- and provides access to some values in Config file.
---
--- It also provides an operation to get the port number of
--- the analysis server (which is implicitly started if necessary).
---
--- @author Michael Hanus
Michael Hanus's avatar
Michael Hanus committed
9
--- @version December 2018
10
11
--------------------------------------------------------------------------

Michael Hanus's avatar
Michael Hanus committed
12
13
module CASS.Configuration
 ( systemBanner, baseDir, docDir, executableName
14
15
16
 , getServerAddress, updateRCFile, updateCurrentProperty
 , getFPMethod, getWithPrelude
 , storeServerPortNumber, removeServerPortNumber, getServerPortNumber
Michael Hanus's avatar
Michael Hanus committed
17
 , getDefaultPath, waitTime, numberOfWorkers
18
 ) where
19

Michael Hanus's avatar
Michael Hanus committed
20
import Char         ( isSpace )
21
import Directory
Michael Hanus's avatar
Michael Hanus committed
22
23
import Distribution ( curryCompiler )
import FilePath     ( FilePath, (</>), (<.>) )
24
import Global
Michael Hanus's avatar
Michael Hanus committed
25
26
27
28
import ReadNumeric
import ReadShowTerm
import Sort         ( mergeSort )
import System
Michael Hanus's avatar
Michael Hanus committed
29

Michael Hanus's avatar
Michael Hanus committed
30
31
32
import Analysis.Logging   ( debugMessage, setDebugLevel )
import CASS.PackageConfig ( packagePath, packageExecutable, packageVersion )
import Data.PropertyFile  ( readPropertyFile, updatePropertyFile )
33

34
systemBanner :: String
35
systemBanner =
Michael Hanus's avatar
Michael Hanus committed
36
  let bannerText = "CASS: Curry Analysis Server System (Version " ++
Michael Hanus's avatar
Michael Hanus committed
37
                   packageVersion ++ " of 13/09/2018 for " ++
Michael Hanus's avatar
Michael Hanus committed
38
                   curryCompiler ++ ")"
39
40
41
42
      bannerLine = take (length bannerText) (repeat '=')
   in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine


43
44
45
46
47
--- The base directory of the analysis tool containing all programs
--- and documentations.
--- It is used to copy the configuration file, to the find executables
--- of the server and the workers, and to find the documentation
--- of the various analyses.
48
baseDir :: String
Michael Hanus's avatar
Michael Hanus committed
49
baseDir = packagePath
50
51
52

--- The directory containing the documentations of the various analyses.
docDir :: String
Michael Hanus's avatar
Michael Hanus committed
53
docDir = baseDir </> "docs"
Michael Hanus's avatar
Michael Hanus committed
54
55
56
57

--- The name of the main executable. Used to start workers in `CASS.Server`.
executableName :: String
executableName = packageExecutable
58
59

--- The address of the server when it is connected from the worker clients.
60
getServerAddress :: IO String
61
62
63
64
getServerAddress = return "127.0.0.1" -- run only on local machine

--------------------------------------------------------------------------
-- Name of user property file:
65
propertyFileName :: IO String
66
67
propertyFileName = getHomeDirectory >>= return . (</> ".curryanalysisrc")

68
defaultPropertyFileName :: String
69
70
71
defaultPropertyFileName = baseDir </> "curryanalysisrc"

--- Install user property file if it does not exist.
72
installPropertyFile :: IO ()
73
74
75
76
77
78
79
installPropertyFile = do
  fname <- propertyFileName
  pfexists <- doesFileExist fname
  if pfexists then done else do
    copyFile defaultPropertyFileName fname
    putStrLn ("New analysis configuration file '"++fname++"' installed.")

80
81
82
83
84
--- Reads the rc file (and try to install a user copy of it if it does not
--- exist) and compares the definitions with the default property file
--- of the CASS distribution. If the set of variables is different,
--- update the rc file of the user with the distribution
--- but keep the user's definitions.
85
86
updateRCFile :: IO ()
updateRCFile = do
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
  hashomedir <- getHomeDirectory >>= doesDirectoryExist
  if not hashomedir
   then readPropertiesAndStoreLocally >> done
   else do
     installPropertyFile
     userprops <- readPropertiesAndStoreLocally
     distprops <- readPropertyFile defaultPropertyFileName
     if (rcKeys userprops == rcKeys distprops) then done else do
       rcName    <- propertyFileName
       putStrLn $ "Updating \"" ++ rcName ++ "\"..."
       renameFile rcName $ rcName <.> "bak"
       copyFile defaultPropertyFileName rcName
       mapIO_ (\ (n, v) -> maybe done
                 (\uv -> if uv==v then done else updatePropertyFile rcName n uv)
                 (lookup n userprops))
              distprops
103
104

rcKeys :: [(String, String)] -> [String]
105
rcKeys = mergeSort . map fst
106

107
108
--- Reads the user property file or, if it does not exist,
--- the default property file of CASS,
Michael Hanus's avatar
Michael Hanus committed
109
110
111
--- and store the properties in a global variable for next access.
readPropertiesAndStoreLocally :: IO [(String,String)]
readPropertiesAndStoreLocally = do
112
113
114
115
  userpfn    <- propertyFileName
  hasuserpfn <- doesFileExist userpfn
  props      <- readPropertyFile
                   (if hasuserpfn then userpfn else defaultPropertyFileName)
Michael Hanus's avatar
Michael Hanus committed
116
  writeGlobal currProps (Just props)
Michael Hanus's avatar
Michael Hanus committed
117
  updateDebugLevel props
Michael Hanus's avatar
Michael Hanus committed
118
119
  return props

120
121
122
123
--- Reads the user property file (which must be installed!)
--- and store the properties in a global variable for next access.
getProperties :: IO [(String,String)]
getProperties =
Michael Hanus's avatar
Michael Hanus committed
124
  readGlobal currProps >>= maybe readPropertiesAndStoreLocally return
125

Michael Hanus's avatar
Michael Hanus committed
126
127
128
129
130
131
132
133
134
135
136
--- Updates the debug level from the current properties.
updateDebugLevel :: [(String,String)] -> IO ()
updateDebugLevel properties = do
  let number = lookup "debugLevel" properties
  case number of
    Just value -> do 
      case (readInt value) of
        Just (dl,_) -> setDebugLevel dl
        Nothing -> done
    Nothing -> done

137
138
139
140
--- Global variable to store the current properties.
currProps :: Global (Maybe [(String,String)])
currProps = global Nothing Temporary

Michael Hanus's avatar
Michael Hanus committed
141
142
143
144
-- Updates a current property.
updateCurrentProperty :: String -> String -> IO ()
updateCurrentProperty pn pv = do
  currprops <- getProperties
Michael Hanus's avatar
Michael Hanus committed
145
146
147
  let newprops = replaceKeyValue pn pv currprops
  writeGlobal currProps (Just newprops)
  updateDebugLevel newprops
Michael Hanus's avatar
Michael Hanus committed
148

Michael Hanus's avatar
Michael Hanus committed
149
replaceKeyValue :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
Michael Hanus's avatar
Michael Hanus committed
150
151
152
153
154
replaceKeyValue k v [] = [(k,v)]
replaceKeyValue k v ((k1,v1):kvs) =
  if k==k1 then (k,v):kvs else (k1,v1) : replaceKeyValue k v kvs


155
156
157
--------------------------------------------------------------------------
--- Gets the name of file containing the current server port and pid
--- ($HOME has to be set) 
158
getServerPortFileName :: IO String
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
getServerPortFileName = do
  homeDir <- getHomeDirectory
  return $ homeDir++"/.curryanalysis.port"

--- Stores the current server port number together with the pid of
--- the server process.
storeServerPortNumber :: Int -> IO ()
storeServerPortNumber portnum = do
  mypid <- getPID
  serverPortFileName <- getServerPortFileName
  writeQTermFile serverPortFileName (portnum,mypid)

--- Removes the currently stored server port number.
removeServerPortNumber :: IO ()
removeServerPortNumber = getServerPortFileName >>= removeFile

readServerPortPid :: IO (Int,Int)
readServerPortPid = getServerPortFileName >>= readQTermFile

--- Reads the current server port number. If the server is not running,
--- it is also started.
getServerPortNumber :: IO Int
getServerPortNumber = do
  serverPortFileName <- getServerPortFileName
  exfile <- doesFileExist serverPortFileName
  if exfile
   then do (portnum,pid) <- readServerPortPid
           flag <- system ("ps -p "++show pid++" > /dev/null")
           if flag==0
            then return portnum
            else do removeFile serverPortFileName
                    getServerPortNumber
191
   else do debugMessage 2 "Starting analysis server..."
192
193
194
195
196
197
198
199
200
201
202
203
           tcmd <- getTerminalCommand
           let serverCmd = baseDir++"/cass"
           if all isSpace tcmd
            then system ("\""++serverCmd++"\"  > /dev/null 2>&1 &")
            else system (tcmd++" \""++baseDir++"/cass\" &")
           sleep 1
           waitForServerPort serverPortFileName
 where
  waitForServerPort serverPortFileName = do
    exfile <- doesFileExist serverPortFileName
    if exfile
     then readServerPortPid >>= return . fst
204
     else do debugMessage 2 "Waiting for server start..."
205
206
207
208
209
             sleep 1
             waitForServerPort serverPortFileName

--------------------------------------------------------------------------
-- Get terminalCommand from Config file
210
getTerminalCommand :: IO String
211
212
213
214
215
216
getTerminalCommand = do
  properties <- getProperties
  let tcmd = lookup "terminalCommand" properties
  return (maybe "" id tcmd)

-- Get the fixpoint computation method from Config file
217
getFPMethod :: IO String
218
219
220
221
getFPMethod =
  getProperties >>= return . maybe "simple" id . lookup "fixpoint"

-- Get the option to analyze also the prelude from Config file
222
getWithPrelude :: IO String
223
224
225
226
getWithPrelude =
  getProperties >>= return . maybe "yes" id . lookup "prelude"

-- timeout for network message passing: -1 is wait time infinity
227
waitTime :: Int
228
229
230
231
waitTime = -1  

-- Default number of workers (if the number is not found in the
-- configuration file).
232
defaultWorkers :: Int
233
234
defaultWorkers=0

235
--- Gets the default load path from the property file (added at the end
236
--- of CURRYPATH).
237
getDefaultPath :: IO String
238
239
240
241
242
243
244
245
246
247
getDefaultPath = do
  currypath <- getEnviron "CURRYPATH"
  properties <- getProperties
  let proppath = lookup "path" properties
  return $ case proppath of
    Just value -> if all isSpace value then currypath else
                  if null currypath then value else currypath++':':value
    Nothing -> currypath

-- number of worker threads running at the same time
248
numberOfWorkers :: IO Int
249
250
251
252
253
254
255
256
257
numberOfWorkers = do
  properties <- getProperties
  let number = lookup "numberOfWorkers" properties
  case number of
    Just value -> do 
      case (readInt value) of
        Just (int,_) -> return int
        Nothing -> return defaultWorkers
    Nothing -> return defaultWorkers