fixed conflicts

agent/config/routes

@@ -41,6 +41,7 @@
 /v0/apps/#AppId/autoconfig/#AppId     AutoconfigureR           POST
 /v0/apps/#AppId/lan/enable            EnableLanR               POST
 /v0/apps/#AppId/lan/disable           DisableLanR              POST
+/v0/apps/#AppId/actions               ActionR                  POST
 
 /v0/disks                             DisksR                   GET
 /v0/disks/eject                       EjectR                   POST

agent/package.yaml

@@ -65,6 +65,7 @@ dependencies:
 - http-types
 - interpolate
 - iso8601-time
+- json-rpc
 - lens
 - lens-aeson
 - lifted-async

agent/src/Handler/Apps.hs

@@ -81,6 +81,8 @@ import           Settings
 import           Crypto.Hash
 import qualified Data.Text                     as Text
 import           Lib.Types.NetAddress
+import qualified Network.JSONRPC               as JSONRPC
+import           Data.Aeson.Types               ( parseMaybe )
 
 pureLog :: Show a => a -> Handler a
 pureLog = liftA2 (*>) ($logInfo . show) pure
@@ -809,3 +811,20 @@ postDisableLanLogic appId = do
     case action of
         Nothing -> pure () -- Nothing to do here
         Just x  -> LAsync.cancel x
+postActionR :: AppId -> Handler (JSONResponse JSONRPC.Response)
+postActionR appId = do
+    req <- requireCheckJsonBody
+    fmap JSONResponse . intoHandler $ postActionLogic appId req
+
+postActionLogic :: (Has (Error S9Error) sig m, Has AppMgr2.AppMgr sig m)
+                => AppId
+                -> JSONRPC.Request
+                -> m JSONRPC.Response
+postActionLogic appId (JSONRPC.Request { getReqMethod, getReqId }) = do
+    hm <- AppMgr2.action appId getReqMethod
+    case (HM.lookup "result" hm, HM.lookup "error" hm >>= parseMaybe parseJSON) of
+        (Just v , _      ) -> pure (JSONRPC.Response JSONRPC.V2 v getReqId)
+        (_      , Just e ) -> pure (JSONRPC.ResponseError JSONRPC.V2 e getReqId)
+        (Nothing, Nothing) -> throwError
+            $ AppMgrParseE "action" (decodeUtf8 . LBS.toStrict $ encode (Object hm)) "Invalid JSONRPC Response"
+postActionLogic _ r = throwError $ InvalidRequestE (toJSON r) "Invalid JSONRPC Request"

agent/src/Lib/Algebra/Domain/AppMgr.hs

@@ -270,6 +270,7 @@ data AppMgr (m :: Type -> Type) k where
     Update ::DryRun -> AppId -> Maybe VersionRange -> AppMgr m BreakageMap
     -- Verify ::_
     LanEnable ::AppId -> AppMgr m ()
+    Action ::AppId -> Text -> AppMgr m (HM.HashMap Text Value)
 makeSmartConstructors ''AppMgr
 
 newtype AppMgrCliC m a = AppMgrCliC { runAppMgrCliC :: m a }
@@ -421,8 +422,17 @@ instance (Has (Error S9Error) sig m, Algebra sig m, MonadIO m) => Algebra (AppMg
                 ExitFailure 6 ->
                     throwError $ NotFoundE "appId@version" ([i|#{appId}#{maybe "" (('@':) . show) version}|])
                 ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
-        (L (LanEnable appId)) -> readProcessInheritStderr "appmgr" ["lan", "enable", show appId] "" $> ctx
+        (L (LanEnable appId    )) -> readProcessInheritStderr "appmgr" ["lan", "enable", show appId] "" $> ctx
-        R other               -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
+        (L (Action appId action)) -> do
+            let args = ["actions", show appId, toS action]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure $ ctx $> x
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
+        R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
         where
             versionSpec :: (IsString a, Semigroup a, ConvertText String a) => Maybe VersionRange -> a -> a
             versionSpec v = case v of