State.hs 7.99 KB
Newer Older
1
2
{-# OPTIONS_GHC -fno-warn-orphans #-}

Valentin Reis's avatar
Valentin Reis committed
3
4
5
6
7
-- |
-- Module      : NRM.Types.State
-- Copyright   : (c) UChicago Argonne, 2019
-- License     : BSD3
-- Maintainer  : fre@freux.fr
Valentin Reis's avatar
wip    
Valentin Reis committed
8
module NRM.Types.State
Valentin Reis's avatar
Valentin Reis committed
9
  ( NRMState (..),
10
    ExtraPassiveSensor (..),
Valentin Reis's avatar
Valentin Reis committed
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

    -- * Useful maps
    cmdIDMap,
    pidMap,
    awaitingCmdIDMap,

    -- * lookups
    lookupProcess,

    -- * Rendering views
    showSliceList,
    showSlices,

    -- * Lenses
    _cmdID,
    _sliceID,
Valentin Reis's avatar
wip    
Valentin Reis committed
27
28
29
  )
where

Valentin Reis's avatar
Valentin Reis committed
30
import Control.Lens
31
import Data.Aeson hiding ((.=))
32
import Data.Coerce
Valentin Reis's avatar
wip    
Valentin Reis committed
33
import Data.Data
34
import Data.Generics.Labels ()
Valentin Reis's avatar
wip    
Valentin Reis committed
35
import Data.JSON.Schema
Valentin Reis's avatar
Valentin Reis committed
36
import Data.Map as M
Valentin Reis's avatar
wip    
Valentin Reis committed
37
import Data.MessagePack
38
import Data.Scientific
Valentin Reis's avatar
wip    
Valentin Reis committed
39
import LensMap.Core
40
import qualified NRM.Types.Actuator as A
Valentin Reis's avatar
Valentin Reis committed
41
import NRM.Types.Cmd
Valentin Reis's avatar
Valentin Reis committed
42
import NRM.Types.CmdID as CmdID
43
import qualified NRM.Types.Configuration as Cfg
Valentin Reis's avatar
Valentin Reis committed
44
import NRM.Types.Controller
45
import NRM.Types.MemBuffer
Valentin Reis's avatar
Valentin Reis committed
46
import NRM.Types.Process as P
47
import NRM.Types.Sensor as S
Valentin Reis's avatar
Valentin Reis committed
48
import NRM.Types.Slice as C
Valentin Reis's avatar
wip    
Valentin Reis committed
49
import NRM.Types.Topology
50
import NRM.Types.Units
Valentin Reis's avatar
wip    
Valentin Reis committed
51
import Protolude
52
import System.Process.Typed
53
54
55
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
Valentin Reis's avatar
wip    
Valentin Reis committed
56
57
58

data NRMState
  = NRMState
59
60
61
      { pus :: M.Map PUID PU,
        cores :: M.Map CoreID Core,
        packages :: M.Map PackageID Package,
Valentin Reis's avatar
Valentin Reis committed
62
        slices :: Map SliceID Slice,
63
        controller :: Maybe Controller,
64
        extraStaticActuators :: Map Text Cfg.ExtraActuator,
65
        extraStaticPassiveSensors :: Map Text ExtraPassiveSensor
Valentin Reis's avatar
wip    
Valentin Reis committed
66
      }
67
  deriving (Show, Generic, MessagePack, ToJSON, FromJSON)
Valentin Reis's avatar
wip    
Valentin Reis committed
68

69
70
71
72
73
74
75
76
77
78
79
type Parser = Parsec Void Text

sc :: Parser ()
sc =
  L.space
    space1 -- (2)
    (L.skipLineComment "//") -- (3)
    (L.skipBlockComment "/*" "*/") -- (4)

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
80

81
instance HasLensMap (Text, Cfg.ExtraActuator) A.ActuatorKey A.Actuator where
82
  lenses (actuatorID, _) =
83
    M.singleton
84
85
86
87
88
      (A.ExtraActuatorKey actuatorID)
      ( ScopedLens
          (_2 . lens getter setter)
      )
    where
89
      getter :: Cfg.ExtraActuator -> A.Actuator
90
      getter (coerce -> extraActuator) = A.Actuator
91
92
93
94
95
96
97
        { actions = Cfg.actions extraActuator,
          referenceAction = Cfg.referenceAction extraActuator,
          go = \value ->
            runProcess_ $
              System.Process.Typed.proc
                (toS $ Cfg.actuatorBinary extraActuator)
                ((toS <$> Cfg.actuatorArguments extraActuator) <> [show value])
98
        }
99
100
      setter :: Cfg.ExtraActuator -> A.Actuator -> Cfg.ExtraActuator
      setter oldExtraActuator actuator = coerce $
101
        oldExtraActuator &~ do
102
103
          #referenceAction .= A.referenceAction actuator
          #actions .= A.actions actuator
104
105
106
107
108
109

data ExtraPassiveSensor
  = ExtraPassiveSensor
      { extraPassiveSensor :: Cfg.ExtraPassiveSensor,
        lastRead :: Maybe (Time, Double),
        frequency :: Frequency,
110
        history :: MemBuffer
111
112
113
      }
  deriving (Eq, Show, Generic, MessagePack, ToJSON, FromJSON)

114
115
116
117
118
119
instance
  HasLensMap
    (Text, ExtraPassiveSensor)
    PassiveSensorKey
    PassiveSensor
  where
120
  lenses (sensorID, _) =
121
    M.singleton
122
123
124
125
126
127
128
129
130
131
      (S.ExtraPassiveSensorKey sensorID)
      ( ScopedLens
          (_2 . lens getter setter)
      )
    where
      getter :: ExtraPassiveSensor -> S.PassiveSensor
      getter ExtraPassiveSensor {..} =
        S.PassiveSensor
          { passiveMeta = S.SensorMeta
              { tags = Cfg.tags extraPassiveSensor,
132
                range = Cfg.toInterval $ Cfg.range extraPassiveSensor,
133
134
                lastReferenceMeasurements = history,
                last = lastRead,
135
                cumulative = Cfg.sensorBehavior extraPassiveSensor
136
137
138
              },
            frequency = frequency,
            perform =
139
140
              -- this megaparsec-based code might be given a module and improved
              -- if/when the need arises
141
142
143
144
145
146
147
148
149
150
151
152
              fmap toRealFloat
                . parseMaybe (lexeme L.scientific)
                . toS
                <$> readProcessStdout_
                  ( System.Process.Typed.proc
                      (toS $ Cfg.sensorBinary extraPassiveSensor)
                      (toS <$> Cfg.sensorArguments extraPassiveSensor)
                  )
          }
      setter :: ExtraPassiveSensor -> S.PassiveSensor -> ExtraPassiveSensor
      setter p passiveSensor =
        p &~ do
153
154
          #extraPassiveSensor . #range
            .= Cfg.toRange (passiveSensor ^. S._meta . #range)
155
156
          #history .= passiveSensor ^. S._meta . #lastReferenceMeasurements
          #lastRead .= passiveSensor ^. S._meta . #last
157
158

instance HasLensMap NRMState A.ActuatorKey A.Actuator where
Valentin Reis's avatar
wip    
Valentin Reis committed
159
160
  lenses s =
    mconcat
161
      [ addPath #packages <$> lenses (packages s),
Valentin Reis's avatar
Valentin Reis committed
162
        addPath #slices <$> lenses (slices s),
163
        addPath #extraStaticActuators <$> lenses (extraStaticActuators s)
Valentin Reis's avatar
wip    
Valentin Reis committed
164
165
166
167
168
      ]

instance HasLensMap NRMState ActiveSensorKey ActiveSensor where
  lenses s =
    mconcat
169
      [ addPath #slices <$> lenses (slices s)
Valentin Reis's avatar
wip    
Valentin Reis committed
170
171
172
173
174
      ]

instance HasLensMap NRMState PassiveSensorKey PassiveSensor where
  lenses s =
    mconcat
175
176
      [ addPath #packages <$> lenses (packages s),
        addPath #extraStaticPassiveSensors <$> lenses (extraStaticPassiveSensors s)
Valentin Reis's avatar
wip    
Valentin Reis committed
177
178
      ]

Valentin Reis's avatar
wip    
Valentin Reis committed
179
180
181
182
183
instance JSONSchema NRMState where
  schema _ = schema (Proxy :: Proxy Text)

showSliceList :: [(SliceID, Slice)] -> Text
showSliceList l =
Valentin Reis's avatar
Valentin Reis committed
184
185
  mconcat $
    l <&> \(sliceID, Slice {..}) ->
186
      "slice: ID " <> C.toText sliceID <> "\n" <> mconcat (descCmd <$> M.toList cmds)
Valentin Reis's avatar
wip    
Valentin Reis committed
187
  where
Valentin Reis's avatar
wip    
Valentin Reis committed
188
    descCmd (cmdID, cmdCore -> CmdCore {..}) =
Valentin Reis's avatar
Valentin Reis committed
189
190
191
      " command: ID " <> CmdID.toText cmdID
        <> descSpec cmdPath arguments
        <> "\n"
192
193
194
    descSpec (Command cmd) args =
      " : " <> toS cmd <> " " <> (mconcat . intersperse " " $ showArg <$> args)
    showArg (Arg a) = a
Valentin Reis's avatar
wip    
Valentin Reis committed
195
196
197
198

-- | Renders a textual view of running slices
showSlices :: NRMState -> Text
showSlices NRMState {..} =
Valentin Reis's avatar
Valentin Reis committed
199
  showSliceList $ M.toList slices
Valentin Reis's avatar
wip    
Valentin Reis committed
200

201
lookupProcess :: ProcessID -> NRMState -> Maybe (CmdID, Cmd, SliceID, Slice)
202
lookupProcess cmdID st = M.lookup cmdID (pidMap st)
203

Valentin Reis's avatar
wip    
Valentin Reis committed
204
-- | NRM state map view by ProcessID.
205
pidMap :: NRMState -> M.Map ProcessID (CmdID, Cmd, SliceID, Slice)
Valentin Reis's avatar
Valentin Reis committed
206
pidMap s = mconcat $ M.toList (slices s) <&> mkMap
Valentin Reis's avatar
wip    
Valentin Reis committed
207
  where
208
    mkMap :: forall c. (c, Slice) -> M.Map ProcessID (CmdID, Cmd, c, Slice)
Valentin Reis's avatar
wip    
Valentin Reis committed
209
    mkMap x@(_, c) =
210
      M.fromList $
Valentin Reis's avatar
Valentin Reis committed
211
        zip
212
213
          (pid <$> M.elems (cmds c))
          (M.toList (cmds c) <&> mkTriple x)
Valentin Reis's avatar
wip    
Valentin Reis committed
214

Valentin Reis's avatar
Valentin Reis committed
215
mkTriple :: (c, d) -> (a, b) -> (a, b, c, d)
Valentin Reis's avatar
wip    
Valentin Reis committed
216
mkTriple (cid, c) (cmid, cm) = (cmid, cm, cid, c)
Valentin Reis's avatar
wip    
Valentin Reis committed
217

218
lookupCmd :: CmdID -> NRMState -> Maybe (Cmd, SliceID, Slice)
219
lookupCmd cmdID st = M.lookup cmdID (cmdIDMap st)
220

221
-- | NRM state map view by cmdID of "running" commands.
222
cmdIDMap :: NRMState -> M.Map CmdID (Cmd, SliceID, Slice)
Valentin Reis's avatar
wip    
Valentin Reis committed
223
224
225
cmdIDMap = mkCmdIDMap cmds

-- | NRM state map view by cmdID of "awaiting" commands.
226
awaitingCmdIDMap :: NRMState -> M.Map CmdID (CmdCore, SliceID, Slice)
Valentin Reis's avatar
wip    
Valentin Reis committed
227
228
awaitingCmdIDMap = mkCmdIDMap awaiting

Valentin Reis's avatar
Valentin Reis committed
229
230
mkCmdIDMap ::
  Ord k =>
231
  (Slice -> M.Map k a) ->
Valentin Reis's avatar
Valentin Reis committed
232
  NRMState ->
233
  M.Map k (a, SliceID, Slice)
Valentin Reis's avatar
Valentin Reis committed
234
mkCmdIDMap accessor s = mconcat $ M.toList (slices s) <&> mkMap
Valentin Reis's avatar
wip    
Valentin Reis committed
235
236
  where
    mkMap x@(_, c) =
237
      M.fromList $
Valentin Reis's avatar
Valentin Reis committed
238
        zip
239
240
          (M.keys $ accessor c)
          (M.elems (accessor c) <&> mk x)
Valentin Reis's avatar
Valentin Reis committed
241
    mk :: (b, c) -> a -> (a, b, c)
Valentin Reis's avatar
wip    
Valentin Reis committed
242
    mk (cid, c) cm = (cm, cid, c)
Valentin Reis's avatar
wip    
Valentin Reis committed
243

Valentin Reis's avatar
Valentin Reis committed
244
245
-- Lenses
_sliceID :: SliceID -> Lens' NRMState (Maybe Slice)
246
_sliceID sliceID = #slices . at sliceID
Valentin Reis's avatar
Valentin Reis committed
247
248
249
250
251
252

_cmdID :: CmdID -> Lens' NRMState (Maybe Cmd)
_cmdID cmdID = lens getter setter
  where
    getter :: NRMState -> Maybe Cmd
    getter st = lookupCmd cmdID st <&> \(cmd, _, _) -> cmd
Valentin Reis's avatar
wip    
Valentin Reis committed
253
    setter st (Just cmd) =
Valentin Reis's avatar
Valentin Reis committed
254
255
      lookupCmd cmdID st & \case
        Just (_, sliceID, slice) ->
256
          st & _sliceID sliceID ?~ (slice & (#cmds . at cmdID) ?~ cmd)
Valentin Reis's avatar
Valentin Reis committed
257
        Nothing -> st
Valentin Reis's avatar
Valentin Reis committed
258
    setter st Nothing =
Valentin Reis's avatar
wip    
Valentin Reis committed
259
      lookupCmd cmdID st & \case
Valentin Reis's avatar
Valentin Reis committed
260
        Just (_, sliceID, _) ->
Valentin Reis's avatar
Valentin Reis committed
261
          st & _sliceID sliceID %~ mayRemoveSlice
Valentin Reis's avatar
wip    
Valentin Reis committed
262
        Nothing -> st
Valentin Reis's avatar
Valentin Reis committed
263
264
    mayRemoveSlice :: Maybe Slice -> Maybe Slice
    mayRemoveSlice x =
Valentin Reis's avatar
Valentin Reis committed
265
266
      x >>= \slice ->
        if length (cmds slice) == 1
Valentin Reis's avatar
Valentin Reis committed
267
          then Nothing
268
          else Just $ slice & #cmds . at cmdID .~ Nothing