Commit 2915e8f7 authored by Valentin Reis's avatar Valentin Reis
Browse files

Adds per-slice actuators.

parent 5705a848
Pipeline #12432 failed with stages
in 1 minute and 33 seconds
......@@ -11,5 +11,6 @@ in { name = "default"
, app =
{ perfwrapper = None t.Perfwrapper
, instrumentation = None t.Instrumentation
, actuators = [] : List t.AppActuatorKV
}
}
......@@ -22,12 +22,25 @@ let Instrumentation =
-- is a message rate limitation.
{ 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 =
-- Application configuration. Two features can be enabled or disabled:
-- perfwrapper: an optional linux perf configuration
-- instrumentation: an optional libnrm instrumentation configuration
{ perfwrapper : Optional Perfwrapper
, instrumentation : Optional Instrumentation
, actuators : List AppActuatorKV
}
let Manifest =
......@@ -39,4 +52,6 @@ in types
, Instrumentation = Instrumentation
, App = App
, Manifest = Manifest
, AppActuator = AppActuator
, AppActuatorKV = AppActuatorKV
}
......@@ -25,7 +25,7 @@ data Actuator
}
deriving (Generic)
data ActuatorKey = RaplKey PackageID | ExtraActuatorKey Text
data ActuatorKey = RaplKey PackageID | ExtraActuatorKey Text | CmdActuatorKey Text
deriving (Show, Read, Eq, Ord)
instance StringConv ActuatorKey CPD.ActuatorID where
......
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : NRM.Types.Cmd
......@@ -23,7 +24,8 @@ module NRM.Types.Cmd
where
import Control.Lens
import Data.Aeson as A
import qualified Data.Aeson as A
import Data.Coerce
import Data.Generics.Labels ()
import Data.JSON.Schema
import Data.Map as M
......@@ -34,18 +36,21 @@ import LensMap.Core
import NRM.Classes.Messaging
import NRM.Orphans.ExitCode ()
import NRM.Orphans.UUID ()
import NRM.Types.Actuator
import NRM.Types.CmdID
import NRM.Types.DownstreamCmd
import NRM.Types.DownstreamCmdID
import NRM.Types.DownstreamThread
import NRM.Types.DownstreamThreadID
import NRM.Types.Manifest as Manifest
import qualified NRM.Types.Manifest as Ma
import NRM.Types.MemBuffer as MemBuffer
import NRM.Types.Process
import NRM.Types.Sensor
import NRM.Types.Units
import qualified NRM.Types.UpstreamClient as UC
import Protolude
import System.Process.Typed
data CmdSpec
= CmdSpec
......@@ -54,7 +59,7 @@ data CmdSpec
env :: Env
}
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 command arguments environment = CmdSpec
......@@ -71,7 +76,7 @@ data CmdCore
manifest :: Manifest
}
deriving (Show, Generic, MessagePack)
deriving (JSONSchema, ToJSON, FromJSON) via GenericJSON CmdCore
deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON CmdCore
data Cmd
= Cmd
......@@ -79,10 +84,11 @@ data Cmd
pid :: ProcessID,
processState :: ProcessState,
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 (JSONSchema, ToJSON, FromJSON) via GenericJSON Cmd
deriving (JSONSchema, A.ToJSON, A.FromJSON) via GenericJSON Cmd
mkCmd :: CmdSpec -> Manifest -> Maybe UC.UpstreamClientID -> CmdCore
mkCmd s manifest clientID = CmdCore
......@@ -98,7 +104,10 @@ registerPID c pid = Cmd
processState = blankState,
downstreamCmds = M.empty,
downstreamThreads = M.empty,
pid = pid
pid = pid,
appActuators =
fromList . fmap (\(AppActuatorKV v k) -> (k, v)) $
c & manifest & app & Ma.actuators
}
addDownstreamCmdClient ::
......@@ -137,17 +146,17 @@ addDownstreamThreadClient c downstreamThreadClientID =
-- | newtype wrapper for an argument.
newtype Arg = Arg Text
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 Command = Command Text
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 Env = Env {fromEnv :: M.Map Text Text}
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
-- | @wrapCmd command args (command',args')@ builds the wrapped command
......@@ -159,3 +168,33 @@ instance HasLensMap (CmdID, Cmd) ActiveSensorKey ActiveSensor where
lenses (_cmdID, cmd) =
(addPath (_2 . #downstreamCmds) <$> lenses (downstreamCmds 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 @@
module NRM.Types.Manifest
( Manifest (..),
App (..),
AppActuator (..),
AppActuatorKV (..),
Instrumentation (..),
Perfwrapper (..),
toFrequency,
......@@ -39,6 +41,8 @@ makeHaskellTypes $
in [ dRec "Frequency" "Frequency",
dRec "Perfwrapper" "Perfwrapper",
dRec "Instrumentation" "Instrumentation",
dRec "AppActuator" "AppActuator",
dRec "AppActuatorKV" "AppActuatorKV",
dRec "App" "App",
dRec "Manifest" "Manifest"
]
......@@ -65,6 +69,59 @@ instance MessagePack Integer where
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 Eq Frequency
......
......@@ -28,6 +28,7 @@ import NRM.Classes.Messaging
import NRM.Types.Cmd (Cmd (..), CmdCore (..))
import NRM.Types.CmdID (CmdID (..))
import NRM.Types.Sensor
import NRM.Types.Actuator
import Protolude
-- | NRM's internal view of the state of a slice.
......@@ -67,3 +68,7 @@ toText (Name n) = n
instance HasLensMap (SliceID, Slice) ActiveSensorKey ActiveSensor where
lenses (_sliceID, 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
lenses s =
mconcat
[ addPath #packages <$> lenses (packages s),
addPath #slices <$> lenses (slices 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