cloudi 2.0.4 → 2.0.5
raw patch · 7 files changed
+128/−81 lines, 7 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +1/−1
- README.markdown +20/−6
- Setup.hs +4/−0
- cloudi.cabal +6/−4
- src/Foreign/CloudI.hs +59/−39
- src/Foreign/CloudI/Instance.hs +11/−7
- src/Foreign/Erlang.hs +27/−24
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2021 Michael Truog <mjtruog at protonmail dot com> +Copyright (c) 2017-2022 Michael Truog <mjtruog at protonmail dot com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),
README.markdown view
@@ -8,6 +8,21 @@ Build ----- +With cabal-install >= 3.4++ cabal v2-update+ mkdir sandbox+ cabal --store-dir=./sandbox v2-configure+ cabal v2-build++With cabal-install >= 2.4 and cabal-install < 3.4++ cabal v1-sandbox init+ cabal v1-update+ cabal v1-install --only-dependencies+ cabal v1-configure+ cabal v1-build+ With cabal-install < 2.4 cabal sandbox init@@ -16,13 +31,12 @@ cabal configure cabal build -With cabal-install >= 2.4+Without cabal-install - cabal v1-sandbox init- cabal v1-update- cabal v1-install --only-dependencies- cabal v1-configure- cabal v1-build+ mkdir -p dist/setup-bin+ ghc --make -outputdir dist/setup-bin -o dist/setup-bin/Setup ./Setup.hs+ dist/setup-bin/Setup configure --builddir=./dist --enable-deterministic --disable-shared --enable-static+ dist/setup-bin/Setup build Author ------
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
cloudi.cabal view
@@ -1,5 +1,5 @@ name: cloudi-version: 2.0.4+version: 2.0.5 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-2021 Michael Truog+copyright: 2017-2022 Michael Truog category: Foreign stability: provisional build-type: Simple@@ -17,8 +17,10 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.4 extra-source-files: README.markdown changelog.md flag dev
src/Foreign/CloudI.hs view
@@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2021 Michael Truog <mjtruog at protonmail dot com>+ Copyright (c) 2017-2022 Michael Truog <mjtruog at protonmail dot com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),@@ -79,7 +79,7 @@ import Prelude hiding (init,length,(<>)) import Data.Bits (shiftL,(.|.))-import Data.Maybe (fromMaybe)+import Data.Maybe (fromJust,fromMaybe) import Data.Typeable (Typeable) import qualified Control.Exception as Exception import qualified Control.Concurrent as Concurrent@@ -424,7 +424,8 @@ forwardAsyncI :: Instance.T s -> ByteString -> ByteString -> ByteString -> Int -> Int -> ByteString -> Source -> IO (Result (Instance.T s))-forwardAsyncI api0 name responseInfo response timeout priority transId pid = do+forwardAsyncI api0 name responseInfo response+ timeout priority transId source = do let forwardTerms = Erlang.OtpErlangTuple [ Erlang.OtpErlangAtom (Char8.pack "forward_async") , Erlang.OtpErlangString name@@ -433,7 +434,7 @@ , Erlang.OtpErlangInteger timeout , Erlang.OtpErlangInteger priority , Erlang.OtpErlangBinary transId- , Erlang.OtpErlangPid pid]+ , Erlang.OtpErlangPid source] case Erlang.termToBinary forwardTerms (-1) of Left err -> return $ Left $ show err@@ -445,9 +446,10 @@ forwardAsync :: Typeable s => Instance.T s -> ByteString -> ByteString -> ByteString -> Int -> Int -> ByteString -> Source -> IO ()-forwardAsync api0 name responseInfo response timeout priority transId pid = do+forwardAsync api0 name responseInfo response+ timeout priority transId source = do result <- forwardAsyncI api0- name responseInfo response timeout priority transId pid+ name responseInfo response timeout priority transId source case result of Left err -> error err@@ -457,7 +459,8 @@ forwardSyncI :: Instance.T s -> ByteString -> ByteString -> ByteString -> Int -> Int -> ByteString -> Source -> IO (Result (Instance.T s))-forwardSyncI api0 name responseInfo response timeout priority transId pid = do+forwardSyncI api0 name responseInfo response+ timeout priority transId source = do let forwardTerms = Erlang.OtpErlangTuple [ Erlang.OtpErlangAtom (Char8.pack "forward_sync") , Erlang.OtpErlangString name@@ -466,7 +469,7 @@ , Erlang.OtpErlangInteger timeout , Erlang.OtpErlangInteger priority , Erlang.OtpErlangBinary transId- , Erlang.OtpErlangPid pid]+ , Erlang.OtpErlangPid source] case Erlang.termToBinary forwardTerms (-1) of Left err -> return $ Left $ show err@@ -478,9 +481,10 @@ forwardSync :: Typeable s => Instance.T s -> ByteString -> ByteString -> ByteString -> Int -> Int -> ByteString -> Source -> IO ()-forwardSync api0 name responseInfo response timeout priority transId pid = do+forwardSync api0 name responseInfo response+ timeout priority transId source = do result <- forwardSyncI api0- name responseInfo response timeout priority transId pid+ name responseInfo response timeout priority transId source case result of Left err -> error err@@ -498,7 +502,8 @@ returnAsyncI :: Instance.T s -> ByteString -> ByteString -> ByteString -> ByteString -> Int -> ByteString -> Source -> IO (Result (Instance.T s))-returnAsyncI api0 name pattern responseInfo response timeout transId pid = do+returnAsyncI api0 name pattern responseInfo response+ timeout transId source = do let returnTerms = Erlang.OtpErlangTuple [ Erlang.OtpErlangAtom (Char8.pack "return_async") , Erlang.OtpErlangString name@@ -507,7 +512,7 @@ , Erlang.OtpErlangBinary response , Erlang.OtpErlangInteger timeout , Erlang.OtpErlangBinary transId- , Erlang.OtpErlangPid pid]+ , Erlang.OtpErlangPid source] case Erlang.termToBinary returnTerms (-1) of Left err -> return $ Left $ show err@@ -519,9 +524,10 @@ returnAsync :: Typeable s => Instance.T s -> ByteString -> ByteString -> ByteString -> ByteString -> Int -> ByteString -> Source -> IO ()-returnAsync api0 name pattern responseInfo response timeout transId pid = do+returnAsync api0 name pattern responseInfo response+ timeout transId source = do result <- returnAsyncI api0- name pattern responseInfo response timeout transId pid+ name pattern responseInfo response timeout transId source case result of Left err -> error err@@ -531,7 +537,8 @@ returnSyncI :: Instance.T s -> ByteString -> ByteString -> ByteString -> ByteString -> Int -> ByteString -> Source -> IO (Result (Instance.T s))-returnSyncI api0 name pattern responseInfo response timeout transId pid = do+returnSyncI api0 name pattern responseInfo response+ timeout transId source = do let returnTerms = Erlang.OtpErlangTuple [ Erlang.OtpErlangAtom (Char8.pack "return_sync") , Erlang.OtpErlangString name@@ -540,7 +547,7 @@ , Erlang.OtpErlangBinary response , Erlang.OtpErlangInteger timeout , Erlang.OtpErlangBinary transId- , Erlang.OtpErlangPid pid]+ , Erlang.OtpErlangPid source] case Erlang.termToBinary returnTerms (-1) of Left err -> return $ Left $ show err@@ -552,9 +559,10 @@ returnSync :: Typeable s => Instance.T s -> ByteString -> ByteString -> ByteString -> ByteString -> Int -> ByteString -> Source -> IO ()-returnSync api0 name pattern responseInfo response timeout transId pid = do+returnSync api0 name pattern responseInfo response+ timeout transId source = do result <- returnSyncI api0- name pattern responseInfo response timeout transId pid+ name pattern responseInfo response timeout transId source case result of Left err -> error err@@ -664,8 +672,9 @@ printException $ show e POSIX.exitImmediately (Exit.ExitFailure 1) -callbackException :: SomeException -> IO ()-callbackException e+callbackException :: Instance.T s -> SomeException -> IO ()+callbackException Instance.T{+ Instance.fatalExceptions = fatalExceptions} e | Just _ <- (Exception.fromException e :: Maybe AsyncException) = callbackExceptionFatal e | Just _ <- (Exception.fromException e :: Maybe SomeAsyncException) =@@ -677,7 +686,10 @@ | Just exitCode <- (Exception.fromException e :: Maybe ExitCode) = POSIX.exitImmediately exitCode | otherwise =- printException $ show e+ if fatalExceptions then+ callbackExceptionFatal e+ else+ printException $ show e callback :: Typeable s => Instance.T s -> (RequestType, ByteString, ByteString, ByteString, ByteString,@@ -686,7 +698,7 @@ Instance.state = state , Instance.callbacks = callbacks} (requestType, name, pattern, requestInfo, request,- timeout, priority, transId, pid) = do+ timeout, priority, transId, source) = do let (callbackF, callbacksNew) = case Map.lookup pattern callbacks of Nothing -> (nullResponse, callbacks)@@ -702,7 +714,7 @@ Instance.ASYNC -> do callbackResultAsyncValue <- Exception.try $ callbackF requestType name pattern- requestInfo request timeout priority transId pid+ requestInfo request timeout priority transId source state api1 case callbackResultAsyncValue of Left (Terminate api2) ->@@ -733,7 +745,7 @@ Instance.SYNC -> do callbackResultSyncValue <- Exception.try $ callbackF requestType name pattern- requestInfo request timeout priority transId pid+ requestInfo request timeout priority transId source state api1 case callbackResultSyncValue of Left (Terminate api2) ->@@ -763,7 +775,7 @@ return $ ReturnI (empty, empty, v0, v1) callbackResultType <- case callbackResultValue of Left exception -> do- callbackException exception+ callbackException api1 exception return $ ReturnI (empty, empty, state, api1) Right callbackResult -> return $ callbackResult@@ -774,24 +786,26 @@ return $ Right api3 ReturnI (responseInfo, response, state', api3) -> returnAsyncI api3{Instance.state = state'}- name pattern responseInfo response timeout transId pid+ name pattern responseInfo response+ timeout transId source ForwardI (name', requestInfo', request', timeout', priority', state', api3) -> forwardAsyncI api3{Instance.state = state'} name' requestInfo' request'- timeout' priority' transId pid+ timeout' priority' transId source Instance.SYNC -> case callbackResultType of Finished api3 -> return $ Right api3 ReturnI (responseInfo, response, state', api3) -> returnSyncI api3{Instance.state = state'}- name pattern responseInfo response timeout transId pid+ name pattern responseInfo response+ timeout transId source ForwardI (name', requestInfo', request', timeout', priority', state', api3) -> forwardSyncI api3{Instance.state = state'} name' requestInfo' request'- timeout' priority' transId pid+ timeout' priority' transId source handleEvents :: [Message] -> Instance.T s -> Bool -> Word32 -> Get ([Message], Instance.T s)@@ -808,11 +822,13 @@ timeoutAsync' <- Get.getWord32host timeoutSync' <- Get.getWord32host priorityDefault' <- Get.getInt8+ fatalExceptions' <- Get.getInt8 let api1 = Instance.reinit api0 processCount' timeoutAsync' timeoutSync' priorityDefault'+ fatalExceptions' empty <- Get.isEmpty if not empty then handleEvents messages api1 external 0@@ -846,6 +862,7 @@ timeoutSync' <- Get.getWord32host timeoutTerminate' <- Get.getWord32host priorityDefault' <- Get.getInt8+ fatalExceptions' <- Get.getInt8 let api1 = Instance.init api0 processIndex' processCount'@@ -857,6 +874,7 @@ timeoutSync' timeoutTerminate' priorityDefault'+ fatalExceptions' empty <- Get.isEmpty if not empty then handleEvents messages api1 external 0@@ -878,13 +896,13 @@ timeout <- Get.getWord32host priority <- Get.getInt8 transId <- Get.getByteString 16- pidSize <- Get.getWord32host- pidData <- Get.getLazyByteString $ fromIntegral pidSize+ sourceSize <- Get.getWord32host+ sourceData <- Get.getLazyByteString $ fromIntegral sourceSize empty <- Get.isEmpty- case Erlang.binaryToTerm pidData of+ case Erlang.binaryToTerm sourceData of Left err -> fail $ show err- Right (Erlang.OtpErlangPid (pid)) ->+ Right (Erlang.OtpErlangPid (source)) -> let requestType = if cmd == messageSendAsync then Instance.ASYNC@@ -893,7 +911,7 @@ messagesNew = (MessageSend ( requestType, name, pattern, requestInfo, request, fromIntegral timeout, fromIntegral priority,- transId, pid)):messages in+ transId, source)):messages in if not empty then handleEvents messagesNew api0 external 0 else@@ -950,11 +968,13 @@ timeoutAsync' <- Get.getWord32host timeoutSync' <- Get.getWord32host priorityDefault' <- Get.getInt8+ fatalExceptions' <- Get.getInt8 let api1 = Instance.reinit api0 processCount' timeoutAsync' timeoutSync' priorityDefault'+ fatalExceptions' empty <- Get.isEmpty if not empty then pollRequestDataGet messages api1 external@@ -1155,17 +1175,17 @@ (bufferRecvHeader, bufferRecvHeaderSize) <- recvBuffer bufferRecv bufferRecvSize 4 socketHandle bufferSize let header0 = Builder.toLazyByteString bufferRecvHeader- Just (byte0, header1) = LazyByteString.uncons header0- Just (byte1, header2) = LazyByteString.uncons header1- Just (byte2, header3) = LazyByteString.uncons header2- Just (byte3, headerRemaining) = LazyByteString.uncons header3+ (byte0, header1) = fromJust $ LazyByteString.uncons header0+ (byte1, header2) = fromJust $ LazyByteString.uncons header1+ (byte2, header3) = fromJust $ LazyByteString.uncons header2+ (byte3, remaining) = fromJust $ LazyByteString.uncons header3 total = fromIntegral $ (fromIntegral byte0 :: Word32) `shiftL` 24 .|. (fromIntegral byte1 :: Word32) `shiftL` 16 .|. (fromIntegral byte2 :: Word32) `shiftL` 8 .|. (fromIntegral byte3 :: Word32) :: Int (bufferRecvAll, bufferRecvAllSize) <- recvBuffer- (Builder.lazyByteString headerRemaining)+ (Builder.lazyByteString remaining) (bufferRecvHeaderSize - 4) total socketHandle bufferSize let bufferRecvAllStr = Builder.toLazyByteString bufferRecvAll (bufferRecvData, bufferRecvNew) =
src/Foreign/CloudI/Instance.hs view
@@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2020 Michael Truog <mjtruog at protonmail dot com>+ Copyright (c) 2017-2022 Michael Truog <mjtruog at protonmail dot com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),@@ -103,6 +103,7 @@ , socketHandle :: !Handle , useHeader :: !Bool , initializationComplete :: !Bool+ , fatalExceptions :: !Bool , terminate :: !Bool , timeout :: !(Maybe Bool) , callbacks :: !(Map ByteString (Seq (Callback s)))@@ -155,6 +156,7 @@ , socketHandle = socketHandle' , useHeader = useHeader' , initializationComplete = False+ , fatalExceptions = False , terminate = False , timeout = Nothing , callbacks = Map.empty@@ -179,11 +181,11 @@ } init :: T s -> Word32 -> Word32 -> Word32 -> Word32 -> ByteString ->- Word32 -> Word32 -> Word32 -> Word32 -> Int8 -> T s+ Word32 -> Word32 -> Word32 -> Word32 -> Int8 -> Int8 -> T s init api0 processIndex' processCount' processCountMax' processCountMin' prefix' timeoutInitialize' timeoutAsync' timeoutSync' timeoutTerminate'- priorityDefault' =+ priorityDefault' fatalExceptions' = api0{ timeout = Just False , processIndex = fromIntegral processIndex'@@ -195,17 +197,19 @@ , timeoutAsync = fromIntegral timeoutAsync' , timeoutSync = fromIntegral timeoutSync' , timeoutTerminate = fromIntegral timeoutTerminate'- , priorityDefault = fromIntegral priorityDefault'}+ , priorityDefault = fromIntegral priorityDefault'+ , fatalExceptions = toEnum (fromIntegral fatalExceptions')} -reinit :: T s -> Word32 -> Word32 -> Word32 -> Int8 -> T s+reinit :: T s -> Word32 -> Word32 -> Word32 -> Int8 -> Int8 -> T s reinit api0 processCount' timeoutAsync' timeoutSync'- priorityDefault' =+ priorityDefault' fatalExceptions' = api0{ processCount = fromIntegral processCount' , timeoutAsync = fromIntegral timeoutAsync' , timeoutSync = fromIntegral timeoutSync'- , priorityDefault = fromIntegral priorityDefault'}+ , priorityDefault = fromIntegral priorityDefault'+ , fatalExceptions = toEnum (fromIntegral fatalExceptions')} setResponse :: T s -> ByteString -> ByteString -> ByteString -> T s setResponse api0
src/Foreign/Erlang.hs view
@@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2019 Michael Truog <mjtruog at protonmail dot com>+ Copyright (c) 2017-2022 Michael Truog <mjtruog at protonmail dot com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),@@ -27,7 +27,7 @@ -} --- | Erlang Binary Term Format Encoding/Decoding+-- | Erlang External Term Format Encoding/Decoding module Foreign.Erlang ( OtpErlangTerm(..)@@ -266,10 +266,6 @@ str <- Get.getByteString 31 let value = Char8.unpack $ Char8.takeWhile (\c -> c /= '\0') str return $ OtpErlangFloat (read value :: Double)- | tag == tagAtomExt -> do- j <- Get.getWord16be- value <- Get.getByteString $ getUnsignedInt16 j- return $ OtpErlangAtom value | tag == tagNewPortExt || tag == tagReferenceExt || tag == tagPortExt -> do (nodeTag, node) <- binaryToAtom@@ -340,15 +336,6 @@ eid <- Get.getByteString $ (getUnsignedInt16 j) * 4 return $ OtpErlangReference $ E.Reference nodeTag node eid creation- | tag == tagSmallAtomExt -> do- j <- Get.getWord8- value <- Get.getByteString $ getUnsignedInt8 j- if value == boolTrue then- return $ OtpErlangAtomBool True- else if value == boolFalse then- return $ OtpErlangAtomBool False- else- return $ OtpErlangAtom value | tag == tagMapExt -> do length <- Get.getWord32be pairs <- replicateM (getUnsignedInt32 length) binaryToMapPair@@ -358,14 +345,28 @@ value <- Get.getByteString length return $ OtpErlangFunction $ E.Function tag value- | tag == tagAtomUtf8Ext -> do+ | tag == tagAtomUtf8Ext || tag == tagAtomExt -> do j <- Get.getWord16be value <- Get.getByteString $ getUnsignedInt16 j- return $ OtpErlangAtomUTF8 value- | tag == tagSmallAtomUtf8Ext -> do+ if value == boolTrue then+ return $ OtpErlangAtomBool True+ else if value == boolFalse then+ return $ OtpErlangAtomBool False+ else if tag == tagAtomUtf8Ext then+ return $ OtpErlangAtomUTF8 value+ else+ return $ OtpErlangAtom value+ | tag == tagSmallAtomUtf8Ext || tag == tagSmallAtomExt -> do j <- Get.getWord8 value <- Get.getByteString $ getUnsignedInt8 j- return $ OtpErlangAtomUTF8 value+ if value == boolTrue then+ return $ OtpErlangAtomBool True+ else if value == boolFalse then+ return $ OtpErlangAtomBool False+ else if tag == tagSmallAtomUtf8Ext then+ return $ OtpErlangAtomUTF8 value+ else+ return $ OtpErlangAtom value | tag == tagCompressedZlib -> do sizeUncompressed <- Get.getWord32be compressed <- Get.getRemainingLazyByteString@@ -520,6 +521,8 @@ Builder.word8 tagNewFloatExt <> Builder.doubleBE value termsToBinary (OtpErlangAtom value) =+ -- deprecated+ -- (not used in Erlang/OTP 26, i.e., minor_version 2) let length = ByteString.length value in if length <= 255 then ok $ Builder.toLazyByteString $@@ -553,9 +556,9 @@ Builder.word8 (fromIntegral value) termsToBinary (OtpErlangAtomBool value) = if value then- termsToBinary $ OtpErlangAtom $ Char8.pack "true"+ termsToBinary $ OtpErlangAtomUTF8 $ Char8.pack "true" else- termsToBinary $ OtpErlangAtom $ Char8.pack "false"+ termsToBinary $ OtpErlangAtomUTF8 $ Char8.pack "false" termsToBinary (OtpErlangString value) = let length = ByteString.length value in if length == 0 then@@ -667,7 +670,7 @@ errorType $ OutputError "uint32 overflow" termsToBinary (OtpErlangPid (E.Pid nodeTag node eid serial creation)) = let tag =- if (ByteString.length creation) == 4 then + if (ByteString.length creation) == 4 then tagNewPidExt else tagPidExt in@@ -680,7 +683,7 @@ Builder.byteString creation termsToBinary (OtpErlangPort (E.Port nodeTag node eid creation)) = let tag =- if (ByteString.length creation) == 4 then + if (ByteString.length creation) == 4 then tagNewPortExt else tagPortExt in@@ -701,7 +704,7 @@ Builder.byteString creation else if length <= 65535 then let tag =- if (ByteString.length creation) == 4 then + if (ByteString.length creation) == 4 then tagNewerReferenceExt else tagNewReferenceExt in