module Util.WBFiles (
getWishPath,
getDaVinciPath,
getGnuClientPath,
getToolTimeOut,
getTOP,
getTOPPath,
getEditorString,
getMMiSSDTD,
getMMiSSAPIDTD,
getHosts,
getPort,
getXMLPort,
getCouplingPort,
getWorkingDir,
getCouplingDir,
getDebugFileName,
getDaVinciIcons,
getServer,
getUser,
getPassword,
getServerFile,
getServerDir,
getServerId,
getArgString,
getArgBool,
getArgInt,
parseArguments,
parseArgumentsRequiring,
ArgType(..),
ArgValue(..),
ProgramArgument(..),
usualProgramArguments,
parseTheseArguments,
parseTheseArgumentsRequiring,
setAlternateArgs
) where
import Data.Char
import Util.CompileFlags
import System.IO
import Data.List
import Control.Monad
import qualified System.Environment as System
import System.Exit(exitWith,ExitCode(..))
import qualified Control.Exception as Exception
import Control.Concurrent
import qualified Data.Map as Map
import System.IO.Unsafe
import Foreign.C.String
import Util.FileNames
valOf :: String -> IO (Maybe a) -> IO a
valOf optionName action =
do
valueOpt <- action
case valueOpt of
Just a -> return a
Nothing ->
error ("option --uni-" ++ optionName ++ " is surprisingly unset")
getWishPath :: IO String
getWishPath = valOf "wish" (getArgString "wish")
getEditorString :: IO (Maybe String)
getEditorString = getArgString "editor"
getMMiSSDTD :: IO (Maybe String)
getMMiSSDTD =
do
mmissDTDOpt <- getArgString "MMiSSDTD"
case mmissDTDOpt of
Just mmissDTD -> return mmissDTDOpt
Nothing ->
do
path <- getTOPPath ["mmiss","MMiSS.dtd"]
return (Just path)
getMMiSSAPIDTD :: IO (Maybe String)
getMMiSSAPIDTD =
do
path <- getTOPPath ["mmiss","api","MMiSSRequest.dtd"]
return (Just path)
getHosts :: IO String
getHosts =
do
hostsOpt <- getArgString "Hosts"
case hostsOpt of
Just hosts -> return hosts
Nothing ->
getTOPPath ["server","Hosts.xml"]
getDaVinciPath :: IO String
getDaVinciPath = valOf "daVinci" (getArgString "daVinci")
getGnuClientPath :: IO String
getGnuClientPath = valOf "gnuclient" (getArgString "gnuclient")
getToolTimeOut :: IO Int
getToolTimeOut = valOf "toolTimeOut" (getArgInt "toolTimeOut")
getTOP :: IO String
getTOP = valOf "top" (getArgString "top")
getTOPPath :: [String] -> IO String
getTOPPath names =
do
top <- getTOP
return (unbreakName (trimDir top:names))
getPort :: IO Int
getPort = valOf "port" (getArgInt "port")
getXMLPort :: IO Int
getXMLPort = valOf "xmlPort" (getArgInt "xmlPort")
getWorkingDir :: IO String
getWorkingDir =
do
workingDir' <- valOf "workingDir" (getArgString "workingDir")
return (trimDir workingDir')
getDebugFileName :: IO String
getDebugFileName = valOf "debug" (getArgString "debug")
getServerFile :: String -> IO String
getServerFile innerName =
do
serverDir <- getServerDir
return (combineNames (trimDir serverDir) innerName)
getServerDir :: IO String
getServerDir =
do
serverDirOpt <- getArgString "serverDir"
case serverDirOpt of
Nothing ->
error (
"UNISERVERDIR environment variable or --uni-serverDir"
++ " must be set for server programs")
Just serverDir -> return serverDir
getServerId :: IO (Maybe String)
getServerId = getArgString "serverId"
getDaVinciIcons :: IO (Maybe String)
getDaVinciIcons = getArgString "daVinciIcons"
getServer :: IO (Maybe String)
getServer = getArgString "server"
getUser :: IO (Maybe String)
getUser = getArgString "user"
getPassword :: IO (Maybe String)
getPassword = getArgString "password"
getCouplingPort :: IO Int
getCouplingPort = valOf "couplingPort" (getArgInt "couplingPort")
getCouplingDir :: IO String
getCouplingDir = valOf "couplingDir" (getArgString "couplingDir")
data ProgramArgument = ProgramArgument {
optionName :: String,
optionHelp :: String,
defaultVal :: Maybe ArgValue,
argType :: ArgType
}
usualProgramArguments :: [ProgramArgument]
usualProgramArguments = [
ProgramArgument{
optionName = "wish",
optionHelp = "path to the wish program",
defaultVal = Just (StringValue "/usr/bin/wish"),
argType = STRING
},
ProgramArgument{
optionName = "daVinci",
optionHelp = "path to the daVinci program",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "daVinciIcons",
optionHelp = "directory containing daVinci icons",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "gnuclient",
optionHelp = "path to the gnuclient program",
defaultVal = Just (StringValue "gnuclient"),
argType = STRING
},
ProgramArgument{
optionName = "toolTimeOut",
optionHelp = "time-out when tools start up in milliseconds",
defaultVal = Just (IntValue 10000),
argType = INT
},
ProgramArgument{
optionName = "windowsTick",
optionHelp = "interval in microseconds for polling wish (Windows only).",
defaultVal = Just (IntValue 10000),
argType = INT
},
ProgramArgument{
optionName = "editor",
optionHelp = "text editor cmd; %F => filename; %N => user-visible name",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "MMiSSDTD",
optionHelp = "Filename for MMiSS's DTD",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "Hosts",
optionHelp = "File containing list of hosts",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "top",
optionHelp = "path where UniForM was installed",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "serverDir",
optionHelp = "where server stores its files",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "serverId",
optionHelp = "globally unique server identifier (EXPERTS ONLY)",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "workingDir",
optionHelp = "directory used for temporary files",
defaultVal = Just (StringValue "/tmp"),
argType = STRING
},
ProgramArgument{
optionName = "server",
optionHelp = "machine where the server runs",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "user",
optionHelp = "Your identifier on the server",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "password",
optionHelp = "Your password on the server",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "port",
optionHelp = "port for the server",
defaultVal = Just (IntValue defaultPort),
argType = INT
},
ProgramArgument{
optionName = "xmlPort",
optionHelp = "port for the MMiSS-XML server",
defaultVal = Just (IntValue defaultXMLPort),
argType = INT
},
ProgramArgument{
optionName = "couplingPort",
optionHelp = "port for the coupling server",
defaultVal = Just (IntValue defaultCouplingPort),
argType = INT
},
ProgramArgument{
optionName = "couplingDir",
optionHelp = "directory where the coupling server finds the working copy of foreign repository",
defaultVal = Nothing,
argType = STRING
},
ProgramArgument{
optionName = "debug",
optionHelp = "file for debug output",
defaultVal = Just (StringValue "/tmp/uniform.DEBUG"),
argType = STRING
}
]
defaultPort :: Int
defaultPort = 11393
defaultXMLPort :: Int
defaultXMLPort = 11396
defaultCouplingPort :: Int
defaultCouplingPort = 11391
data ArgType = STRING | INT | BOOL
showArgType :: ArgType -> String
showArgType STRING = "string"
showArgType INT = "int"
showArgType BOOL = "bool"
data ArgValue = StringValue String | IntValue Int | BoolValue Bool
parseArgValue :: ArgType -> String -> Maybe ArgValue
parseArgValue STRING str = Just (StringValue str)
parseArgValue INT str =
case readsPrec 0 str of
[(val,"")] -> Just (IntValue val)
_ -> Nothing
parseArgValue BOOL str =
let
true = Just (BoolValue True)
false = Just (BoolValue False)
in
case str of
"" -> true
"True" -> true
"False" -> false
"+" -> true
"-" -> false
"yes" -> true
"no" -> false
_ -> Nothing
showArgValue :: ArgValue -> String
showArgValue (StringValue str) = str
showArgValue (IntValue i) = show i
showArgValue (BoolValue b) = if b then "+" else "-"
newtype ParsedArguments =
ParsedArguments (MVar (Maybe (Map.Map String ArgValue)))
makeParsedArguments :: IO ParsedArguments
makeParsedArguments =
do
mVar <- newMVar Nothing
return (ParsedArguments mVar)
parsedArguments :: ParsedArguments
parsedArguments = unsafePerformIO makeParsedArguments
getArgValue :: String -> IO (Maybe ArgValue)
getArgValue optionName =
do
map <- forceParseArguments
return (Map.lookup optionName map)
mismatch :: String -> a
mismatch optionName =
error ("WBFiles.mismatch - type mismatch for "++optionName)
getArgString :: String -> IO (Maybe String)
getArgString optionName =
do
valOpt <- getArgValue optionName
case valOpt of
Just (StringValue str) -> return (Just str)
Just _ -> mismatch optionName
Nothing -> return Nothing
getArgInt :: String -> IO (Maybe Int)
getArgInt optionName =
do
valOpt <- getArgValue optionName
case valOpt of
Just (IntValue i) -> return (Just i)
Just _ -> mismatch optionName
Nothing -> return Nothing
getArgBool :: String -> IO (Maybe Bool)
getArgBool optionName =
do
valOpt <- getArgValue optionName
case valOpt of
Just (BoolValue b) -> return (Just b)
Just _ -> mismatch optionName
Nothing -> return Nothing
forceParseArguments :: IO (Map.Map String ArgValue)
forceParseArguments =
do
let ParsedArguments mVar = parsedArguments
mapOpt <- takeMVar mVar
case mapOpt of
Nothing ->
do
(exitCode,newMap) <-
parseTheseArgumentsRequiring' usualProgramArguments []
putMVar mVar (Just newMap)
return newMap
Just map ->
do
putMVar mVar (Just map)
return map
alternateArgs :: MVar [String]
newAlternateArgs :: IO (MVar [String])
newAlternateArgs = newEmptyMVar
alternateArgs = unsafePerformIO newAlternateArgs
setAlternateArgs :: [String] -> IO ()
setAlternateArgs newArgs =
do
isEmpty <- isEmptyMVar alternateArgs
if isEmpty
then
putMVar alternateArgs newArgs
else
error "setAlternateArgs called twice or after getArgs"
getArgs :: IO [String]
getArgs =
do
isEmpty <- isEmptyMVar alternateArgs
args <- if isEmpty
then
System.getArgs
else
takeMVar alternateArgs
putMVar alternateArgs args
return args
parseArguments :: IO ()
parseArguments = parseTheseArguments usualProgramArguments
parseArgumentsRequiring :: [String] -> IO ()
parseArgumentsRequiring required =
parseTheseArgumentsRequiring usualProgramArguments required
parseTheseArguments :: [ProgramArgument] -> IO ()
parseTheseArguments arguments = parseTheseArgumentsRequiring arguments []
parseTheseArgumentsRequiring :: [ProgramArgument] -> [String] -> IO ()
parseTheseArgumentsRequiring arguments required =
do
let ParsedArguments mVar = parsedArguments
mapOpt <- takeMVar mVar
case mapOpt of
Just _ ->
do
putMVar mVar mapOpt
printToErr
("WBFiles.parseTheseArgumentsRequiring: " ++
"attempt to parse arguments too late")
Nothing ->
do
(result,newMap) <-
parseTheseArgumentsRequiring' arguments required
putMVar mVar (Just newMap)
case result of
Nothing -> return ()
Just exitCode -> exitWith exitCode
type ParseState = (Maybe ExitCode,Map.Map String ArgValue)
parseTheseArgumentsRequiring' :: [ProgramArgument] -> [String] ->
IO ParseState
parseTheseArgumentsRequiring' arguments required =
do
let
initialMap =
foldl
(\ map argument ->
case (defaultVal argument) of
Nothing -> map
Just value -> Map.insert (optionName argument) value map
)
Map.empty
arguments
initial = (Nothing, initialMap) :: ParseState
defaultOptionsStr <- peekCString defaultOptions
afterDefault <- foldM (handleParameter False) initial
(words defaultOptionsStr)
parameters <- getArgs
afterParms <- foldM (handleParameter True) afterDefault parameters
afterEnvs <- foldM handleEnv afterParms arguments
foldM checkReq afterEnvs required
where
handleParameter :: Bool -> ParseState -> String -> IO ParseState
handleParameter noticeErrors prev@(prevExit,prevMap) parameter =
let
newExit exitCode = upgradeError noticeErrors exitCode prevExit
cantParse =
do
printToErr ("Can't parse "++parameter)
displayHelp
return (newExit (ExitFailure 4),prevMap)
in
case parameter of
"--uni" ->
do
displayHelp
return (newExit ExitSuccess,prevMap)
"--uni-version" ->
do
printToErr ("uni's version is "++uniVersion)
return (newExit ExitSuccess,prevMap)
"--uni-parameters" ->
do
displayState prevMap
return (newExit ExitSuccess,prevMap)
'-':'-':'u':'n':'i':'-':setParm ->
case splitSetPart setParm of
Nothing -> cantParse
Just (option,value) ->
case find (\ arg -> optionName arg == option)
arguments of
Nothing ->
do
if noticeErrors
then
do
displayHelp
printToErr ("Option '"++option++
"' not recognised")
else
return ()
return (newExit (ExitFailure 4),prevMap)
Just arg ->
tryToAddValue (argType arg) option value prev
'-':'-':'u':'n':'i':_ -> cantParse
_ -> return prev
tryToAddValue :: ArgType -> String -> String -> ParseState ->
IO ParseState
tryToAddValue argType option value prev@(prevExit,prevMap) =
case parseArgValue argType value of
Nothing ->
do
printToErr("For --uni-"++ option ++ ", "++(show value)++
" isn't "++ (showArgType argType))
return
(upgradeError True (ExitFailure 4) prevExit,prevMap)
Just argValue ->
return (prevExit,Map.insert option argValue prevMap)
splitSetPart :: String -> Maybe (String,String)
splitSetPart "" = Nothing
splitSetPart (':':rest) = Just ("",rest)
splitSetPart ('=':rest) = Just ("",rest)
splitSetPart (first:rest) =
case splitSetPart rest of
Nothing -> Nothing
Just (left,right) -> Just (first:left,right)
displayHelp :: IO ()
displayHelp =
do
printToErr "Command-line options:"
printToErr "--uni displays this message"
printToErr "--uni-version displays the current version"
printToErr "--uni-parameters displays option settings"
sequence_
(map
(\ (ProgramArgument{optionName = optionName,
optionHelp = optionHelp,argType = argType}) ->
printToErr (
"--uni-"++optionName++"=["++showArgType argType ++
"] sets "++optionHelp
)
)
arguments
)
displayState :: Map.Map String ArgValue -> IO ()
displayState fmap =
do
let optionValues = Map.toList fmap
printToErr "Parameter settings:"
sequence_
(map
(\ (option,argValue) ->
printToErr ("--uni-"++option++"="++
(showArgValue argValue))
)
optionValues
)
handleEnv :: ParseState -> ProgramArgument -> IO ParseState
handleEnv prev@(prevExit,prevMap) arg =
do
let
option = optionName arg
envVar = "UNI"++(map toUpper option)
valueOpt <- Exception.try (System.getEnv envVar)
case valueOpt of
Left (_ :: Exception.IOException) -> return prev
Right newValue ->
tryToAddValue (argType arg) option newValue prev
checkReq :: ParseState -> String -> IO ParseState
checkReq prev@(prevExit,prevMap) option =
case Map.lookup option prevMap of
Just _ -> return prev
Nothing ->
do
printToErr ("Option "++option++" is not set.")
return (upgradeError True (ExitFailure 4) prevExit,prevMap)
upgradeError :: Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
upgradeError False _ soFar = soFar
upgradeError True exitCode Nothing = Just exitCode
upgradeError True exitCode (Just ExitSuccess) = Just exitCode
upgradeError True ExitSuccess (Just exitCode) = Just exitCode
upgradeError True (ExitFailure level1) (Just (ExitFailure level2)) =
Just (ExitFailure (max level1 level2))
foreign import ccall "default_options.h & default_options"
defaultOptions :: CString
printToErr :: String -> IO ()
printToErr message =
do
hPutStrLn stderr message