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
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
------------------------------------------------------------------------------
--- Implementation of a Curry Port Name Server based on raw sockets.
--- It is used to implement the library `Network.NamedPorts` and
--- the library `Ports` for distributed programming with ports.
---
--- @author Michael Hanus
--- @version March 2021
------------------------------------------------------------------------------

module Network.CPNS
  ( registerPort, getPortInfo, unregisterPort
  , cpnsStart, cpnsStop, cpnsStatus, cpnsAlive
  )
 where

import Control.Monad      ( unless )
import Data.List          ( delete )
import System.Environment ( getHostname )
import System.IO

import Data.Time          ( calendarTimeToString, getLocalTime )
import System.Process     ( getPID, system )

import Debug.Profile      ( getProcessInfos, showMemInfo )
import Network.Socket     ( Socket, accept, connectToSocket, listenOn )

import Network.CPNS.Config

--- Type of messages to be processed by the Curry Port Name Server.
---
--- @cons Register name pid sn pn
---       -  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 status and 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
  deriving (Read, Show)

--- 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
                  (\_ -> addLogLn "FAILURE occurred during startup!" >>
                         deleteStartupLockfile >>
                         return Nothing) >>=
             maybe (return ()) (cpnsServer [])
 where
   deleteStartupLockfile = do
     lockfile <- getStartupLockFile
     addLogLn $ "Removing startup lock file \"" ++ lockfile ++ "\"..."
     system $ "/bin/rm -f " ++ lockfile
     return ()

   startup = do
     addLogLn $ "Starting Curry Port Name Server on port " ++
                show cpnsSocket ++ "..."
     socket <- listenOn cpnsSocket
     deleteStartupLockfile
     pid <- getPID
     addLogLn $ "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) <- accept socket
  --addLogLn $ "Connection from "++chost
  serveRequest chost stream
 where
   doIfLocalHost rhost action = do
     hostname <- getHostname
     if rhost `elem` ["localhost","localhost.localdomain",hostname]
        || take 8 rhost == "127.0.0."
      then action
      else do addLogLn $ "Illegal request received from host: " ++ rhost
              cpnsServer regs socket

   serveRequest rhost h = do
     msg <- readMsgLine h
     either
      (\line -> do addLogLn $ "ERROR: Illegal message:\n" ++ line
                   cpnsServer regs socket )
      (\m -> case m of
        Terminate -> doIfLocalHost rhost $ do
          hClose h
          addLogLn "CPNS demon terminated."
        Ping -> do
          hPutStrLn h (show True)
          hClose h
          cpnsServer regs socket
        Register pname pid sn pn -> doIfLocalHost rhost $ do
          (ack, newregs) <- tryRegisterPortName regs pname pid sn pn
          hPutStrLn h (show ack)
          hClose h
          cpnsServer (id $!! newregs) socket
        GetRegister pname -> do
          --addLogLn $ "Request for port name: " ++ pname
          (newregs,pinfo) <- getRegisteredPortName regs pname
          hPutStrLn h (show pinfo)
          hClose h
          cpnsServer (id $!! newregs) socket
        Unregister pname -> doIfLocalHost rhost $ do
          newregs <- unregisterPortName regs pname
          hClose h
          cpnsServer (id $!! newregs) socket
        ShowRegistry -> doIfLocalHost rhost $ do
          newregs <- getAndCleanRegs regs
          meminfo <- getMemInfo regs
          pid     <- getPID
          hPutStrLn h (show (pid,meminfo,newregs))
          hClose h
          cpnsServer (id $!! newregs) socket )
      msg

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 doesProcessExist pid' >>= \pex -> return (not pex)
              else return True
  ctime <- getLocalTime
  addLogLn $ "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
  getMemInfo newregs >>= addLogLn
  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
  addLogLn $ "Unregister port \""++name++"\" at "++calendarTimeToString ctime
  let newregs = filter (\ (n,_,_,_) -> name/=n) regs
  getMemInfo newregs >>= addLogLn
  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 doesProcessExist pid >>= \pex ->
            if pex
            then return (regs,(sn,pn))
            else --addLogLn ("WARNING: Process "++show pid++" not running!") >>
                 return (delete (head nameregs) regs, (0,0))
       else return (regs,(sn,pn))

-- Returns the registration list but delete a registration
-- if the corresponding server process does not exist.
getAndCleanRegs :: [(String,Int,Int,Int)] -> IO [(String,Int,Int,Int)]
getAndCleanRegs regs = do
  newreglist <- mapM checkAndShow regs
  return (concat newreglist)
 where
  checkAndShow reg@(_,pid,_,_) = do
    pidexist <- doesProcessExist pid
    return $ if pidexist then [reg] else []

-- Returns memory status information of current CPNS demon process as string.
getMemInfo :: [(String,Int,Int,Int)] -> IO String
getMemInfo regs = do
  pinfos <- getProcessInfos
  return $ "NumRegs: " ++ show (length regs) ++ ", " ++ showMemInfo pinfos

-- Tests whether a process with a given pid is running.
doesProcessExist :: Int -> IO Bool
doesProcessExist 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 :: Read a => Handle -> IO (Either String a)
readMsgLine handle = do
  line <- hGetLine handle
  case reads 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 host
  if not alive
   then error $ timeOutMessage host
   else action

timeOutMessage :: String -> String
timeOutMessage host =
  "Curry port name server at host \"" ++ host ++
  "\" is not reachable (timeout after " ++ show cpnsTimeOut ++ " ms)!"

sendToLocalCPNS :: CPNSMessage -> IO ()
sendToLocalCPNS msg = doIfAlive "localhost" $ do
  h <- connectToSocket "localhost" cpnsSocket
  hPutStrLn h (show msg)
  hClose h

--- Shows all registered ports at the local CPNS demon (in its logfile).
cpnsStatus :: IO ()
cpnsStatus = do
  (pid,meminfo,regs) <- cpnsTryGetAnswer "localhost" ShowRegistry
  putStrLn $ "CPNSD PID: " ++ show (pid :: Int)
  putStrLn $ "Memory information:\n" ++ meminfo
  putStrLn "Currently registered port names:"
  putStrLn $ unlines $ map showReg regs

showReg :: (String,Int,Int,Int) -> String
showReg (n,pid,sn,pn) = n ++ ": pid " ++ show pid ++
                        " / socket " ++ show sn ++ " / number " ++ show pn

--- 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 :: Read a => String -> CPNSMessage -> IO a
cpnsTryGetAnswer host msg = catch tryGetAnswer connectError
 where
  tryGetAnswer = do
    h <- connectToSocket host cpnsSocket
    hPutStrLn h (show msg)
    hFlush h
    ready <- hWaitForInput h cpnsTimeOut
    if ready
     then do
       answer <- readMsgLine h
       hClose h
       either (\line -> error $ "cpnsTryGetAnswer: Illegal answer: " ++ line)
              return
              answer
     else error $ timeOutMessage host

  connectError _ = error $ "Curry port name server at host \""++host++
                           "\" is not reachable!"

--- Registers a symbolic port at the local host.
--- The symbolic name, the socket number, and the port number are passed
--- as arguments.
registerPort :: String -> Int -> Int -> IO ()
registerPort pname sn pn = do
  startCPNSDIfNecessary
  pid <- getPID
  ack <- cpnsTryGetAnswer "localhost" (Register pname pid sn pn)
  if ack then return ()
         else addLogLn ("WARNING: Port name '"++pname++"' already registered!")

--- Gets the information about a symbolic port (first argument)
--- at some host (second argument).
--- If there is no registration, `(0,0)` is returned, otherwise a pair
--- consisting of a socket and port number.
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, i.e.,
--- reacts on `Ping` message.
cpnsAlive :: String -> IO Bool
cpnsAlive host = catch tryPingCPNS (\_ -> return False)
 where
  tryPingCPNS = do
    h <- connectToSocket host cpnsSocket
    hPutStrLn h (show Ping)
    hFlush h
    answer <- hWaitForInput h cpnsTimeOut
    hClose h
    return answer

--- Starts the CPNS demon at localhost if it is not already running:
startCPNSDIfNecessary :: IO ()
startCPNSDIfNecessary = do
  alive <- cpnsAlive "localhost"
  unless alive $ do
    cpnsbin <- getCPNSD
    system $ cpnsbin ++ " start"
    return ()

{-
Testing:

Network.CPNS> registerPort "xxx" 42 2
Network.CPNS> getPortInfo "xxx" "localhost"
(42,2)

-}