From 2915e8f72bb065c707dc15cddd74858031b7e712 Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 2 Feb 2021 15:25:23 -0600 Subject: [PATCH 1/3] Adds per-slice actuators. --- hsnrm/hsnrm/dhall/defaults/manifest.dhall | 1 + hsnrm/hsnrm/dhall/types/manifest.dhall | 15 ++++++ hsnrm/hsnrm/src/NRM/Types/Actuator.hs | 2 +- hsnrm/hsnrm/src/NRM/Types/Cmd.hs | 57 +++++++++++++++++++---- hsnrm/hsnrm/src/NRM/Types/Manifest.hs | 57 +++++++++++++++++++++++ hsnrm/hsnrm/src/NRM/Types/Slice.hs | 5 ++ hsnrm/hsnrm/src/NRM/Types/State.hs | 1 + 7 files changed, 128 insertions(+), 10 deletions(-) diff --git a/hsnrm/hsnrm/dhall/defaults/manifest.dhall b/hsnrm/hsnrm/dhall/defaults/manifest.dhall index e73b180..020e413 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 = [] : List t.AppActuatorKV } } diff --git a/hsnrm/hsnrm/dhall/types/manifest.dhall b/hsnrm/hsnrm/dhall/types/manifest.dhall index 74f66d3..e1d9421 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 : 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 c487773..f9fd9fa 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 1b85a09..10f0b7b 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)) $ + 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 409fc2e..9c1ddd5 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,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 diff --git a/hsnrm/hsnrm/src/NRM/Types/Slice.hs b/hsnrm/hsnrm/src/NRM/Types/Slice.hs index 09049b8..9f34463 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Slice.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Slice.hs @@ -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) diff --git a/hsnrm/hsnrm/src/NRM/Types/State.hs b/hsnrm/hsnrm/src/NRM/Types/State.hs index f3c8686..d01f9ea 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) ] -- GitLab From bcf740b2a3d7532f5631ccca0190ade42d87e87b Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 2 Feb 2021 19:01:49 -0600 Subject: [PATCH 2/3] [format] fix formatting. --- hsnrm/hsnrm/src/NRM/Types/Manifest.hs | 13 ------------- hsnrm/hsnrm/src/NRM/Types/Slice.hs | 2 +- 2 files changed, 1 insertion(+), 14 deletions(-) diff --git a/hsnrm/hsnrm/src/NRM/Types/Manifest.hs b/hsnrm/hsnrm/src/NRM/Types/Manifest.hs index 9c1ddd5..4c36afc 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Manifest.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Manifest.hs @@ -69,9 +69,6 @@ instance MessagePack Integer where fromObject x = (toInteger :: Int -> Integer) <$> fromObject x - - - deriving instance Generic AppActuatorKV deriving instance Eq AppActuatorKV @@ -92,11 +89,6 @@ deriving via (GenericJSON AppActuatorKV) instance ToJSON AppActuatorKV deriving via (GenericJSON AppActuatorKV) instance JSONSchema AppActuatorKV - - - - - deriving instance Generic AppActuator deriving instance Eq AppActuator @@ -117,11 +109,6 @@ 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 9f34463..7244131 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Slice.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Slice.hs @@ -25,10 +25,10 @@ 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 -import NRM.Types.Actuator import Protolude -- | NRM's internal view of the state of a slice. -- GitLab From f970b028e672e1c35c0e7a511885634a8f215789 Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 2 Feb 2021 19:42:56 -0600 Subject: [PATCH 3/3] [fix] Move List to Optional List in dhall configuration for slice-actuators. --- hsnrm/hsnrm/dhall/defaults/manifest.dhall | 2 +- hsnrm/hsnrm/dhall/types/manifest.dhall | 2 +- hsnrm/hsnrm/src/NRM/Types/Cmd.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/hsnrm/hsnrm/dhall/defaults/manifest.dhall b/hsnrm/hsnrm/dhall/defaults/manifest.dhall index 020e413..b85ccc5 100644 --- a/hsnrm/hsnrm/dhall/defaults/manifest.dhall +++ b/hsnrm/hsnrm/dhall/defaults/manifest.dhall @@ -11,6 +11,6 @@ in { name = "default" , app = { perfwrapper = None t.Perfwrapper , instrumentation = None t.Instrumentation - , actuators = [] : List t.AppActuatorKV + , actuators = None (List t.AppActuatorKV) } } diff --git a/hsnrm/hsnrm/dhall/types/manifest.dhall b/hsnrm/hsnrm/dhall/types/manifest.dhall index e1d9421..d3c8f0a 100644 --- a/hsnrm/hsnrm/dhall/types/manifest.dhall +++ b/hsnrm/hsnrm/dhall/types/manifest.dhall @@ -40,7 +40,7 @@ let App = -- instrumentation: an optional libnrm instrumentation configuration { perfwrapper : Optional Perfwrapper , instrumentation : Optional Instrumentation - , actuators : List AppActuatorKV + , actuators : Optional (List AppActuatorKV) } let Manifest = diff --git a/hsnrm/hsnrm/src/NRM/Types/Cmd.hs b/hsnrm/hsnrm/src/NRM/Types/Cmd.hs index 10f0b7b..382584f 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Cmd.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Cmd.hs @@ -106,7 +106,7 @@ registerPID c pid = Cmd downstreamThreads = M.empty, pid = pid, appActuators = - fromList . fmap (\(AppActuatorKV v k) -> (k, v)) $ + fromList . fmap (\(AppActuatorKV v k) -> (k, v)) . fromMaybe [] $ c & manifest & app & Ma.actuators } @@ -171,7 +171,7 @@ instance HasLensMap (CmdID, Cmd) ActiveSensorKey ActiveSensor where instance HasLensMap (CmdID, Cmd) ActuatorKey Actuator where lenses (_cmdID, cmd) = - (addPath (_2 . #appActuators) <$> lenses (appActuators cmd)) + addPath (_2 . #appActuators) <$> lenses (appActuators cmd) instance HasLensMap (Text, AppActuator) ActuatorKey Actuator where lenses (t, _) = -- GitLab