packages feed

managed-functions (empty) → 1.1.0.0

raw patch · 23 files changed

+669/−0 lines, 23 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, exceptions, hspec, managed-functions

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Martin Bednář++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,5 @@+# managed-functions++This package provides the core functionality of the Managed Functions framework.++For basic information about the framework see README on Github at [https://github.com/martin-bednar/managed-functions](https://github.com/martin-bednar/managed-functions#readme)
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ managed-functions.cabal view
@@ -0,0 +1,74 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           managed-functions+version:        1.1.0.0+synopsis:       Remote Management Framework+description:    Please see the README on GitHub at <https://github.com/martin-bednar/managed-functions#readme>+category:       Remote Management+homepage:       https://github.com/martin-bednar/managed-functions#readme+bug-reports:    https://github.com/martin-bednar/managed-functions/issues+author:         Martin Bednar+maintainer:     bednam17@fit.cvut.cz+copyright:      2022 Martin Bednar+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/martin-bednar/managed-functions++library+  exposed-modules:+      Data.Managed+      Data.Managed.Agent+      Data.Managed.Connector+      Data.Managed.Encoding+      Data.Managed.Encodings.ShowRead+      Data.Managed.Probe+      Data.Managed.ProbeDescription+      Managed+      Managed.Agent+      Managed.Exception+      Managed.Probe+      Managed.Probe.Internal.Params+      Managed.Probe.ToProbe+      Managed.ProbeDescription+  other-modules:+      Paths_managed_functions+  hs-source-dirs:+      src+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Wmonomorphism-restriction -Wmissing-home-modules -Widentities -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , containers+    , deepseq+    , exceptions+  default-language: Haskell2010++test-suite managed-functions-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Spec.Data+      Spec.Managed.Agent+      Spec.Managed.Probe+      Spec.Managed.Probe.ToProbe+      Paths_managed_functions+  hs-source-dirs:+      test+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Wmonomorphism-restriction -Wmissing-home-modules -Widentities -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , deepseq+    , exceptions+    , hspec+    , managed-functions+  default-language: Haskell2010
+ src/Data/Managed.hs view
@@ -0,0 +1,15 @@+module Data.Managed+  ( module Data.Managed.Probe+  , module Data.Managed.Agent+  , module Data.Managed.Connector+  , module Data.Managed.ProbeDescription+  , module Data.Managed.Encoding+  , module Data.Managed.Encodings.ShowRead+  ) where++import Data.Managed.Agent+import Data.Managed.Connector+import Data.Managed.Encoding+import Data.Managed.Encodings.ShowRead+import Data.Managed.Probe+import Data.Managed.ProbeDescription
+ src/Data/Managed/Agent.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}++module Data.Managed.Agent where++import Data.Managed.Probe++import Data.Map (Map)++type ProbeID = String++type Agent e = Map ProbeID (Probe e)
+ src/Data/Managed/Connector.hs view
@@ -0,0 +1,8 @@+module Data.Managed.Connector where++import Data.Managed.Agent++newtype Connector e =+  Connector+    { run :: Agent e -> IO ()+    }
+ src/Data/Managed/Encoding.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Managed.Encoding where++import Data.Kind (Type)++class Encoding a where+  type In a :: Type+  type Out a :: Type++class Encode t rep where+  encode :: t -> Out rep++class Decode t rep where+  decode :: In rep -> Maybe t++withEncoding ::+     forall e i o. (Encode o e, Decode i e)+  => (i -> o)+  -> In e+  -> Maybe (Out e)+withEncoding f i = do+  decoded <- decode @i @e i+  let applied = f decoded+  return $ encode @o @e applied
+ src/Data/Managed/Encodings/ShowRead.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Managed.Encodings.ShowRead where++import Data.Managed.Encoding+import Text.Read (readMaybe)++data SR++instance Encoding SR where+  type In SR = String+  type Out SR = String++instance (Show a) => Encode a SR where+  encode = show++instance (Read a) => Decode a SR where+  decode = readMaybe
+ src/Data/Managed/Probe.hs view
@@ -0,0 +1,13 @@+module Data.Managed.Probe where++import Data.Data (TypeRep)+import Data.Managed.Encoding++data Probe e =+  Probe+    { call :: [In e] -> IO (Out e)+    , typeRep :: TypeRep+    }++instance Show (Probe e) where+  show p = "<Probe> :: " ++ show (typeRep p)
+ src/Data/Managed/ProbeDescription.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.Managed.ProbeDescription+  ( ProbeDescription(..)+  ) where++import Data.Managed.Agent (ProbeID)+import GHC.Generics (Generic)++data ProbeDescription =+  ProbeDescription+    { probeID :: ProbeID+    , probeType :: String+    , probeParams :: [String]+    , probeReturns :: String+    }+  deriving (Show, Eq, Generic)
+ src/Managed.hs view
@@ -0,0 +1,13 @@+module Managed+  ( module Data.Managed+  , module Managed.Probe+  , module Managed.Agent+  , module Managed.Probe.ToProbe+  , module Managed.Exception+  ) where++import Data.Managed+import Managed.Agent+import Managed.Exception+import Managed.Probe+import Managed.Probe.ToProbe
+ src/Managed/Agent.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Managed.Agent+  ( fromList+  , toList+  , (!)+  , (!?)+  , invoke+  , ids+  , invokeUnsafe+  , describe+  , describeEither+  , describeHuman+  ) where++import qualified Data.Map as M++import Data.Managed++import Control.DeepSeq (NFData, force)+import Control.Exception (catch, evaluate, toException)+import Control.Monad.Catch (try)+import Managed.Exception+import Managed.ProbeDescription+import System.IO.Error (catchIOError)++-- | 'Data.Map.fromList' specialized to 'Agent'+fromList :: [(ProbeID, Probe e)] -> Agent e+fromList = M.fromList++-- | 'Data.Map.toList' specialized to 'Agent'+toList :: Agent e -> [(ProbeID, Probe e)]+toList = M.toList++infixl 9 !, !?++-- | 'Data.Map.!' specialized to 'Agent'+(!) :: Agent e -> ProbeID -> Probe e+(!) = (M.!)++-- | 'Data.Map.!?' specialized to 'Agent'+(!?) :: Agent e -> ProbeID -> Maybe (Probe e)+(!?) = (M.!?)++-- | Invokes (calls) a 'Probe'.+--+-- This function never throws an exception,+-- instead, an 'Either' is used.+-- Any errors and exceptions caused by incorrect 'ProbeID',+-- incorrect input parameters, or by the probe call itself+-- are caught and passed as an 'AgentException'.+--+-- The result is fully evaluated using 'force'+-- before it's returned+-- (to keep all exceptions inside the 'Either').+invoke ::+     (NFData (Out e))+  => Agent e -- ^ Agent that contains the probe to be called+  -> ProbeID -- ^ ID of the probe to be called+  -> [In e] -- ^ Input parameters+  -> IO (Either AgentException (Out e))+invoke a p i = try $ invokeUnsafe a p i++-- | An unsafe variant of 'invoke'.+--+-- This function rethrows all exceptions and errors+-- caused by probe lookup or input parameters.+-- Exceptions caused by probe invocation+-- are rethrown as 'ProbeRuntimeException'.+invokeUnsafe :: (NFData (Out e)) => Agent e -> ProbeID -> [In e] -> IO (Out e)+invokeUnsafe agent pid input = findOrThrow agent pid >>= callStrict input++-- | List all Probe IDs+ids :: Agent e -> [ProbeID]+ids = Prelude.map fst . toList++-- | Create a full description of a 'Probe'+describe :: Agent e -> ProbeID -> Maybe ProbeDescription+describe agent pid = mkDescription pid <$> agent !? pid++-- | A variant of 'describe' that returns 'Either' instead of 'Maybe'+describeEither :: Agent e -> ProbeID -> Either AgentException ProbeDescription+describeEither agent pid =+  case describe agent pid of+    Nothing -> Left $ badProbeID pid+    Just res -> Right res++-- | Create a human-readable description of a probe+describeHuman :: Agent e -> ProbeID -> Maybe String+describeHuman agent pid = human <$> describe agent pid++-- Utility functions+findOrThrow :: Agent e -> ProbeID -> IO (Probe e)+findOrThrow agent pid =+  case agent !? pid of+    Nothing -> throwM $ badProbeID pid+    Just probe -> return probe++callStrict :: (NFData (Out e)) => [In e] -> Probe e -> IO (Out e)+callStrict input p = callOrThrow input p >>= evalOrThrow++callOrThrow :: [In e] -> Probe e -> IO (Out e)+callOrThrow input p =+  call p input `catchIOError` (throwM . probeRuntimeException . toException)++evalOrThrow :: (NFData a) => a -> IO a+evalOrThrow x = (evaluate . force) x `catch` (throwM . probeRuntimeException)
+ src/Managed/Exception.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}++module Managed.Exception+  ( AgentException(..)+  , throwM+  , explain+  , badNumberOfArgs+  , noParseArg+  , probeRuntimeException+  , badProbeID+  ) where++import Control.Exception (Exception(..), SomeException)+import Control.Monad.Catch (throwM)+import Data.Managed+import GHC.Generics (Generic)++data AgentException+  = BadProbeID ProbeID+  | BadNumberOfArguments Int Int+  | NoParseArgument+  | ProbeRuntimeException String+  deriving (Show, Eq, Generic)++instance Exception AgentException where+  displayException = explain++explain :: AgentException -> String+explain (BadProbeID pid) = "Unrecognized ProbeID: " ++ show pid+explain (BadNumberOfArguments expected got) =+  "Bad number of arguments. Expected " +++  show expected ++ ", but got " ++ show got+explain NoParseArgument = "Can't parse probe input argument."+explain (ProbeRuntimeException reason) =+  "Exception thrown in probe invocation:\n" ++ reason++badNumberOfArgs :: Int -> [a] -> AgentException+badNumberOfArgs n xs = BadNumberOfArguments n (length xs)++noParseArg :: AgentException+noParseArg = NoParseArgument++probeRuntimeException :: SomeException -> AgentException+probeRuntimeException exception = ProbeRuntimeException (show exception)++badProbeID :: ProbeID -> AgentException+badProbeID = BadProbeID
+ src/Managed/Probe.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Managed.Probe+  ( params+  , returns+  ) where++import Data.Managed (Probe(..), typeRep)+import Data.Typeable (TypeRep)+import qualified Managed.Probe.Internal.Params as P++params :: Probe e -> [TypeRep]+params = P.params . typeRep++returns :: Probe e -> TypeRep+returns = P.returns . typeRep
+ src/Managed/Probe/Internal/Params.hs view
@@ -0,0 +1,24 @@+module Managed.Probe.Internal.Params+  ( params+  , paramsCnt+  , returns+  ) where++import Data.Typeable++expand :: TypeRep -> [TypeRep]+expand x+  | "->" <- tyConName $ typeRepTyCon x = flatten $ typeRepArgs x+  | otherwise = [x]++flatten :: [TypeRep] -> [TypeRep]+flatten = concatMap expand++params :: TypeRep -> [TypeRep]+params = init . expand++paramsCnt :: TypeRep -> Int+paramsCnt = length . params++returns :: TypeRep -> TypeRep+returns = last . expand
+ src/Managed/Probe/ToProbe.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++module Managed.Probe.ToProbe+  ( toProbe+  , ToProbe(..)+  ) where++import Control.Monad.Catch (MonadThrow)+import Data.Managed+import Data.Typeable (Proxy(..), TypeRep, Typeable, typeOf)+import Managed.Exception (badNumberOfArgs, noParseArg, throwM)+import Managed.Probe.Internal.Params (paramsCnt)++-- | Converts any suitable function to a 'Probe'+toProbe ::+     forall e fn. (Typeable fn, ToProbe fn e)+  => fn+  -> Probe e+toProbe x =+  let t = typeOf x+   in Probe {typeRep = t, call = checkArgs t (apply (Proxy @e) x)}++-- | Class of functions that can be converted to a Probe+class ToProbe fn e+  where+  -- | Read arguments from a list, apply them to a function, and encode the result+  apply :: Proxy e -> fn -> [In e] -> IO (Out e)++instance {-# OVERLAPPABLE #-} (Encode a e) => ToProbe a e where+  apply _ c [] = return $ (encode @a @e) c++instance {-# OVERLAPPING #-} (Encode a e) => ToProbe (IO a) e where+  apply _ c [] = (encode @a @e) <$> c++instance {-# OVERLAPPING #-} (Decode a e, ToProbe b e) =>+                             ToProbe (a -> b) e where+  apply _ f (x:xs) = do+    r <- decodeSingle (Proxy @e) x+    apply (Proxy @e) (f r) xs++-- Helper functions+decodeSingle ::+     forall a e m. (MonadThrow m, Decode a e)+  => Proxy e+  -> In e+  -> m a+decodeSingle _ x'+  | (Just x) <- (decode @a @e) x' = return x+  | otherwise = throwM noParseArg++checkArgs :: TypeRep -> ([a] -> IO b) -> [a] -> IO b+checkArgs t = withArgs (paramsCnt t)++withArgs :: Int -> ([a] -> IO b) -> [a] -> IO b+withArgs n f args+  | n == length args = f args+  | otherwise = throwM $ badNumberOfArgs n args
+ src/Managed/ProbeDescription.hs view
@@ -0,0 +1,20 @@+module Managed.ProbeDescription+  ( mkDescription+  , human+  ) where++import Data.Managed+import Managed.Probe++mkDescription :: ProbeID -> Probe e -> ProbeDescription+mkDescription pid probe =+  ProbeDescription+    { probeID = pid+    , probeType = show $ typeRep probe+    , probeParams = Prelude.map show $ params probe+    , probeReturns = show $ returns probe+    }++-- | Create a human-readable description from a 'ProbeDescription'+human :: ProbeDescription -> String+human pd = concat [probeID pd, " :: ", probeType pd]
+ test/Spec.hs view
@@ -0,0 +1,13 @@+module Main where++import Spec.Managed.Agent+import Spec.Managed.Probe+import Spec.Managed.Probe.ToProbe+import Test.Hspec++main :: IO ()+main =+  hspec $ do+    describe "Managed.Probe.ToProbe" Spec.Managed.Probe.ToProbe.spec+    describe "Managed.Probe" Spec.Managed.Probe.spec+    describe "Managed.Agent" Spec.Managed.Agent.spec
+ test/Spec/Data.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeApplications #-}++module Spec.Data where++import Data.Typeable (Proxy(Proxy), TypeRep, typeRep)+import Managed hiding (typeRep)++data MyData+  = A+  | B+  | C+  deriving (Show, Read, Eq)++nullary :: MyData+nullary = A++probeN :: Probe SR+probeN = toProbe nullary++unary :: MyData -> MyData+unary _ = B++probeU :: Probe SR+probeU = toProbe unary++binary :: MyData -> MyData -> MyData+binary _ _ = C++probeB :: Probe SR+probeB = toProbe binary++unaryIO :: MyData -> IO MyData+unaryIO = return++probeIO :: Probe SR+probeIO = toProbe unaryIO++probeIntCharStr :: Probe SR+probeIntCharStr = toProbe (replicate :: Int -> Char -> [Char])++int :: TypeRep+int = typeRep (Proxy @Int)++char :: TypeRep+char = typeRep (Proxy @Char)++intChar :: TypeRep+intChar = typeRep (Proxy @(Int -> Char))++intCharChar :: TypeRep+intCharChar = typeRep (Proxy @(Int -> Char -> Char))
+ test/Spec/Managed/Agent.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Spec.Managed.Agent where++import GHC.IO (throwIO)+import Managed+import Managed.Exception+import Spec.Data+import Test.Hspec++spec :: Spec+spec = do+  let myIds = ["probeN", "probeB", "probeIO"]+  let myProbes = zip myIds [probeN, probeB, probeIO]+  let myAgent = fromList myProbes+  Test.Hspec.describe "list" $ do+    it "lists all probes in an Agent" $ do+      Prelude.map fst (toList myAgent) `shouldMatchList` myIds+  Test.Hspec.describe "ids" $ do+    it "lists IDs of all probes in an Agent" $ do+      ids myAgent `shouldMatchList` myIds+  Test.Hspec.describe "invoke" $ do+    it "invokes a probe with valid input" $ do+      invoke myAgent "probeB" ["A", "B"] `shouldReturn` Right "C"+    it "fails to invoke a probe with invalid input" $ do+      invoke myAgent "probeB" ["A", "X"] `shouldReturn` Left NoParseArgument+    it "fails to invoke a nonexistent probe" $ do+      invoke myAgent "probeX" [] `shouldReturn` Left (BadProbeID "probeX")+    it "detect wrong number of input parameters" $ do+      invoke myAgent "probeB" ["A", "B", "C"] `shouldReturn`+        Left (BadNumberOfArguments 2 3)+    it "catches any error thrown inside a Probe" $ do+      invoke errAgent "simpleErr" [] >>= (`shouldSatisfy` isRuntimeException)+      invoke errAgent "ioErr" [] >>= (`shouldSatisfy` isRuntimeException)++errAgent :: Agent SR+errAgent =+  fromList+    [ ("simpleErr", toProbe (error "Bad Error!" :: String))+    , ("ioErr", toProbe ((throwIO $ userError "Bad Error!") :: IO String))+    ]++isRuntimeException :: Either AgentException b -> Bool+isRuntimeException (Left (ProbeRuntimeException _)) = True+isRuntimeException _ = False
+ test/Spec/Managed/Probe.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeApplications #-}++module Spec.Managed.Probe where++import Data.Typeable (Proxy(Proxy), TypeRep, typeRep)+import Managed.Probe+import Spec.Data+import Test.Hspec++myData :: TypeRep+myData = typeRep (Proxy @MyData)++spec :: Spec+spec = do+  describe "returns" $ do+    it "Finds the return type of a Probe" $ do+      returns probeN `shouldBe` myData+      returns probeIO `shouldBe` typeRep (Proxy @(IO MyData))+  describe "params" $ do+    it "Finds the param types of a Probe" $ do+      params probeN `shouldBe` []+      params probeIntCharStr `shouldBe` [int, char]
+ test/Spec/Managed/Probe/ToProbe.hs view
@@ -0,0 +1,27 @@+module Spec.Managed.Probe.ToProbe where++import Data.Typeable (typeOf)+import Managed hiding (describe)+import Managed.Exception+import Spec.Data+import Test.Hspec++spec :: Spec+spec = do+  describe "toProbe" $ do+    it "converts a nullary function (constant) to a Probe" $ do+      call probeN [] >>= (`shouldBe` show A)+    it "converts a unary function to a Probe" $ do+      call probeU [show B] >>= (`shouldBe` show B)+    it "converts a binary function to a Probe" $ do+      call probeB [show A, show B] >>= (`shouldBe` show C)+    it "converts an IO function to a Probe" $ do+      call probeIO [show A] >>= (`shouldBe` show A)+    it "rejects wrong number of parameters" $ do+      call probeN [show B] `shouldThrow` (== BadNumberOfArguments 0 1)+      call probeU [] `shouldThrow` (== BadNumberOfArguments 1 0)+      call probeU [show B, show B] `shouldThrow` (== BadNumberOfArguments 1 2)+      call probeB [show B] `shouldThrow` (== BadNumberOfArguments 2 1)+    it "creates the correct typeRep" $ do+      typeRep probeB `shouldBe` typeOf binary+      typeRep probeIO `shouldBe` typeOf unaryIO