diff --git a/hsnrm/hsnrm/dhall/defaults/manifest.dhall b/hsnrm/hsnrm/dhall/defaults/manifest.dhall index e73b1800b21a5d60b475561cd62abb350ce06033..b85ccc5a03b5cc3b8f1fea44141b8d9d77a3f917 100644 --- a/hsnrm/hsnrm/dhall/defaults/manifest.dhall +++ b/hsnrm/hsnrm/dhall/defaults/manifest.dhall @@ -11,5 +11,6 @@ in { name = "default" , app = { perfwrapper = None t.Perfwrapper , instrumentation = None t.Instrumentation + , actuators = None (List t.AppActuatorKV) } } diff --git a/hsnrm/hsnrm/dhall/types/manifest.dhall b/hsnrm/hsnrm/dhall/types/manifest.dhall index 74f66d3711fd390e2e24d1d27bd512b1816770f8..d3c8f0a9d812975ab96682d21ba4fd05ddc394ee 100644 --- a/hsnrm/hsnrm/dhall/types/manifest.dhall +++ b/hsnrm/hsnrm/dhall/types/manifest.dhall @@ -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 : Optional (List AppActuatorKV) } let Manifest = @@ -39,4 +52,6 @@ in types , Instrumentation = Instrumentation , App = App , Manifest = Manifest + , AppActuator = AppActuator + , AppActuatorKV = AppActuatorKV } diff --git a/hsnrm/hsnrm/src/NRM/Types/Actuator.hs b/hsnrm/hsnrm/src/NRM/Types/Actuator.hs index c48777315fda72c9b4b67bfaa1e9cd95af41217d..f9fd9fa44e918344fd5342e7034ec06c4774c6ec 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Actuator.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Actuator.hs @@ -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 diff --git a/hsnrm/hsnrm/src/NRM/Types/Cmd.hs b/hsnrm/hsnrm/src/NRM/Types/Cmd.hs index 1b85a0944ff39e221e21b0c178298d508d41b369..382584f5eb79ad01d6da854c89ec62652d10f499 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Cmd.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Cmd.hs @@ -1,4 +1,5 @@ {-# 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)) . fromMaybe [] $ + 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 diff --git a/hsnrm/hsnrm/src/NRM/Types/Manifest.hs b/hsnrm/hsnrm/src/NRM/Types/Manifest.hs index 409fc2ee1bd4ca3fbd471956d147b38f96823b43..4c36afc3fb445cee7c38cdb01c4481db3f3f95ad 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Manifest.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Manifest.hs @@ -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,46 @@ 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 diff --git a/hsnrm/hsnrm/src/NRM/Types/Slice.hs b/hsnrm/hsnrm/src/NRM/Types/Slice.hs index 09049b837c0be818c550edb990dcb0a3c59f581d..7244131c19ee15076bfdd53d692446680800895c 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Slice.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Slice.hs @@ -25,6 +25,7 @@ import qualified Data.UUID as U (UUID, fromText, toText) import Data.UUID.V1 import LensMap.Core import NRM.Classes.Messaging +import NRM.Types.Actuator import NRM.Types.Cmd (Cmd (..), CmdCore (..)) import NRM.Types.CmdID (CmdID (..)) import NRM.Types.Sensor @@ -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) diff --git a/hsnrm/hsnrm/src/NRM/Types/State.hs b/hsnrm/hsnrm/src/NRM/Types/State.hs index f3c868665e499fc6a216ed71dd9712f25a7b7de6..d01f9ead64afc347a3177c6776ef047c7da99c69 100644 --- a/hsnrm/hsnrm/src/NRM/Types/State.hs +++ b/hsnrm/hsnrm/src/NRM/Types/State.hs @@ -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) ]