Commit d8ef9ec6 authored by Michael Hanus 's avatar Michael Hanus

Base packaged synched to libs of PAKCS 2.1.0

parent a8e67a81
This diff is collapsed.
This diff is collapsed.
------------------------------------------------------------------------------
--- Library to support network programming with sockets that are addressed
--- by symbolic names. In contrast to raw sockets (see library
--- <code>Socket</code>), this library uses the Curry Port Name Server
--- to provide sockets that are addressed by symbolic names
--- rather than numbers.
---
--- In standard applications, the server side uses the operations
--- <code>listenOn</code> and <code>socketAccept</code> to provide some service
--- on a named socket, and the client side uses the operation
--- <code>connectToSocket</code> to request a service.
---
--- @author Michael Hanus
--- @version February 2008
--- @category general
------------------------------------------------------------------------------
module NamedSocket(Socket,
listenOn, socketAccept, waitForSocketAccept,
connectToSocketRepeat, connectToSocketWait,
sClose, socketName, connectToSocket)
where
import System
import IO(Handle)
import qualified Socket
import CPNS
---------------------------------------------------------------------
-- Server side operations:
--- Abstract type for named sockets.
data Socket = NamedSocket String Socket.Socket
--- Creates a server side socket with a symbolic name.
listenOn :: String -> IO Socket
listenOn socketname = do
(port,socket) <- Socket.listenOnFresh
registerPort socketname port 0
return (NamedSocket socketname socket)
--- Returns a connection of a client to a socket.
--- The connection is returned as a pair consisting of a string identifying
--- the client (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- The handle is both readable and writable.
socketAccept :: Socket -> IO (String,Handle)
socketAccept (NamedSocket _ socket) = Socket.socketAccept socket
--- Waits until a connection of a client to a socket is available.
--- If no connection is available within the time limit, it returns Nothing,
--- otherwise the connection is returned as a pair consisting
--- of a string identifying the client
--- (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- @param socket - a socket
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
waitForSocketAccept (NamedSocket _ socket) = Socket.waitForSocketAccept socket
--- Closes a server socket.
sClose :: Socket -> IO ()
sClose (NamedSocket socketname socket) = do
Socket.sClose socket
unregisterPort socketname
--- Returns a the symbolic name of a named socket.
socketName :: Socket -> String
socketName (NamedSocket socketname _) = socketname
---------------------------------------------------------------------
-- Client side operations:
--- Waits for connection to a Unix socket with a symbolic name.
--- In contrast to <code>connectToSocket</code>, this action waits until
--- the socket has been registered with its symbolic name.
--- @param waittime - the time to wait before retrying (in milliseconds)
--- @param action - I/O action to be executed before each wait cycle
--- @param retries - number of retries before giving up (-1 = retry forever)
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return Nothing (if connection is not possible within the given limits)
--- or (Just h) where h is the handle of the connection
connectToSocketRepeat :: Int -> IO _ -> Int -> String -> IO (Maybe Handle)
connectToSocketRepeat waittime action retries nameAtHost = do
let (name,atHost) = break (=='@') nameAtHost
host = if atHost=="" then "localhost" else tail atHost
-- check whether remote CPNS demon is alive:
alive <- cpnsAlive waittime host
if not alive
then tryAgain
else do -- get remote socket/port numbers:
(snr,_) <- getPortInfo name host
if snr==0
then tryAgain
else Socket.connectToSocket host snr >>= return . Just
where
tryAgain = if retries==0 then return Nothing else do
action
sleep (ms2s waittime)
connectToSocketRepeat waittime action (decr retries) nameAtHost
ms2s n = let mn = n `div` 1000 in if mn==0 then 1 else mn
decr n = if n<0 then n else n-1
--- Waits for connection to a Unix socket with a symbolic name and
--- return the handle of the connection.
--- This action waits (possibly forever) until the socket with the symbolic
--- name is registered.
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return the handle of the connection (connected to the socket nameAtHost)
--- which is both readable and writable
connectToSocketWait :: String -> IO Handle
connectToSocketWait nameAtHost = do
Just hdl <- connectToSocketRepeat 1000 done (-1) nameAtHost
return hdl
--- Creates a new connection to an existing(!) Unix socket with a symbolic
--- name. If the symbolic name is not registered, an error is reported.
--- @param nameAtHost - the symbolic name of the socket
--- (must be either of the form "name@host" or "name"
--- where the latter is a shorthand for "name@localhost")
--- @return the handle of the stream (connected to the socket nameAtHost)
--- which is both readable and writable
connectToSocket :: String -> IO Handle
connectToSocket nameAtHost = do
let (name,atHost) = break (=='@') nameAtHost
host = if atHost=="" then "localhost" else tail atHost
-- get remote port number:
(snr,_) <- getPortInfo name host
if snr==0
then error ("connectToSocket: Socket \""++name++"@"++host++
"\" is not registered!")
else done
Socket.connectToSocket host snr
---------------------------------------------------------------------
------------------------------------------------------------------------------
--- A library to read and update files containing properties in the usual
--- equational syntax, i.e., a property is defined by a line of the form
--- `prop=value` where `prop` starts with a letter.
--- All other lines (e.g., blank lines or lines starting with `#` are
--- considered as comment lines and are ignored.
---
--- @author Michael Hanus
--- @version August 2006
--- @category general
------------------------------------------------------------------------------
module PropertyFile(readPropertyFile,updatePropertyFile) where
import Directory
import IOExts
import Char
--- Reads a property file and returns the list of properties.
--- Returns empty list if the property file does not exist.
readPropertyFile :: String -> IO [(String,String)]
readPropertyFile file = do
pfexists <- doesFileExist file
if pfexists
then do rcs <- readCompleteFile file -- to avoid open file handles
return $ splitEqs . filter (\l->not (null l) && isAlpha (head l))
. lines $ rcs
else return []
where
splitEqs [] = []
splitEqs (eq:eqs) = case break (=='=') eq of
(prop,_:val) -> (prop,val) : splitEqs eqs
_ -> splitEqs eqs
--- Update a property in a property file or add it, if it is not already
--- there.
--- @param file - the name of the property file
--- @param pname - the name of the property
--- @param pvalue - the new value of the property
updatePropertyFile :: String -> String -> String -> IO ()
updatePropertyFile file pname pval = do
props <- readPropertyFile file
if lookup pname props == Nothing
then appendFile file (pname++"="++pval++"\n")
else changePropertyInFile file pname pval
--- Change a property in a property file.
changePropertyInFile :: String -> String -> String -> IO ()
changePropertyInFile file pname pval = do
updateFile (\rcs -> unlines . map changeProp . lines $ rcs) file
where
changeProp l = let (s1,s2) = break (=='=') l
in if null l || not (isAlpha (head l)) || null s2
then l
else if s1==pname then s1++"="++pval else l
--- ----------------------------------------------------------------------------
--- Computing strongly connected components
---
--- Copyright (c) 2000 - 2003, Wolfgang Lux
--- See LICENSE for the full license.
---
--- The function `scc` computes the strongly connected components of a list
--- of entities in two steps. First, the list is topologically sorted
--- "downwards" using the *defines* relation.
--- Then the resulting list is sorted "upwards" using the *uses* relation
--- and partitioned into the connected components. Both relations
--- are computed within this module using the bound and free names of each
--- declaration.
---
--- In order to avoid useless recomputations, the code in the module first
--- decorates the declarations with their bound and free names and a
--- unique number. The latter is only used to provide a trivial ordering
--- so that the declarations can be used as set elements.
---
--- @author Wolfgang Lux
--- @category algorithm
--- ----------------------------------------------------------------------------
module SCC (scc) where
import SetRBT (emptySetRBT, elemRBT, insertRBT)
data Node a b = Node Int [b] [b] a
deriving Eq
cmpNode :: Node a b -> Node a b -> Bool
cmpNode n1 n2 = key n1 < key n2
key :: Node a b -> Int
key (Node k _ _ _) = k
bvs :: Node a b -> [b]
bvs (Node _ bs _ _) = bs
fvs :: Node a b -> [b]
fvs (Node _ _ fs _) = fs
node :: Node a b -> a
node (Node _ _ _ n) = n
--- Computes the strongly connected components of a list
--- of entities. To be flexible, we distinguish the nodes and
--- the entities defined in this node.
---
--- @param defines - maps each node to the entities defined in this node
--- @param uses - maps each node to the entities used in this node
--- @param nodes - the list of nodes which should be sorted into
--- strongly connected components
--- @return the strongly connected components of the list of nodes
scc :: (Eq a, Eq b) =>
(a -> [b]) -- ^ entities defined by node
-> (a -> [b]) -- ^ entities used by node
-> [a] -- ^ list of nodes
-> [[a]] -- ^ strongly connected components
scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..]
where wrap i n = Node i (bvs' n) (fvs' n) n
tsort :: (Eq a, Eq b) => [Node a b] -> [Node a b]
tsort xs = snd (dfs xs (emptySetRBT cmpNode) [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `elemRBT` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' (x : stack')
where
(marks', stack') = dfs (defs x) (x `insertRBT` marks) stack
defs x1 = filter (any (`elem` fvs x1) . bvs) xs
tsort' :: (Eq a, Eq b) => [Node a b] -> [[Node a b]]
tsort' xs = snd (dfs xs (emptySetRBT cmpNode) [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `elemRBT` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' ((x : concat stack') : stack)
where
(marks', stack') = dfs (uses x) (x `insertRBT` marks) []
uses x1 = filter (any (`elem` bvs x1) . fvs) xs
------------------------------------------------------------------------------
--- Library to support network programming with sockets.
--- In standard applications, the server side uses the operations
--- <code>listenOn</code> and <code>socketAccept</code> to provide some service
--- on a socket, and the client side uses the operation
--- <code>connectToSocket</code> to request a service.
---
--- @author Michael Hanus
--- @version February 2008
--- @category general
------------------------------------------------------------------------------
module Socket(Socket, listenOn, listenOnFresh,
socketAccept, waitForSocketAccept, sClose, connectToSocket)
where
import System
import IO(Handle)
--- The abstract type of sockets.
external data Socket
---------------------------------------------------------------------
-- Server side operations:
--- Creates a server side socket bound to a given port number.
listenOn :: Int -> IO Socket
listenOn port = prim_listenOn $# port
prim_listenOn :: Int -> IO Socket
prim_listenOn external
--- Creates a server side socket bound to a free port.
--- The port number and the socket is returned.
listenOnFresh :: IO (Int,Socket)
listenOnFresh external
--- Returns a connection of a client to a socket.
--- The connection is returned as a pair consisting of a string identifying
--- the client (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- The handle is both readable and writable.
socketAccept :: Socket -> IO (String,Handle)
socketAccept s = prim_socketAccept $## s
prim_socketAccept :: Socket -> IO (String,Handle)
prim_socketAccept external
--- Waits until a connection of a client to a socket is available.
--- If no connection is available within the time limit, it returns Nothing,
--- otherwise the connection is returned as a pair consisting
--- of a string identifying the client
--- (the format of this string is implementation-dependent)
--- and a handle to a stream communication with the client.
--- @param socket - a socket
--- @param timeout - milliseconds to wait for input (< 0 : no time out)
waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
waitForSocketAccept s timeout = (prim_waitForSocketAccept $## s) $# timeout
prim_waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle))
prim_waitForSocketAccept external
--- Closes a server socket.
sClose :: Socket -> IO ()
sClose s = prim_sClose $## s
prim_sClose :: Socket -> IO ()
prim_sClose external
---------------------------------------------------------------------
-- Client side operations:
--- Creates a new connection to a Unix socket.
--- @param host - the host name of the connection
--- @param port - the port number of the connection
--- @return the handle of the stream (connected to the port port@host)
--- which is both readable and writable
connectToSocket :: String -> Int -> IO Handle
connectToSocket host port = (prim_connectToSocket $## host) $# port
prim_connectToSocket :: String -> Int -> IO Handle
prim_connectToSocket external
---------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
import Control.Concurrent
import Control.Monad (when)
import Network
import Network.Socket hiding (sClose)
type C_Socket = PrimData Socket
instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket
external_d_C_prim_listenOn i _ _ = toCurry listenOn i
external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket)
external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort
where
listenOnFreshPort :: IO (PortID,Socket)
listenOnFreshPort = do
s <- listenOn (PortNumber aNY_PORT)
p <- Network.socketPort s
return (p,s)
external_d_C_prim_socketAccept :: C_Socket
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle)
external_d_C_prim_socketAccept socket _ _ =
toCurry (\s -> Network.accept s >>= \ (h,s,_) -> return (s,OneHandle h)) socket
external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle))
external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i
wait :: Socket -> Int -> IO (Maybe (String, CurryHandle))
wait s t =
if t < 0
then Network.accept s >>= \ (h, s, _) -> return (Just (s, OneHandle h))
else do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h, s, _) ->
putMVar mv (Just (s, OneHandle h)))
ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000)
>> putMVar mv Nothing)
res <- takeMVar mv
maybe (killThread tacc) (\_ -> killThread ttim) res
return res
-- Like 'threadDelay', but not bounded by an 'Int'
delay :: Integer -> IO ()
delay time = do
let maxWait = min time $ toInteger (maxBound :: Int)
threadDelay $ fromInteger maxWait
when (maxWait /= time) $ delay (time - maxWait)
external_d_C_prim_sClose :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_prim_sClose s _ _ = toCurry sClose s
external_d_C_prim_connectToSocket :: Curry_Prelude.C_String -> Curry_Prelude.C_Int
-> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle
external_d_C_prim_connectToSocket str i _ _ =
toCurry (\ s i -> connectTo s i >>= return . OneHandle) str i
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_listenOn" arity="1">
<library>prim_socket</library>
<entry>prim_listenOn</entry>
</primitive>
<primitive name="listenOnFresh" arity="0">
<library>prim_socket</library>
<entry>prim_listenOnFresh</entry>
</primitive>
<primitive name="prim_socketAccept" arity="1">
<library>prim_socket</library>
<entry>prim_socketAccept</entry>
</primitive>
<primitive name="prim_waitForSocketAccept" arity="2">
<library>prim_socket</library>
<entry>prim_waitForSocketAccept</entry>
</primitive>
<primitive name="prim_sClose" arity="1">
<library>prim_socket</library>
<entry>prim_sClose</entry>
</primitive>
<primitive name="prim_connectToSocket" arity="2">
<library>prim_socket</library>
<entry>prim_connectToSocket</entry>
</primitive>
</primitives>
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment