diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2021 Michael Truog +Copyright (c) 2017-2022 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/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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 ------ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ +module Main (main) where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/cloudi.cabal b/cloudi.cabal --- a/cloudi.cabal +++ b/cloudi.cabal @@ -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 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-2021 Michael Truog + Copyright (c) 2017-2022 Michael Truog 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) = diff --git a/src/Foreign/CloudI/Instance.hs b/src/Foreign/CloudI/Instance.hs --- a/src/Foreign/CloudI/Instance.hs +++ b/src/Foreign/CloudI/Instance.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017-2020 Michael Truog + Copyright (c) 2017-2022 Michael Truog 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 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-2019 Michael Truog + Copyright (c) 2017-2022 Michael Truog 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