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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
--------------------------------------------------------------------------
--- 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
--- @version January 2017
--------------------------------------------------------------------------

module CASS.Configuration
 ( systemBanner, baseDir, docDir, executableName
 , getServerAddress, updateRCFile, updateCurrentProperty
 , getFPMethod, getWithPrelude
 , storeServerPortNumber, removeServerPortNumber, getServerPortNumber
 , getDefaultPath, waitTime, numberOfWorkers
 ) where

import System
import Distribution (curryCompiler)
import PropertyFile
import ReadNumeric
import FilePath     (FilePath, (</>), (<.>))
import Directory
import ReadShowTerm
import Sort         (mergeSort)
import Global
import Char         (isSpace)

import Analysis.Logging   (debugMessage, setDebugLevel)
import CASS.PackageConfig (packagePath, packageExecutable, packageVersion)

systemBanner :: String
systemBanner =
  let bannerText = "CASS: Curry Analysis Server System (Version " ++
                   packageVersion ++ " of 23/01/2017 for "++curryCompiler++")"
      bannerLine = take (length bannerText) (repeat '=')
   in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine


--- 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.
baseDir :: String
baseDir = packagePath

--- The directory containing the documentations of the various analyses.
docDir :: String
docDir = baseDir </> "docs"

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

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

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

defaultPropertyFileName :: String
defaultPropertyFileName = baseDir </> "curryanalysisrc"

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

--- 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.
updateRCFile :: IO ()
updateRCFile = do
  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

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

--- Reads the user property file or, if it does not exist,
--- the default property file of CASS,
--- and store the properties in a global variable for next access.
readPropertiesAndStoreLocally :: IO [(String,String)]
readPropertiesAndStoreLocally = do
  userpfn    <- propertyFileName
  hasuserpfn <- doesFileExist userpfn
  props      <- readPropertyFile
                   (if hasuserpfn then userpfn else defaultPropertyFileName)
  writeGlobal currProps (Just props)
  updateDebugLevel props
  return props

--- 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 =
  readGlobal currProps >>= maybe readPropertiesAndStoreLocally return

--- 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

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

-- Updates a current property.
updateCurrentProperty :: String -> String -> IO ()
updateCurrentProperty pn pv = do
  currprops <- getProperties
  let newprops = replaceKeyValue pn pv currprops
  writeGlobal currProps (Just newprops)
  updateDebugLevel newprops

replaceKeyValue :: a -> b -> [(a,b)] -> [(a,b)]
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


--------------------------------------------------------------------------
--- Gets the name of file containing the current server port and pid
--- ($HOME has to be set) 
getServerPortFileName :: IO String
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
   else do debugMessage 2 "Starting analysis server..."
           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
     else do debugMessage 2 "Waiting for server start..."
             sleep 1
             waitForServerPort serverPortFileName

--------------------------------------------------------------------------
-- Get terminalCommand from Config file
getTerminalCommand :: IO String
getTerminalCommand = do
  properties <- getProperties
  let tcmd = lookup "terminalCommand" properties
  return (maybe "" id tcmd)

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

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

-- timeout for network message passing: -1 is wait time infinity
waitTime :: Int
waitTime = -1

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

--- Gets the default load path from the property file (added at the end
--- of CURRYPATH).
getDefaultPath :: IO String
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
numberOfWorkers :: IO Int
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