Cmd.hs 6.05 KB
Newer Older
Valentin Reis's avatar
wip    
Valentin Reis committed
1
{-# LANGUAGE DerivingVia #-}
Valentin Reis's avatar
Valentin Reis committed
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
Valentin Reis's avatar
wip    
Valentin Reis committed
3

Valentin Reis's avatar
Valentin Reis committed
4
5
6
7
8
-- |
-- Module      : NRM.Types.Cmd
-- Copyright   : (c) UChicago Argonne, 2019
-- License     : BSD3
-- Maintainer  : fre@freux.fr
Valentin Reis's avatar
wip    
Valentin Reis committed
9
module NRM.Types.Cmd
Valentin Reis's avatar
Valentin Reis committed
10
  ( Cmd (..),
11
    mkCmd,
Valentin Reis's avatar
Valentin Reis committed
12
13
    CmdCore (..),
    CmdSpec (..),
14
    mkCmdSpec,
Valentin Reis's avatar
Valentin Reis committed
15
16
17
18
19
20
21
    registerPID,
    TaskID (..),
    Command (..),
    Arg (..),
    Env (..),
    wrapCmd,
    addDownstreamCmdClient,
Valentin Reis's avatar
Valentin Reis committed
22
    addDownstreamThreadClient,
Valentin Reis's avatar
wip    
Valentin Reis committed
23
24
25
  )
where

Valentin Reis's avatar
wip    
Valentin Reis committed
26
import Control.Lens
Valentin Reis's avatar
Valentin Reis committed
27
28
import qualified Data.Aeson as A
import Data.Coerce
29
import Data.Generics.Labels ()
Valentin Reis's avatar
wip    
Valentin Reis committed
30
import Data.JSON.Schema
Valentin Reis's avatar
Valentin Reis committed
31
import Data.Map as M
Valentin Reis's avatar
wip    
Valentin Reis committed
32
33
import Data.MessagePack
import Data.String (IsString (..))
Valentin Reis's avatar
wip    
Valentin Reis committed
34
import Dhall hiding (field)
Valentin Reis's avatar
Valentin Reis committed
35
import LensMap.Core
Valentin Reis's avatar
wip    
Valentin Reis committed
36
37
38
import NRM.Classes.Messaging
import NRM.Orphans.ExitCode ()
import NRM.Orphans.UUID ()
Valentin Reis's avatar
Valentin Reis committed
39
import NRM.Types.Actuator
Valentin Reis's avatar
Valentin Reis committed
40
import NRM.Types.CmdID
Valentin Reis's avatar
Valentin Reis committed
41
42
import NRM.Types.DownstreamCmd
import NRM.Types.DownstreamCmdID
Valentin Reis's avatar
Valentin Reis committed
43
44
import NRM.Types.DownstreamThread
import NRM.Types.DownstreamThreadID
Valentin Reis's avatar
wip    
Valentin Reis committed
45
import NRM.Types.Manifest as Manifest
Valentin Reis's avatar
Valentin Reis committed
46
import qualified NRM.Types.Manifest as Ma
47
import NRM.Types.MemBuffer as MemBuffer
Valentin Reis's avatar
wip    
Valentin Reis committed
48
import NRM.Types.Process
Valentin Reis's avatar
Valentin Reis committed
49
import NRM.Types.Sensor
Valentin Reis's avatar
Valentin Reis committed
50
import NRM.Types.Units
Valentin Reis's avatar
wip    
Valentin Reis committed
51
52
import qualified NRM.Types.UpstreamClient as UC
import Protolude
Valentin Reis's avatar
Valentin Reis committed
53
import System.Process.Typed
Valentin Reis's avatar
wip    
Valentin Reis committed
54
55
56

data CmdSpec
  = CmdSpec
Valentin Reis's avatar
Valentin Reis committed
57
      { cmd :: Command,
58
        args :: [Arg],
Valentin Reis's avatar
Valentin Reis committed
59
        env :: Env
Valentin Reis's avatar
wip    
Valentin Reis committed
60
      }
61
  deriving (Show, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
62
  deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON CmdSpec
Valentin Reis's avatar
wip    
Valentin Reis committed
63

64
65
66
67
mkCmdSpec :: Text -> [Text] -> [(Text, Text)] -> CmdSpec
mkCmdSpec command arguments environment = CmdSpec
  { cmd = Command command,
    args = Arg <$> arguments,
68
    env = Env $ M.fromList environment
69
70
  }

Valentin Reis's avatar
wip    
Valentin Reis committed
71
72
data CmdCore
  = CmdCore
Valentin Reis's avatar
Valentin Reis committed
73
      { cmdPath :: Command,
74
        arguments :: [Arg],
Valentin Reis's avatar
Valentin Reis committed
75
76
        upstreamClientID :: Maybe UC.UpstreamClientID,
        manifest :: Manifest
Valentin Reis's avatar
wip    
Valentin Reis committed
77
      }
78
  deriving (Show, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
79
  deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON CmdCore
Valentin Reis's avatar
wip    
Valentin Reis committed
80
81
82

data Cmd
  = Cmd
Valentin Reis's avatar
Valentin Reis committed
83
84
85
      { cmdCore :: CmdCore,
        pid :: ProcessID,
        processState :: ProcessState,
86
        downstreamCmds :: M.Map DownstreamCmdID DownstreamCmd,
Valentin Reis's avatar
Valentin Reis committed
87
88
        downstreamThreads :: M.Map DownstreamThreadID DownstreamThread,
        appActuators :: Map Text Ma.AppActuator
Valentin Reis's avatar
wip    
Valentin Reis committed
89
      }
90
  deriving (Show, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
91
  deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON Cmd
Valentin Reis's avatar
wip    
Valentin Reis committed
92

Valentin Reis's avatar
Valentin Reis committed
93
mkCmd :: CmdSpec -> Manifest -> Maybe UC.UpstreamClientID -> CmdCore
94
95
96
97
98
99
mkCmd s manifest clientID = CmdCore
  { cmdPath = cmd s,
    arguments = args s,
    upstreamClientID = clientID,
    manifest = manifest
  }
Valentin Reis's avatar
wip    
Valentin Reis committed
100
101

registerPID :: CmdCore -> ProcessID -> Cmd
Valentin Reis's avatar
wip    
Valentin Reis committed
102
registerPID c pid = Cmd
Valentin Reis's avatar
Valentin Reis committed
103
104
  { cmdCore = c,
    processState = blankState,
105
106
    downstreamCmds = M.empty,
    downstreamThreads = M.empty,
Valentin Reis's avatar
Valentin Reis committed
107
108
    pid = pid,
    appActuators =
109
      fromList . fmap (\(AppActuatorKV v k) -> (k, v)) . fromMaybe [] $
Valentin Reis's avatar
Valentin Reis committed
110
        c & manifest & app & Ma.actuators
Valentin Reis's avatar
wip    
Valentin Reis committed
111
112
  }

Valentin Reis's avatar
Valentin Reis committed
113
114
115
116
addDownstreamCmdClient ::
  Cmd ->
  DownstreamCmdID ->
  Maybe Cmd
117
118
addDownstreamCmdClient c downstreamCmdClientID =
  c ^. #cmdCore . #manifest . #app . #perfwrapper & \case
119
120
    Nothing -> Nothing
    (Just (Perfwrapper perfFreq perfLimit)) ->
121
122
123
124
      Just $
        c
          & #downstreamCmds
          . at downstreamCmdClientID ?~ DownstreamCmd
125
126
            { maxValue = Operations (fromInteger perfLimit),
              ratelimit = toFrequency perfFreq,
127
128
129
              dtLastReferenceMeasurements = MemBuffer.empty,
              lastRead = Nothing
            }
Valentin Reis's avatar
wip    
Valentin Reis committed
130

Valentin Reis's avatar
Valentin Reis committed
131
132
133
addDownstreamThreadClient ::
  Cmd ->
  DownstreamThreadID ->
134
  Cmd
135
addDownstreamThreadClient c downstreamThreadClientID =
136
137
138
139
140
141
142
143
144
  c & #downstreamThreads . at downstreamThreadClientID ?~ DownstreamThread
    { maxValue = 1 & progress,
      ratelimit = c ^. #cmdCore . #manifest . #app . #instrumentation
        & \case
          Just (Manifest.Instrumentation ratelimit) -> toFrequency ratelimit
          Nothing -> 1 & hz,
      dtLastReferenceMeasurements = MemBuffer.empty,
      lastRead = Nothing
    }
Valentin Reis's avatar
Valentin Reis committed
145

146
-- | newtype wrapper for an argument.
Valentin Reis's avatar
wip    
Valentin Reis committed
147
newtype Arg = Arg Text
148
  deriving (Show, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
149
  deriving (JSONSchema, A.ToJSON, A.FromJSON, IsString) via Text
Valentin Reis's avatar
wip    
Valentin Reis committed
150

151
-- | newtype wrapper for a command name.
Valentin Reis's avatar
wip    
Valentin Reis committed
152
newtype Command = Command Text
153
  deriving (Show, Eq, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
154
  deriving (JSONSchema, A.ToJSON, A.FromJSON, IsString, Interpret, Inject) via Text
Valentin Reis's avatar
wip    
Valentin Reis committed
155

156
-- | newtype wrapper for environment variables.
157
newtype Env = Env {fromEnv :: M.Map Text Text}
158
  deriving (Show, Generic, MessagePack)
Valentin Reis's avatar
Valentin Reis committed
159
  deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON Env
160
  deriving (Semigroup, Monoid) via M.Map Text Text
Valentin Reis's avatar
wip    
Valentin Reis committed
161

162
163
164
165
-- | @wrapCmd command args (command',args')@ builds the wrapped command
-- @command@ @args@ @command'@ @args'@.
wrapCmd :: Command -> [Arg] -> (Command, [Arg]) -> (Command, [Arg])
wrapCmd c options (Command a, as) = (c, options <> [Arg a] <> as)
Valentin Reis's avatar
Valentin Reis committed
166

Valentin Reis's avatar
Valentin Reis committed
167
instance HasLensMap (CmdID, Cmd) ActiveSensorKey ActiveSensor where
Valentin Reis's avatar
wip    
Valentin Reis committed
168
  lenses (_cmdID, cmd) =
169
170
    (addPath (_2 . #downstreamCmds) <$> lenses (downstreamCmds cmd))
      <> (addPath (_2 . #downstreamThreads) <$> lenses (downstreamThreads cmd))
Valentin Reis's avatar
Valentin Reis committed
171
172
173

instance HasLensMap (CmdID, Cmd) ActuatorKey Actuator where
  lenses (_cmdID, cmd) =
174
    addPath (_2 . #appActuators) <$> lenses (appActuators cmd)
Valentin Reis's avatar
Valentin Reis committed
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

instance HasLensMap (Text, AppActuator) ActuatorKey Actuator where
  lenses (t, _) =
    M.singleton
      (CmdActuatorKey t)
      ( ScopedLens
          ( _2
              . lens getter setter
          )
      )
    where
      getter :: Ma.AppActuator -> Actuator
      getter (coerce -> extraActuator) = Actuator
        { actions = Ma.actions extraActuator,
          referenceAction = Ma.referenceAction extraActuator,
          go = \value ->
            runProcess_ $
              System.Process.Typed.proc
                (toS $ Ma.actuatorBinary extraActuator)
                ((toS <$> Ma.actuatorArguments extraActuator) <> [show value])
        }
      setter :: Ma.AppActuator -> Actuator -> Ma.AppActuator
      setter oldExtraActuator actuator = coerce $
        oldExtraActuator &~ do
          #referenceAction .= NRM.Types.Actuator.referenceAction actuator
          #actions .= NRM.Types.Actuator.actions actuator