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

------------------------------------------------------------------------
--- Implementation of the analysis computations on the server side
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version December 2018
------------------------------------------------------------------------

-- analysis computations on the server side

module CASS.ServerFunctions where

import FlatCurry.Types   (QName)
import FlatCurry.Goodies (progImports)
import IO(Handle(..),hClose,hFlush,hGetLine,hPutStrLn,hWaitForInput,hWaitForInputs)
import ReadShowTerm(readQTerm,showQTerm)
import System(system,sleep)
import Directory(doesFileExist,getModificationTime)
import Maybe(fromMaybe)
import List(delete)
import Time(ClockTime)
import XML(showXmlDoc,xml)

import Analysis.Logging(debugMessage)
import Analysis.Types
import Analysis.ProgInfo
import CASS.Dependencies
import CASS.Configuration(waitTime)

data WorkerMessage = Task String String | ChangePath String | StopWorker


-- Master loop for communication with workers
-- Argument 1: handles for workers that are currently free
-- Argument 2: handles for workers that are currently busy
-- Argument 3: the analysis name
-- Argument 4: the name of the main module
-- Argument 5: the modules to be analyzed (with their dependencies)
-- Argument 6: names of modules that are ready be to analyzed (since their
--             imports are already analyzed)
-- Result: Nothing (in case of successful work) or (Just <error>)
masterLoop :: [Handle] -> [Handle] -> String -> String
           -> [(String,[String])] -> [String] -> IO (Maybe String)
masterLoop _ [] _ _ [] [] = do
  debugMessage 2 "Master loop: terminated"
  return Nothing

masterLoop _ (b:busyWorker) ananame mainModule [] [] = do
  debugMessage 2 "Master loop: waiting for worker result"
  inputHandle <- hWaitForInputs (b:busyWorker) waitTime
  if inputHandle/=0
    then return (Just "No input from any worker received")
    else do
      let handle =  b
      input <- hGetLine handle
      debugMessage 2 ("Master loop: got message: "++input)
      let Task ananame2 moduleName2 = readQTerm input
      if ananame==ananame2 && moduleName2==mainModule
        then return Nothing
        else return (Just "Received analysis does not match requested analysis")

masterLoop idleWorker busyWorker ananame mainModule
           modulesToDo@(_:_) [] = do
  debugMessage 3 ("Master loop: modules to do: "++(showQTerm modulesToDo))
  let modulesToDo2 = filter ((not . null) . snd) modulesToDo
      waitList     = map fst (filter (null . snd) modulesToDo)
  if null waitList
    then do
      debugMessage 2 "Master loop: waiting for workers to finish"
      inputHandle <- hWaitForInputs busyWorker waitTime
      if inputHandle<0
        then return (Just "No input from any worker received")
        else do
          let handle =  busyWorker !! inputHandle
          input <- hGetLine handle
          debugMessage 2 ("Master loop: got message: "++input)
          let Task ananame2 moduleName2 = readQTerm input
          if ananame==ananame2
            then do
              let modulesToDo3 = reduceDependencies modulesToDo2 [moduleName2]
                  busyWorker2= deleteIndex inputHandle busyWorker
              masterLoop (handle:idleWorker) busyWorker2 ananame
                         mainModule modulesToDo3 waitList
            else
             return
              (Just "Received analysis does not match requested analysis type")
    else masterLoop idleWorker busyWorker ananame mainModule modulesToDo2
                    waitList

masterLoop (handle:idleWorker) busyWorker ananame mainModule modulesToDo
           (modName:waitList) = do
  debugMessage 2 "Master loop: worker available, send task to a worker..."
  let newTask = showQTerm (Task ananame modName)
  hPutStrLn handle newTask
  hFlush handle
  debugMessage 2 ("Master loop: send message: "++newTask)
  masterLoop idleWorker (handle:busyWorker) ananame mainModule
             modulesToDo waitList

masterLoop [] busyWorker ananame mainModule modulesToDo
           waits@(modName:waitList) = do
  debugMessage 2 $ "Waiting for worker to analyze modules: "++show waits
  inputHandle <- hWaitForInputs busyWorker waitTime
  if inputHandle<0
    then return (Just "No input from any worker received")
    else do
      let handle = busyWorker !! inputHandle
      input <- hGetLine handle
      debugMessage 2 ("Master loop: got message: "++input)
      let Task _ finishedmodule = readQTerm input
          newTask = showQTerm (Task ananame modName)
      hPutStrLn handle newTask
      hFlush handle
      debugMessage 2 ("Master loop: send message: "++newTask)
      let modulesToDo2 = reduceDependencies modulesToDo [finishedmodule]
      masterLoop [] busyWorker ananame mainModule modulesToDo2 waitList

deleteIndex :: Int -> [a] -> [a]
deleteIndex _ [] = []
deleteIndex n (x:xs) | n==0      = xs
                     | otherwise = x : deleteIndex (n-1) xs

-----------------------------------------------------------------------