Commit d53e71f6 authored by Valentin Reis's avatar Valentin Reis
Browse files

Merge branch 'command-actuators' into 'master'

Adds per-slice actuators.

See merge request !77
parents 5705a848 f970b028
Pipeline #12747 passed with stages
in 2 minutes and 59 seconds
...@@ -11,5 +11,6 @@ in { name = "default" ...@@ -11,5 +11,6 @@ in { name = "default"
, app = , app =
{ perfwrapper = None t.Perfwrapper { perfwrapper = None t.Perfwrapper
, instrumentation = None t.Instrumentation , instrumentation = None t.Instrumentation
, actuators = None (List t.AppActuatorKV)
} }
} }
...@@ -22,12 +22,25 @@ let Instrumentation = ...@@ -22,12 +22,25 @@ let Instrumentation =
-- is a message rate limitation. -- is a message rate limitation.
{ ratelimit : types.Frequency } { ratelimit : types.Frequency }
let AppActuator =
-- Configuration for an arbitrary actuator.
{ actuatorBinary : Text
, actuatorArguments : List Text
, actions : List Double
, referenceAction : Double
}
let AppActuatorKV =
-- Key-value representation for an actuator.
{ actuatorID : Text, actuator : AppActuator }
let App = let App =
-- Application configuration. Two features can be enabled or disabled: -- Application configuration. Two features can be enabled or disabled:
-- perfwrapper: an optional linux perf configuration -- perfwrapper: an optional linux perf configuration
-- instrumentation: an optional libnrm instrumentation configuration -- instrumentation: an optional libnrm instrumentation configuration
{ perfwrapper : Optional Perfwrapper { perfwrapper : Optional Perfwrapper
, instrumentation : Optional Instrumentation , instrumentation : Optional Instrumentation
, actuators : Optional (List AppActuatorKV)
} }
let Manifest = let Manifest =
...@@ -39,4 +52,6 @@ in types ...@@ -39,4 +52,6 @@ in types
, Instrumentation = Instrumentation , Instrumentation = Instrumentation
, App = App , App = App
, Manifest = Manifest , Manifest = Manifest
, AppActuator = AppActuator
, AppActuatorKV = AppActuatorKV
} }
...@@ -25,7 +25,7 @@ data Actuator ...@@ -25,7 +25,7 @@ data Actuator
} }
deriving (Generic) deriving (Generic)
data ActuatorKey = RaplKey PackageID | ExtraActuatorKey Text data ActuatorKey = RaplKey PackageID | ExtraActuatorKey Text | CmdActuatorKey Text
deriving (Show, Read, Eq, Ord) deriving (Show, Read, Eq, Ord)
instance StringConv ActuatorKey CPD.ActuatorID where instance StringConv ActuatorKey CPD.ActuatorID where
......
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | -- |
-- Module : NRM.Types.Cmd -- Module : NRM.Types.Cmd
...@@ -23,7 +24,8 @@ module NRM.Types.Cmd ...@@ -23,7 +24,8 @@ module NRM.Types.Cmd
where where
import Control.Lens import Control.Lens
import Data.Aeson as A import qualified Data.Aeson as A
import Data.Coerce
import Data.Generics.Labels () import Data.Generics.Labels ()
import Data.JSON.Schema import Data.JSON.Schema
import Data.Map as M import Data.Map as M
...@@ -34,18 +36,21 @@ import LensMap.Core ...@@ -34,18 +36,21 @@ import LensMap.Core
import NRM.Classes.Messaging import NRM.Classes.Messaging
import NRM.Orphans.ExitCode () import NRM.Orphans.ExitCode ()
import NRM.Orphans.UUID () import NRM.Orphans.UUID ()
import NRM.Types.Actuator
import NRM.Types.CmdID import NRM.Types.CmdID
import NRM.Types.DownstreamCmd import NRM.Types.DownstreamCmd
import NRM.Types.DownstreamCmdID import NRM.Types.DownstreamCmdID
import NRM.Types.DownstreamThread import NRM.Types.DownstreamThread
import NRM.Types.DownstreamThreadID import NRM.Types.DownstreamThreadID
import NRM.Types.Manifest as Manifest import NRM.Types.Manifest as Manifest
import qualified NRM.Types.Manifest as Ma
import NRM.Types.MemBuffer as MemBuffer import NRM.Types.MemBuffer as MemBuffer
import NRM.Types.Process import NRM.Types.Process
import NRM.Types.Sensor import NRM.Types.Sensor
import NRM.Types.Units import NRM.Types.Units
import qualified NRM.Types.UpstreamClient as UC import qualified NRM.Types.UpstreamClient as UC
import Protolude import Protolude
import System.Process.Typed
data CmdSpec data CmdSpec
= CmdSpec = CmdSpec
...@@ -54,7 +59,7 @@ data CmdSpec ...@@ -54,7 +59,7 @@ data CmdSpec
env :: Env env :: Env
} }
deriving (Show, Generic, MessagePack) deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON) via GenericJSON CmdSpec deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON CmdSpec
mkCmdSpec :: Text -> [Text] -> [(Text, Text)] -> CmdSpec mkCmdSpec :: Text -> [Text] -> [(Text, Text)] -> CmdSpec
mkCmdSpec command arguments environment = CmdSpec mkCmdSpec command arguments environment = CmdSpec
...@@ -71,7 +76,7 @@ data CmdCore ...@@ -71,7 +76,7 @@ data CmdCore
manifest :: Manifest manifest :: Manifest
} }
deriving (Show, Generic, MessagePack) deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON) via GenericJSON CmdCore deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON CmdCore
data Cmd data Cmd
= Cmd = Cmd
...@@ -79,10 +84,11 @@ data Cmd ...@@ -79,10 +84,11 @@ data Cmd
pid :: ProcessID, pid :: ProcessID,
processState :: ProcessState, processState :: ProcessState,
downstreamCmds :: M.Map DownstreamCmdID DownstreamCmd, downstreamCmds :: M.Map DownstreamCmdID DownstreamCmd,
downstreamThreads :: M.Map DownstreamThreadID DownstreamThread downstreamThreads :: M.Map DownstreamThreadID DownstreamThread,
appActuators :: Map Text Ma.AppActuator
} }
deriving (Show, Generic, MessagePack) deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON) via GenericJSON Cmd deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON Cmd
mkCmd :: CmdSpec -> Manifest -> Maybe UC.UpstreamClientID -> CmdCore mkCmd :: CmdSpec -> Manifest -> Maybe UC.UpstreamClientID -> CmdCore
mkCmd s manifest clientID = CmdCore mkCmd s manifest clientID = CmdCore
...@@ -98,7 +104,10 @@ registerPID c pid = Cmd ...@@ -98,7 +104,10 @@ registerPID c pid = Cmd
processState = blankState, processState = blankState,
downstreamCmds = M.empty, downstreamCmds = M.empty,
downstreamThreads = M.empty, downstreamThreads = M.empty,
pid = pid pid = pid,
appActuators =
fromList . fmap (\(AppActuatorKV v k) -> (k, v)) . fromMaybe [] $
c & manifest & app & Ma.actuators
} }
addDownstreamCmdClient :: addDownstreamCmdClient ::
...@@ -137,17 +146,17 @@ addDownstreamThreadClient c downstreamThreadClientID = ...@@ -137,17 +146,17 @@ addDownstreamThreadClient c downstreamThreadClientID =
-- | newtype wrapper for an argument. -- | newtype wrapper for an argument.
newtype Arg = Arg Text newtype Arg = Arg Text
deriving (Show, Generic, MessagePack) deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON, IsString) via Text deriving (JSONSchema, A.ToJSON, A.FromJSON, IsString) via Text
-- | newtype wrapper for a command name. -- | newtype wrapper for a command name.
newtype Command = Command Text newtype Command = Command Text
deriving (Show, Eq, Generic, MessagePack) deriving (Show, Eq, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON, IsString, Interpret, Inject) via Text deriving (JSONSchema, A.ToJSON, A.FromJSON, IsString, Interpret, Inject) via Text
-- | newtype wrapper for environment variables. -- | newtype wrapper for environment variables.
newtype Env = Env {fromEnv :: M.Map Text Text} newtype Env = Env {fromEnv :: M.Map Text Text}
deriving (Show, Generic, MessagePack) deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON) via GenericJSON Env deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON Env
deriving (Semigroup, Monoid) via M.Map Text Text deriving (Semigroup, Monoid) via M.Map Text Text
-- | @wrapCmd command args (command',args')@ builds the wrapped command -- | @wrapCmd command args (command',args')@ builds the wrapped command
...@@ -159,3 +168,33 @@ instance HasLensMap (CmdID, Cmd) ActiveSensorKey ActiveSensor where ...@@ -159,3 +168,33 @@ instance HasLensMap (CmdID, Cmd) ActiveSensorKey ActiveSensor where
lenses (_cmdID, cmd) = lenses (_cmdID, cmd) =
(addPath (_2 . #downstreamCmds) <$> lenses (downstreamCmds cmd)) (addPath (_2 . #downstreamCmds) <$> lenses (downstreamCmds cmd))
<> (addPath (_2 . #downstreamThreads) <$> lenses (downstreamThreads cmd)) <> (addPath (_2 . #downstreamThreads) <$> lenses (downstreamThreads cmd))
instance HasLensMap (CmdID, Cmd) ActuatorKey Actuator where
lenses (_cmdID, cmd) =
addPath (_2 . #appActuators) <$> lenses (appActuators cmd)
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
...@@ -11,6 +11,8 @@ ...@@ -11,6 +11,8 @@
module NRM.Types.Manifest module NRM.Types.Manifest
( Manifest (..), ( Manifest (..),
App (..), App (..),
AppActuator (..),
AppActuatorKV (..),
Instrumentation (..), Instrumentation (..),
Perfwrapper (..), Perfwrapper (..),
toFrequency, toFrequency,
...@@ -39,6 +41,8 @@ makeHaskellTypes $ ...@@ -39,6 +41,8 @@ makeHaskellTypes $
in [ dRec "Frequency" "Frequency", in [ dRec "Frequency" "Frequency",
dRec "Perfwrapper" "Perfwrapper", dRec "Perfwrapper" "Perfwrapper",
dRec "Instrumentation" "Instrumentation", dRec "Instrumentation" "Instrumentation",
dRec "AppActuator" "AppActuator",
dRec "AppActuatorKV" "AppActuatorKV",
dRec "App" "App", dRec "App" "App",
dRec "Manifest" "Manifest" dRec "Manifest" "Manifest"
] ]
...@@ -65,6 +69,46 @@ instance MessagePack Integer where ...@@ -65,6 +69,46 @@ instance MessagePack Integer where
fromObject x = (toInteger :: Int -> Integer) <$> fromObject x fromObject x = (toInteger :: Int -> Integer) <$> fromObject x
deriving instance Generic AppActuatorKV
deriving instance Eq AppActuatorKV
deriving instance Ord AppActuatorKV
deriving instance Show AppActuatorKV
deriving instance MessagePack AppActuatorKV
deriving instance FromDhall AppActuatorKV
deriving instance ToDhall AppActuatorKV
deriving via (GenericJSON AppActuatorKV) instance FromJSON AppActuatorKV
deriving via (GenericJSON AppActuatorKV) instance ToJSON AppActuatorKV
deriving via (GenericJSON AppActuatorKV) instance JSONSchema AppActuatorKV
deriving instance Generic AppActuator
deriving instance Eq AppActuator
deriving instance Ord AppActuator
deriving instance Show AppActuator
deriving instance MessagePack AppActuator
deriving instance FromDhall AppActuator
deriving instance ToDhall AppActuator
deriving via (GenericJSON AppActuator) instance FromJSON AppActuator
deriving via (GenericJSON AppActuator) instance ToJSON AppActuator
deriving via (GenericJSON AppActuator) instance JSONSchema AppActuator
deriving instance Generic Frequency deriving instance Generic Frequency
deriving instance Eq Frequency deriving instance Eq Frequency
......
...@@ -25,6 +25,7 @@ import qualified Data.UUID as U (UUID, fromText, toText) ...@@ -25,6 +25,7 @@ import qualified Data.UUID as U (UUID, fromText, toText)
import Data.UUID.V1 import Data.UUID.V1
import LensMap.Core import LensMap.Core
import NRM.Classes.Messaging import NRM.Classes.Messaging
import NRM.Types.Actuator
import NRM.Types.Cmd (Cmd (..), CmdCore (..)) import NRM.Types.Cmd (Cmd (..), CmdCore (..))
import NRM.Types.CmdID (CmdID (..)) import NRM.Types.CmdID (CmdID (..))
import NRM.Types.Sensor import NRM.Types.Sensor
...@@ -67,3 +68,7 @@ toText (Name n) = n ...@@ -67,3 +68,7 @@ toText (Name n) = n
instance HasLensMap (SliceID, Slice) ActiveSensorKey ActiveSensor where instance HasLensMap (SliceID, Slice) ActiveSensorKey ActiveSensor where
lenses (_sliceID, slice) = lenses (_sliceID, slice) =
addPath (_2 . #cmds) <$> lenses (cmds slice) addPath (_2 . #cmds) <$> lenses (cmds slice)
instance HasLensMap (SliceID, Slice) ActuatorKey Actuator where
lenses (_sliceID, slice) =
addPath (_2 . #cmds) <$> lenses (cmds slice)
...@@ -159,6 +159,7 @@ instance HasLensMap NRMState A.ActuatorKey A.Actuator where ...@@ -159,6 +159,7 @@ instance HasLensMap NRMState A.ActuatorKey A.Actuator where
lenses s = lenses s =
mconcat mconcat
[ addPath #packages <$> lenses (packages s), [ addPath #packages <$> lenses (packages s),
addPath #slices <$> lenses (slices s),
addPath #extraStaticActuators <$> lenses (extraStaticActuators s) addPath #extraStaticActuators <$> lenses (extraStaticActuators s)
] ]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment