Commit d8ef9ec6 authored by Michael Hanus 's avatar Michael Hanus

Base packaged synched to libs of PAKCS 2.1.0

parent a8e67a81
--- Implementation of a Curry Port Name Server based on raw sockets.
--- It is used to implement the library Ports for distributed programming
--- with ports.
--- @author Michael Hanus
--- @version February 2017
--- @category web
module CPNS(registerPort,getPortInfo,unregisterPort,
cpnsStart,cpnsStop,cpnsShow,cpnsAlive,main) where
import Char
import Distribution(installDir)
import FilePath((</>))
import IO
import List(delete,intersperse)
import Profile
import ReadShowTerm
import Socket
import System
import Time
-- If we connect to a port with symbolic name pn, we first connect
-- to the CPNS of the host named by pn to get the physical socket
-- number of this port. In order to connect to CPNS from any
-- machine in the world, the CPNS demon always listens at the following
-- port:
-- (Note that this must be identical for all machines running
-- Distributed Curry! If this port is occupied by another process
-- on a host, you cannot run Distributed Curry on it.)
-- The standard port number of CPNS demon.
cpnsSocket :: Int
cpnsSocket = 8767
-- The time out before considering the server as unreachable:
cpnsTimeOut :: Int
cpnsTimeOut = 3000
--- Type of messages to be processed by the Curry Port Name Server.
--- @cons Register name pid sn pn ack
--- - assign the values pid, sn, and pn to name
--- (pid is the process number of the registered process
--- (should be 0 if it is unknown); the server returns True
--- if registration had no problems, otherwise False)
--- @cons GetRegister name - request for a registered port name;
--- the server returns the values (sn,pn) that are assigned to the
--- port name
--- @cons Unregister name - request to remove a registered port name
--- @cons ShowRegistry - show the current port registrations
--- @cons Ping - ping the CPNS demon for liveness check
--- @cons Terminate - terminate the CPNS demon
data CPNSMessage = Terminate
| Ping
| Register String Int Int Int
| GetRegister String
| Unregister String
| ShowRegistry
-- The lock file to coordinate the startup of the CPNS demon:
cpnsStartupLockfile :: String
cpnsStartupLockfile = "/tmp/CurryPNSD.lock"
--- Starts the "Curry Port Name Server" (CPNS) running on the local machine.
--- The CPNS is responsible to resolve symbolic names for ports
--- into physical socket numbers so that a port can be reached
--- under its symbolic name from any machine in the world.
cpnsStart :: IO ()
cpnsStart = catch startup
(\_ -> putStrLn "FAILURE occurred during startup!" >>
deleteStartupLockfile >>
return Nothing) >>=
maybe done (cpnsServer [])
deleteStartupLockfile = do
putStrLn $ "Removing startup lock file \""++cpnsStartupLockfile++"\"..."
system $ "rm -f "++cpnsStartupLockfile
startup = do
putStrLn $ "Starting Curry Port Name Server on port " ++
show cpnsSocket ++ "..."
socket <- listenOn cpnsSocket
pid <- getPID
putStrLn $ "Curry Port Name Server is ready (PID: "++show pid++")."
return (Just socket)
--- The main loop of the CPNS demon
cpnsServer :: [(String,Int,Int,Int)] -> Socket -> IO ()
cpnsServer regs socket = do
(chost,stream) <- socketAccept socket
--putStrLn $ "Connection from "++chost
serveRequest chost stream
doIfLocalHost rhost action = do
hostname <- getHostname
if rhost `elem` ["localhost","localhost.localdomain",hostname]
|| take 8 rhost == "127.0.0."
then action
else do putStrLn $ "Illegal request received from host: " ++ rhost
cpnsServer regs socket
serveRequest rhost h = do
msg <- readMsgLine h
(\line -> do putStrLn $ "ERROR: Illegal message:\n" ++ line
cpnsServer regs socket )
(\m -> case m of
Terminate -> doIfLocalHost rhost $ do
hClose h
putStrLn "CPNS demon terminated."
Ping -> do
hPutStrLn h (showQTerm ())
hClose h
cpnsServer regs socket
Register pname pid sn pn -> doIfLocalHost rhost $ do
(ack, newregs) <- tryRegisterPortName regs pname pid sn pn
hPutStrLn h (showQTerm ack)
hClose h
cpnsServer newregs socket
GetRegister pname -> do
--putStrLn $ "Request for port name: " ++ pname
(newregs,pinfo) <- getRegisteredPortName regs pname
hPutStrLn h (showQTerm pinfo)
hClose h
cpnsServer newregs socket
Unregister pname -> doIfLocalHost rhost $ do
newregs <- unregisterPortName regs pname
hClose h
cpnsServer newregs socket
ShowRegistry -> doIfLocalHost rhost $ do
putStrLn "Currently registered port names:"
newregs <- showAndCleanRegs regs
hFlush stdout
hClose h
cpnsServer newregs socket )
tryRegisterPortName :: [(String,Int,Int,Int)] -> String -> Int -> Int -> Int
-> IO (Bool, [(String, Int, Int, Int)])
tryRegisterPortName regs name pid sn pn = do
let nameregs = filter (\(n,_,_,_)->name==n) regs
ack <- if null nameregs
then return True
else let (_,pid',_,_) = head nameregs in
if pid'>0 && pid'/=pid
-- we allow registration from the same process
then doesProcessExists pid' >>= \pex -> return (not pex)
else return True
ctime <- getLocalTime
putStrLn $ "Register port \""++name++"\": pid "++show pid++
" / socket "++show sn++
" / number "++show pn ++ " at " ++ calendarTimeToString ctime
let newregs = (name,pid,sn,pn) : filter (\ (n,_,_,_)->name/=n) regs
printMemInfo newregs
hFlush stdout
return (ack, newregs)
-- Delete all registrations for a given port name:
unregisterPortName :: [(String,Int,Int,Int)] -> String
-> IO [(String,Int,Int,Int)]
unregisterPortName regs name = do
ctime <- getLocalTime
putStrLn $ "Unregister port \""++name++"\" at "++calendarTimeToString ctime
let newregs = filter (\ (n,_,_,_)->name/=n) regs
printMemInfo newregs
hFlush stdout
return newregs
-- Get the socket number for a registered port name
-- (or (0,0) if not registered).
-- In addition, a new registration list is returned where a registration
-- is deleted if the corresponding server process does not exist.
getRegisteredPortName :: [(String,Int,Int,Int)] -> String
-> IO ([(String,Int,Int,Int)],(Int,Int))
getRegisteredPortName regs pname =
let nameregs = filter (\(n,_,_,_)->pname==n) regs in
if null nameregs
then return (regs,(0,0))
else let (_,pid,sn,pn) = head nameregs in
if pid>0
then doesProcessExists pid >>= \pex ->
if pex
then return (regs,(sn,pn))
else --putStrLn ("WARNING: Process "++show pid++" not running!") >>
return (delete (head nameregs) regs, (0,0))
else return (regs,(sn,pn))
-- Show all registered ports and return a new registration list
-- where a registration is deleted if the corresponding server process
-- does not exist.
showAndCleanRegs :: [(String,Int,Int,Int)] -> IO [(String,Int,Int,Int)]
showAndCleanRegs regs = do
newreglist <- mapIO checkAndShow regs
return (concat newreglist)
checkAndShow reg@(n,pid,sn,pn) = do
pidexist <- doesProcessExists pid
if pidexist
then do putStrLn $ n++": pid "++show pid++
" / socket "++show sn++" / number "++show pn
return [reg]
else return []
-- Print status information of current CPNS demon process:
printMemInfo :: [(String,Int,Int,Int)] -> IO ()
printMemInfo regs = do
pinfos <- getProcessInfos
putStrLn ("NumRegs: " ++ show (length regs) ++ ", " ++ showMemInfo pinfos)
-- test whether a process with a given pid is running:
doesProcessExists :: Int -> IO Bool
doesProcessExists pid = do
status <- system("test -z \"`ps -p "++show pid++" | fgrep "++show pid++"`\"")
return (status>0)
-- Read a line from a stream and check syntactical correctness of message:
readMsgLine :: Handle -> IO (Either String a)
readMsgLine handle = do
line <- hGetLine handle
case readsQTerm line of
[(msg,rem)] -> return (if all isSpace rem then Right msg else Left line)
_ -> return (Left line)
-- Perform an action if the CPNS demon at a given host is alive:
doIfAlive :: String -> IO a -> IO a
doIfAlive host action = do
alive <- cpnsAlive cpnsTimeOut host
if not alive
then error $ "Curry port name server at host \""++host++
"\" is not reachable (timeout after "++show cpnsTimeOut++
" ms)!"
else action
sendToLocalCPNS :: CPNSMessage -> IO ()
sendToLocalCPNS msg = doIfAlive "localhost" $ do
h <- connectToSocket "localhost" cpnsSocket
hPutStrLn h (showQTerm msg)
hClose h
--- Shows all registered ports at the local CPNS demon (in its logfile).
cpnsShow :: IO ()
cpnsShow = sendToLocalCPNS ShowRegistry
--- Terminates the local CPNS demon
cpnsStop :: IO ()
cpnsStop = sendToLocalCPNS Terminate
--- Gets an answer from a Curry port name server on a host,
--- or reports an error.
cpnsTryGetAnswer :: String -> CPNSMessage -> IO _
cpnsTryGetAnswer host msg = catch tryGetAnswer connectError
tryGetAnswer = do
h <- connectToSocket host cpnsSocket
hPutStrLn h (showQTerm msg)
hFlush h
ready <- hWaitForInput h cpnsTimeOut
if ready
then do
answer <- readMsgLine h
hClose h
either (\line -> error $ "cpnsTryGetAnswer: Illegal answer: " ++ line)
else failed
connectError _ = error $ "Curry port name server at host \""++host++
"\" is not reachable!"
--- Registers a symbolic port at the local host.
registerPort :: String -> Int -> Int -> IO ()
registerPort pname sn pn = do
pid <- getPID
ack <- cpnsTryGetAnswer "localhost" (Register pname pid sn pn)
if ack then done
else putStrLn ("WARNING: Port name '"++pname++"' already registered!")
--- Gets the information about a symbolic port at some host.
getPortInfo :: String -> String -> IO (Int,Int)
getPortInfo pname host = cpnsTryGetAnswer host (GetRegister pname)
--- Unregisters a symbolic port at the local host.
unregisterPort :: String -> IO ()
unregisterPort pname = sendToLocalCPNS (Unregister pname)
--- Tests whether the CPNS demon at a host is alive.
cpnsAlive :: Int -> String -> IO Bool
cpnsAlive timeout host = catch tryPingCPNS (\_ -> return False)
tryPingCPNS = do
h <- connectToSocket host cpnsSocket
hPutStrLn h (showQTerm Ping)
hFlush h
answer <- hWaitForInput h timeout
hClose h
return answer
--- Starts the CPNS demon at localhost if it is not already running:
startCPNSDIfNecessary :: IO ()
startCPNSDIfNecessary = do
system $ installDir </> "currytools" </> "cpns" </> "start"
--- Main function for CPNS demon. Check arguments and execute command.
main :: IO ()
main = do
args <- getArgs
case args of
["start"] -> cpnsStart
["stop"] -> cpnsStop
["show"] -> cpnsShow
_ -> putStrLn $ "ERROR: Illegal arguments: " ++
concat (intersperse " " args) ++ "\n" ++
"Allowed arguments: start|stop|show"
Test with PAKCS:
:fork cpnsStart
registerPort "xxx" 42 2
getPortInfo "xxx" "localhost"
--- This module contains functions to obtain information concerning the current
--- distribution of the Curry implementation, e.g.,
--- compiler version, load paths, front end.
--- This module contains definition of constants to obtain information
--- concerning the current distribution of the Curry implementation, e.g.,
--- compiler version, run-time version, installation directory.
--- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller, Finn Teegen
--- @version November 2018
--- @author Michael Hanus
--- @version December 2018
--- @category general
module Distribution (
curryCompiler, curryCompilerMajorVersion, curryCompilerMinorVersion,
curryRuntime, curryRuntimeMajorVersion, curryRuntimeMinorVersion,
baseVersion, installDir, stripCurrySuffix, modNameToPath,
currySubdir, inCurrySubdir, addCurrySubdir,
rcFileName, rcFileContents, getRcVar, getRcVars,
joinModuleIdentifiers, splitModuleIdentifiers, splitModuleFileName,
sysLibPath, getLoadPathForModule,
lookupModuleSourceInLoadPath, lookupModuleSource,
FrontendParams, defaultParams, rcParams,
quiet, extended, cpp, definitions, overlapWarn, fullPath, htmldir, logfile,
specials, setQuiet, setExtended, setCpp, addDefinition, setDefinitions,
setOverlapWarn, setFullPath, setHtmlDir, setLogfile, addTarget, setSpecials,
callFrontend, callFrontendWithParams
module Distribution
( curryCompiler, curryCompilerMajorVersion, curryCompilerMinorVersion
, curryCompilerRevisionVersion
, curryRuntime, curryRuntimeMajorVersion, curryRuntimeMinorVersion
, baseVersion, installDir, rcFileName
) where
import List (intercalate, nub, split)
import Char (toLower, toUpper)
import Directory (doesFileExist, getHomeDirectory)
import FileGoodies (lookupFileInPath, getFileInPath, fileSuffix, stripSuffix)
import FilePath ( FilePath, (</>), (<.>), addTrailingPathSeparator
, dropFileName, joinPath, normalise, splitDirectories
, splitExtension, splitFileName, splitSearchPath
, takeDirectory, takeFileName
import IO
import PropertyFile
import System
import Directory ( getHomeDirectory )
import FilePath ( (</>) )
-- Compiler and run-time environment name and version
-- if you do not use other functions but
-- if-then-else, and the _Prelude_ functions
-- (<), (>), (<=), (>=), (==)
-- directly on the following constants,
-- the compiler might be able to eliminate
-- them at compile time.
--- The name of the Curry compiler (e.g., "pakcs" or "kics2").
curryCompiler :: String
curryCompiler external
......@@ -92,407 +58,11 @@ baseVersion external
installDir :: FilePath
installDir external
-- retrieving user specified options from rc file
--- The name of the file specifying configuration parameters of the
--- current distribution. This file must have the usual format of
--- property files (see description in module PropertyFile).
--- current distribution.
--- This file must have the usual format of property files.
rcFileName :: IO String
rcFileName = getHomeDirectory >>= return . (</> rcFile)
where rcFile = '.' : curryCompiler ++ "rc"
--- Returns the current configuration parameters of the distribution.
--- This action yields the list of pairs (var,val).
rcFileContents :: IO [(String,String)]
rcFileContents = rcFileName >>= readPropertyFile
--- Look up a specific configuration variable as specified by user in his rc file.
--- Uppercase/lowercase is ignored for the variable names.
getRcVar :: String -> IO (Maybe String)
getRcVar var = getRcVars [var] >>= return . head
--- Look up configuration variables as specified by user in his rc file.
--- Uppercase/lowercase is ignored for the variable names.
getRcVars :: [String] -> IO [Maybe String]
getRcVars vars = do
rcs <- rcFileContents
return (map (flip lookup (map (\ (a, b) -> (map toLower a, b)) rcs))
(map (map toLower) vars))
--- Functions for handling file names of Curry modules
type ModuleIdent = String
--- Split the `FilePath` of a module into the directory prefix and the
--- `FilePath` corresponding to the module name.
--- For instance, the call `splitModuleFileName "Data.Set" "lib/Data/Set.curry"`
--- evaluates to `("lib", "Data/Set.curry")`.
--- This can be useful to compute output directories while retaining the
--- hierarchical module structure.
splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath)
splitModuleFileName mid fn = case splitModuleIdentifiers mid of
[_] -> splitFileName fn
ms -> let (base, ext) = splitExtension fn
dirs = splitDirectories base
(pre , suf) = splitAt (length dirs - length ms) dirs
path = if null pre then ""
else addTrailingPathSeparator (joinPath pre)
in (path, joinPath suf <.> ext)
--- Split up the components of a module identifier. For instance,
--- `splitModuleIdentifiers "Data.Set"` evaluates to `["Data", "Set"]`.
splitModuleIdentifiers :: ModuleIdent -> [String]
splitModuleIdentifiers = split (=='.')
--- Join the components of a module identifier. For instance,
--- `joinModuleIdentifiers ["Data", "Set"]` evaluates to `"Data.Set"`.
joinModuleIdentifiers :: [String] -> ModuleIdent
joinModuleIdentifiers = foldr1 combine
where combine xs ys = xs ++ '.' : ys
--- Strips the suffix ".curry" or ".lcurry" from a file name.
stripCurrySuffix :: String -> String
stripCurrySuffix s =
if fileSuffix s `elem` ["curry","lcurry"]
then stripSuffix s
else s
--- A module path consists of a directory prefix (which can be omitted)
--- and a module name (which can be hierarchical). For instance, the
--- following strings are module paths in Unix-based systems:
--- HTML
--- Data.Number.Int
--- curry/Data.Number.Int
type ModulePath = String
--- Transforms a hierarchical module name into a path name, i.e.,
--- replace the dots in the name by directory separator chars.
modNameToPath :: ModuleIdent -> String
modNameToPath = foldr1 (</>) . split (=='.')
--- Name of the sub directory where auxiliary files (.fint, .fcy, etc)
--- are stored.
currySubdir :: FilePath
currySubdir = ".curry"
--- Transforms a path to a module name into a file name
--- by adding the `currySubDir` to the path and transforming
--- a hierarchical module name into a path.
--- For instance, `inCurrySubdir "mylib/Data.Char"` evaluates to
--- `"mylib/.curry/Data/Char"`.
inCurrySubdir :: FilePath -> FilePath
inCurrySubdir filename =
let (base,file) = splitFileName filename
in base </> currySubdir </> modNameToPath file
--- Transforms a file name by adding the currySubDir to the file name.
--- This version respects hierarchical module names.
inCurrySubdirModule :: ModuleIdent -> FilePath -> FilePath
inCurrySubdirModule m fn = let (dirP, modP) = splitModuleFileName m fn
in dirP </> currySubdir </> modP
--- Transforms a directory name into the name of the corresponding
--- sub directory containing auxiliary files.
addCurrySubdir :: FilePath -> FilePath
addCurrySubdir dir = dir </> currySubdir
--- finding files in correspondence to compiler load path
--- Returns the current path (list of directory names) of the
--- system libraries.
sysLibPath :: [String]
sysLibPath = case curryCompiler of
"pakcs" -> [installDir </> "lib"]
"kics" -> [installDir </> "src" </> "lib"]
"kics2" -> [installDir </> "lib"]
_ -> error "Distribution.sysLibPath: unknown curryCompiler"
--- Returns the current path (list of directory names) that is
--- used for loading modules w.r.t. a given module path.
--- The directory prefix of the module path (or "." if there is
--- no such prefix) is the first element of the load path and the
--- remaining elements are determined by the environment variable
--- CURRYRPATH and the entry "libraries" of the system's rc file.
getLoadPathForModule :: ModulePath -> IO [String]
getLoadPathForModule modpath = do
mblib <- getRcVar "libraries"
let fileDir = dropFileName modpath
if curryCompiler `elem` ["pakcs","kics","kics2"] then
do currypath <- getEnviron "CURRYPATH"
let llib = maybe [] (\l -> if null l then [] else splitSearchPath l)
return $ (fileDir : (if null currypath
then []
else splitSearchPath currypath) ++
llib ++ sysLibPath)
else error "Distribution.getLoadPathForModule: unknown curryCompiler"
--- Returns a directory name and the actual source file name for a module
--- by looking up the module source in the current load path.
--- If the module is hierarchical, the directory is the top directory
--- of the hierarchy.
--- Returns Nothing if there is no corresponding source file.
lookupModuleSourceInLoadPath :: ModulePath -> IO (Maybe (String,String))
lookupModuleSourceInLoadPath modpath = do
loadpath <- getLoadPathForModule modpath
lookupModuleSource loadpath modpath
--- Returns a directory name and the actual source file name for a module
--- by looking up the module source in the load path provided as the
--- first argument.
--- If the module is hierarchical, the directory is the top directory
--- of the hierarchy.
--- Returns Nothing if there is no corresponding source file.
lookupModuleSource :: [String] -> String -> IO (Maybe (String,String))
lookupModuleSource loadpath mod = lookupSourceInPath loadpath
fn = takeFileName mod
fnlcurry = modNameToPath fn ++ ".lcurry"
fncurry = modNameToPath fn ++ ".curry"
lookupSourceInPath [] = return Nothing
lookupSourceInPath (dir:dirs) = do
lcurryExists <- doesFileExist (dir </> fnlcurry)
if lcurryExists then return (Just (dir, dir </> fnlcurry)) else do
curryExists <- doesFileExist (dir </> fncurry)
if curryExists then return (Just (dir, dir </> fncurry))
else lookupSourceInPath dirs
-- calling the front end
--- Data type for representing the different target files that can be produced
--- by the front end of the Curry compiler.
--- @cons FCY - FlatCurry file ending with .fcy
--- @cons TFCY - Typed FlatCurry file ending with .tfcy
--- @cons FINT - FlatCurry interface file ending with .fint
--- @cons ACY - AbstractCurry file ending with .acy
--- @cons UACY - Untyped (without type checking) AbstractCurry file ending with .uacy
--- @cons HTML - colored HTML representation of source program
--- @cons CY - source representation employed by the frontend
--- @cons TOKS - token stream of source program
--- @cons TAFC - type-annotated Flat Curry file ending with .tafcy
data FrontendTarget = FCY | TFCY | FINT | ACY | UACY | HTML | CY | TOKS | TAFCY
deriving Eq
--- Abstract data type for representing parameters supported by the front end
--- of the Curry compiler.
-- The parameters are of the form
-- FrontendParams Quiet Extended Cpp NoOverlapWarn FullPath HtmlDir LogFile Specials
-- where
-- Quiet - work silently
-- Extended - support extended Curry syntax
-- Cpp - enable conditional compiling
-- Definitions - definitions for conditional compiling
-- OverlapWarn - warn for overlapping rules
-- FullPath dirs - the complete list of directory names for loading modules
-- HtmlDir file - output directory (only relevant for HTML target)
-- LogFile file - store all output (including errors) of the front end in file
-- Targets - additional targets for the front end
-- Specials - additional special parameters (use with care!)
data FrontendParams =
FrontendParams Bool
[(String, Int)]
(Maybe [String])
(Maybe String)
(Maybe String)
--- The default parameters of the front end.
defaultParams :: FrontendParams
defaultParams =
FrontendParams False True False defaultDefs True Nothing Nothing Nothing [] ""
defaultDefs = [("__" ++ map toUpper curryCompiler ++ "__",
curryCompilerMajorVersion * 100 + curryCompilerMinorVersion)]
--- The default parameters of the front end as configured by the compiler
--- specific resource configuration file.
rcParams :: IO FrontendParams
rcParams = do
[mbExtended,mbOverlapWarn] <- getRcVars ["curryextensions","warnoverlapping"]
return $ setExtended (mbExtended /= Just "no")
$ setOverlapWarn (mbOverlapWarn /= Just "no")
$ defaultParams
--- Set quiet mode of the front end.
setQuiet :: Bool -> FrontendParams -> FrontendParams
setQuiet s (FrontendParams _ t u v w x y z ts sp) =
FrontendParams s t u v w x y z ts sp
--- Set extended mode of the front end.
setExtended :: Bool -> FrontendParams -> FrontendParams
setExtended s (FrontendParams a _ u v w x y z ts sp) =
FrontendParams a s u v w x y z ts sp
--- Set cpp mode of the front end.
setCpp :: Bool -> FrontendParams -> FrontendParams
setCpp s (FrontendParams a b _ v w x y z ts sp) =
FrontendParams a b s v w x y z ts sp
--- Add cpp definition of the front end.
addDefinition :: (String, Int) -> FrontendParams -> FrontendParams
addDefinition d (FrontendParams a b c ds w x y z ts sp) =
FrontendParams a b c (ds ++ [d]) w x y z ts sp
--- Set cpp definitions of the front end.
setDefinitions :: [(String, Int)] -> FrontendParams -> FrontendParams
setDefinitions s (FrontendParams a b c _ w x y z ts sp) =
FrontendParams a b c s w x y z ts sp
--- Set overlap warn mode of the front end.
setOverlapWarn :: Bool -> FrontendParams -> FrontendParams
setOverlapWarn s (FrontendParams a b c d _ x y z ts sp) =
FrontendParams a b c d s x y z ts sp
--- Set the full path of the front end.
--- If this parameter is set, the front end searches all modules
--- in this path (instead of using the default path).
setFullPath :: [String] -> FrontendParams -> FrontendParams
setFullPath s (FrontendParams a b c d e _ y z ts sp) =
FrontendParams a b c d e (Just s) y z ts sp