diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2022 Michael Truog +Copyright (c) 2017-2023 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), diff --git a/cloudi.cabal b/cloudi.cabal --- a/cloudi.cabal +++ b/cloudi.cabal @@ -1,5 +1,5 @@ name: cloudi -version: 2.0.5 +version: 2.0.6 synopsis: Haskell CloudI API description: Haskell CloudI API (see https://cloudi.org for more details) homepage: https://github.com/CloudI/cloudi_api_haskell @@ -7,7 +7,7 @@ license-file: LICENSE author: Michael Truog maintainer: mjtruog at protonmail dot com -copyright: 2017-2022 Michael Truog +copyright: 2017-2023 Michael Truog category: Foreign stability: provisional build-type: Simple diff --git a/src/Foreign/CloudI.hs b/src/Foreign/CloudI.hs --- a/src/Foreign/CloudI.hs +++ b/src/Foreign/CloudI.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2022 Michael Truog + Copyright (c) 2017-2023 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -60,14 +60,19 @@ , returnSync , recvAsync , processIndex + , processIndex_ , processCount , processCountMax + , processCountMax_ , processCountMin + , processCountMin_ , prefix , timeoutInitialize + , timeoutInitialize_ , timeoutAsync , timeoutSync , timeoutTerminate + , timeoutTerminate_ , priorityDefault , poll , shutdown @@ -241,13 +246,7 @@ -- | returns the thread count from the service configuration threadCount :: IO (Result Int) -threadCount = do - threadCountValue <- POSIX.getEnv "CLOUDI_API_INIT_THREAD_COUNT" - case threadCountValue of - Nothing -> - return $ Left invalidInputError - Just threadCountStr -> - return $ Right (read threadCountStr :: Int) +threadCount = getEnvToUnsignedInt "CLOUDI_API_INIT_THREAD_COUNT" -- | subscribes to a service name pattern with a callback subscribe :: Instance.T s -> ByteString -> Instance.Callback s -> @@ -609,6 +608,10 @@ processIndex Instance.T{Instance.processIndex = processIndex'} = processIndex' +-- | returns the 0-based index of this process in the service instance +processIndex_ :: IO (Result Int) +processIndex_ = getEnvToUnsignedInt "CLOUDI_API_INIT_PROCESS_INDEX" + -- | returns the current process count based on the service configuration processCount :: Instance.T s -> Int processCount Instance.T{Instance.processCount = processCount'} = @@ -620,12 +623,22 @@ processCountMax Instance.T{Instance.processCountMax = processCountMax'} = processCountMax' +-- | returns the count_process_dynamic maximum count +-- based on the service configuration +processCountMax_ :: IO (Result Int) +processCountMax_ = getEnvToUnsignedInt "CLOUDI_API_INIT_PROCESS_COUNT_MAX" + -- | returns the count_process_dynamic minimum count -- based on the service configuration processCountMin :: Instance.T s -> Int processCountMin Instance.T{Instance.processCountMin = processCountMin'} = processCountMin' +-- | returns the count_process_dynamic minimum count +-- based on the service configuration +processCountMin_ :: IO (Result Int) +processCountMin_ = getEnvToUnsignedInt "CLOUDI_API_INIT_PROCESS_COUNT_MIN" + -- | returns the service name pattern prefix from the service configuration prefix :: Instance.T s -> ByteString prefix Instance.T{Instance.prefix = prefix'} = @@ -637,6 +650,11 @@ timeoutInitialize Instance.T{Instance.timeoutInitialize = timeoutInitialize'} = timeoutInitialize' +-- | returns the service initialization timeout +-- from the service configuration +timeoutInitialize_ :: IO (Result Int) +timeoutInitialize_ = getEnvToUnsignedInt "CLOUDI_API_INIT_TIMEOUT_INITIALIZE" + -- | returns the default asynchronous service request send timeout -- from the service configuration timeoutAsync :: Instance.T s -> Int @@ -655,6 +673,11 @@ timeoutTerminate Instance.T{Instance.timeoutTerminate = timeoutTerminate'} = timeoutTerminate' +-- | returns the service termination timeout +-- based on the service configuration +timeoutTerminate_ :: IO (Result Int) +timeoutTerminate_ = getEnvToUnsignedInt "CLOUDI_API_INIT_TIMEOUT_TERMINATE" + -- | returns the default service request send priority -- from the service configuration priorityDefault :: Instance.T s -> Int @@ -863,6 +886,7 @@ timeoutTerminate' <- Get.getWord32host priorityDefault' <- Get.getInt8 fatalExceptions' <- Get.getInt8 + bind <- Get.getInt32host let api1 = Instance.init api0 processIndex' processCount' @@ -876,7 +900,9 @@ priorityDefault' fatalExceptions' empty <- Get.isEmpty - if not empty then + if bind >= 0 then + fail invalidInputError + else if not empty then handleEvents messages api1 external 0 else return (messages, api1) @@ -1230,6 +1256,19 @@ setTerminate api0 = api0{ Instance.terminate = True , Instance.timeout = Just False} + +getEnvToUnsignedInt :: String -> IO (Result Int) +getEnvToUnsignedInt name = do + valueResult <- POSIX.getEnv name + case valueResult of + Nothing -> + return $ Left invalidInputError + Just valueStr -> + let value = read valueStr :: Int in + if value < 0 then + return $ Left invalidInputError + else + return $ Right value threadList :: Concurrent.MVar [Concurrent.MVar ()] threadList = Unsafe.unsafePerformIO (Concurrent.newMVar []) diff --git a/src/Foreign/Erlang.hs b/src/Foreign/Erlang.hs --- a/src/Foreign/Erlang.hs +++ b/src/Foreign/Erlang.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2022 Michael Truog + Copyright (c) 2017-2023 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -132,6 +132,10 @@ tagAtomUtf8Ext = 118 tagSmallAtomUtf8Ext :: Word8 tagSmallAtomUtf8Ext = 119 +tagV4PortExt :: Word8 +tagV4PortExt = 120 +tagLocalExt :: Word8 +tagLocalExt = 121 data OtpErlangTerm = OtpErlangInteger Int @@ -266,16 +270,23 @@ str <- Get.getByteString 31 let value = Char8.unpack $ Char8.takeWhile (\c -> c /= '\0') str return $ OtpErlangFloat (read value :: Double) - | tag == tagNewPortExt || + | tag == tagV4PortExt || tag == tagNewPortExt || tag == tagReferenceExt || tag == tagPortExt -> do (nodeTag, node) <- binaryToAtom - eid <- Get.getByteString 4 - let creationSize = if tag == tagNewPortExt then 4 else 1 + let idSize = if tag == tagV4PortExt then 8 else 4 + eid <- Get.getByteString idSize + let creationSize = + if tag == tagV4PortExt || tag == tagNewPortExt then + 4 + else + 1 creation <- Get.getByteString creationSize if tag == tagReferenceExt then return $ OtpErlangReference $ E.Reference nodeTag node eid creation - else -- tag == tagNewPortExt || tag == tagPortExt + else + -- tag == tagV4PortExt || tag == tagNewPortExt || + -- tag == tagPortExt return $ OtpErlangPort $ E.Port nodeTag node eid creation | tag == tagNewPidExt || tag == tagPidExt -> do @@ -381,6 +392,8 @@ fail err Right (_, _, term) -> return term + | tag == tagLocalExt -> + fail $ "LOCAL_EXT is opaque" | otherwise -> fail $ "invalid tag" @@ -395,31 +408,6 @@ value <- binaryToTerms return (key, value) -binaryToExportSize :: Get Int -binaryToExportSize = do - oldI <- Get.bytesRead - (_, _) <- binaryToAtom -- module - (_, _) <- binaryToAtom -- function - arityTag <- Get.getWord8 - _ <- Get.getWord8 -- arity - i <- Get.bytesRead - if arityTag == tagSmallIntegerExt then - return $ fromIntegral (i - oldI) - else - fail $ "invalid small integer tag" - -binaryToFunSize :: Get Int -binaryToFunSize = do - oldI <- Get.bytesRead - numfree <- Get.getWord32be - _ <- binaryToPid -- pid - (_, _) <- binaryToAtom -- module - _ <- binaryToInteger -- index - _ <- binaryToInteger -- uniq - _ <- binaryToTermSequence (getUnsignedInt32 numfree) -- free - i <- Get.bytesRead - return $ fromIntegral (i - oldI) - binaryToInteger :: Get Int binaryToInteger = do tag <- Get.getWord8 @@ -454,6 +442,31 @@ | otherwise -> fail $ "invalid pid tag" +binaryToExportSize :: Get Int +binaryToExportSize = do + oldI <- Get.bytesRead + (_, _) <- binaryToAtom -- module + (_, _) <- binaryToAtom -- function + arityTag <- Get.getWord8 + _ <- Get.getWord8 -- arity + i <- Get.bytesRead + if arityTag == tagSmallIntegerExt then + return $ fromIntegral (i - oldI) + else + fail $ "invalid small integer tag" + +binaryToFunSize :: Get Int +binaryToFunSize = do + oldI <- Get.bytesRead + numfree <- Get.getWord32be + _ <- binaryToPid -- pid + (_, _) <- binaryToAtom -- module + _ <- binaryToInteger -- index + _ <- binaryToInteger -- uniq + _ <- binaryToTermSequence (getUnsignedInt32 numfree) -- free + i <- Get.bytesRead + return $ fromIntegral (i - oldI) + binaryToAtom :: Get (Word8, ByteString) binaryToAtom = do tag <- Get.getWord8 @@ -594,7 +607,7 @@ let length = ByteString.length value in if length <= 4294967295 then ok $ Builder.toLazyByteString $ - Builder.word8 tagBinaryExt <> + Builder.word8 tagBitBinaryExt <> Builder.word32BE (fromIntegral length) <> Builder.word8 (fromIntegral bits) <> Builder.byteString value @@ -683,7 +696,9 @@ Builder.byteString creation termsToBinary (OtpErlangPort (E.Port nodeTag node eid creation)) = let tag = - if (ByteString.length creation) == 4 then + if (ByteString.length eid) == 8 then + tagV4PortExt + else if (ByteString.length creation) == 4 then tagNewPortExt else tagPortExt in