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
|
{-# LANGUAGE DeriveFunctor #-}
module Connection where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import qualified Data.Map as Map
;import Data.Map (Map)
import PingMachine
data Status status
= Dormant
| InProgress status
| Established
deriving (Show,Eq,Ord,Functor)
data Policy
= RefusingToConnect
| OpenToConnect
| TryingToConnect
deriving (Eq,Ord,Show)
data Connection status = Connection
{ connStatus :: STM (Status status)
, connPolicy :: STM Policy
, connPingLogic :: PingMachine
}
deriving Functor
data Manager status k = Manager
{ setPolicy :: k -> Policy -> IO ()
, connections :: STM (Map k (Connection status))
, stringToKey :: String -> Maybe k
, showProgress :: status -> String
, showKey :: k -> String
}
showStatus :: Manager status k -> Status status -> String
showStatus mgr Dormant = "dormant"
showStatus mgr Established = "established"
showStatus mgr (InProgress s) = "in progress ("++showProgress mgr s++")"
addManagers :: (Ord kA, Ord kB) =>
Manager statusA kA
-> Manager statusB kB
-> Manager (Either statusA statusB) (Either kA kB)
addManagers mgrA mgrB = Manager
{ setPolicy = either (setPolicy mgrA) (setPolicy mgrB)
, connections = do
as <- Map.toList <$> connections mgrA
bs <- Map.toList <$> connections mgrB
return $ Map.fromList $ map (Left *** fmap Left) as ++ map (Right *** fmap Right) bs
, stringToKey = \str -> Left <$> stringToKey mgrA str
<|> Right <$> stringToKey mgrB str
, showProgress = either (showProgress mgrA) (showProgress mgrB)
, showKey = either (showKey mgrA) (showKey mgrB)
}
|
