diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2018 Michael Truog +Copyright (c) 2017-2019 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,11 +8,21 @@ Build ----- +With cabal-install < 2.4 + cabal sandbox init cabal update cabal install --only-dependencies cabal configure cabal build + +With cabal-install >= 2.4 + + cabal v1-sandbox init + cabal v1-update + cabal v1-install --only-dependencies + cabal v1-configure + cabal v1-build Author ------ diff --git a/cloudi.cabal b/cloudi.cabal --- a/cloudi.cabal +++ b/cloudi.cabal @@ -1,5 +1,5 @@ name: cloudi -version: 1.7.5 +version: 1.8.0 synopsis: Haskell CloudI API description: Haskell CloudI API (see https://cloudi.org for more details) homepage: https://github.com/CloudI/cloudi_api_haskell @@ -7,14 +7,24 @@ license-file: LICENSE author: Michael Truog maintainer: mjtruog at protonmail dot com -copyright: 2017-2018 Michael Truog +copyright: 2017-2019 Michael Truog category: Foreign stability: provisional build-type: Simple cabal-version: 1.22 -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +tested-with: GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.3 + , GHC == 8.6.5 + , GHC == 8.8.1 extra-source-files: README.markdown changelog.md +flag dev + description: Turn on development settings. + manual: True + default: False + library hs-source-dirs: src exposed-modules: Foreign.CloudI @@ -24,13 +34,16 @@ , Foreign.Erlang.Reference , Foreign.Erlang.Function other-modules: Foreign.CloudI.Instance - ghc-options: -Wall -funbox-strict-fields - build-depends: base >= 4.8.2.0 && < 5 + if flag(dev) + ghc-options: -Wall -Werror -funbox-strict-fields + else + ghc-options: -Wall -funbox-strict-fields + build-depends: base >= 4.8.2.0 && < 5.0 , binary >= 0.8.4.0 , bytestring >= 0.10.4 + , network >= 3.0.0.0 , array , containers - , network , time , unix , zlib 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-2018 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -68,6 +68,7 @@ , timeoutSync , timeoutTerminate , poll + , shutdown , threadCreate , threadsWait , infoKeyValueParse @@ -995,6 +996,22 @@ poll :: Typeable s => Instance.T s -> Int -> IO (Result (Bool, Instance.T s)) poll api0 timeout = pollRequest api0 timeout True + +-- | shutdown the service successfully +shutdown :: Instance.T s -> Maybe ByteString -> + IO (Result (Instance.T s)) +shutdown api0 reasonOpt = + let reason = fromMaybe Char8.empty reasonOpt + shutdownTerms = Erlang.OtpErlangTuple + [ Erlang.OtpErlangAtom (Char8.pack "shutdown") + , Erlang.OtpErlangString reason] + in + case Erlang.termToBinary shutdownTerms (-1) of + Left err -> + return $ Left $ show err + Right shutdownBinary -> do + send api0 shutdownBinary + return $ Right $ api0 send :: Instance.T s -> LazyByteString -> IO () send Instance.T{ 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 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -131,14 +131,11 @@ makeSocket :: String -> C.CInt -> IO Socket makeSocket "local" fd = - Socket.mkSocket fd Socket.AF_UNIX Socket.Stream - Socket.defaultProtocol Socket.Connected + Socket.mkSocket fd makeSocket "tcp" fd = - Socket.mkSocket fd Socket.AF_INET Socket.Stream - Socket.defaultProtocol Socket.Connected + Socket.mkSocket fd makeSocket "udp" fd = - Socket.mkSocket fd Socket.AF_INET Socket.Datagram - Socket.defaultProtocol Socket.Connected + Socket.mkSocket fd makeSocket _ _ = error "invalid protocol" 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-2018 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -80,6 +80,12 @@ tagBitBinaryExt = 77 tagAtomCacheRef :: Word8 tagAtomCacheRef = 78 +tagNewPidExt :: Word8 +tagNewPidExt = 88 +tagNewPortExt :: Word8 +tagNewPortExt = 89 +tagNewerReferenceExt :: Word8 +tagNewerReferenceExt = 90 tagSmallIntegerExt :: Word8 tagSmallIntegerExt = 97 tagIntegerExt :: Word8 @@ -264,23 +270,24 @@ j <- Get.getWord16be value <- Get.getByteString $ getUnsignedInt16 j return $ OtpErlangAtom value - | tag == tagReferenceExt || tag == tagPortExt -> do + | tag == tagNewPortExt || + tag == tagReferenceExt || tag == tagPortExt -> do (nodeTag, node) <- binaryToAtom eid <- Get.getByteString 4 - creation <- Get.getWord8 + let creationSize = if tag == tagNewPortExt then 4 else 1 + creation <- Get.getByteString creationSize if tag == tagReferenceExt then return $ OtpErlangReference $ E.Reference nodeTag node eid creation - else if tag == tagPortExt then + else -- tag == tagNewPortExt || tag == tagPortExt return $ OtpErlangPort $ E.Port nodeTag node eid creation - else - fail $ "invalid" - | tag == tagPidExt -> do + | tag == tagNewPidExt || tag == tagPidExt -> do (nodeTag, node) <- binaryToAtom eid <- Get.getByteString 4 serial <- Get.getByteString 4 - creation <- Get.getWord8 + let creationSize = if tag == tagNewPidExt then 4 else 1 + creation <- Get.getByteString creationSize return $ OtpErlangPid $ E.Pid nodeTag node eid serial creation | tag == tagSmallTupleExt || tag == tagLargeTupleExt -> do @@ -325,10 +332,11 @@ value <- Get.getByteString length return $ OtpErlangFunction $ E.Function tag value - | tag == tagNewReferenceExt -> do + | tag == tagNewerReferenceExt || tag == tagNewReferenceExt -> do j <- Get.getWord16be (nodeTag, node) <- binaryToAtom - creation <- Get.getWord8 + let creationSize = if tag == tagNewerReferenceExt then 4 else 1 + creation <- Get.getByteString creationSize eid <- Get.getByteString $ (getUnsignedInt16 j) * 4 return $ OtpErlangReference $ E.Reference nodeTag node eid creation @@ -428,13 +436,20 @@ binaryToPid = do tag <- Get.getWord8 case () of - _ | tag == tagPidExt -> do + _ | tag == tagNewPidExt -> do (nodeTag, node) <- binaryToAtom eid <- Get.getByteString 4 serial <- Get.getByteString 4 - creation <- Get.getWord8 + creation <- Get.getByteString 4 return $ E.Pid nodeTag node eid serial creation + | tag == tagPidExt -> do + (nodeTag, node) <- binaryToAtom + eid <- Get.getByteString 4 + serial <- Get.getByteString 4 + creation <- Get.getByteString 1 + return $ E.Pid + nodeTag node eid serial creation | otherwise -> fail $ "invalid pid tag" @@ -651,20 +666,30 @@ else errorType $ OutputError "uint32 overflow" termsToBinary (OtpErlangPid (E.Pid nodeTag node eid serial creation)) = + let tag = + if (ByteString.length creation) == 4 then + tagNewPidExt + else + tagPidExt in ok $ Builder.toLazyByteString $ - Builder.word8 tagPidExt <> + Builder.word8 tag <> Builder.word8 nodeTag <> Builder.byteString node <> Builder.byteString eid <> Builder.byteString serial <> - Builder.word8 creation + Builder.byteString creation termsToBinary (OtpErlangPort (E.Port nodeTag node eid creation)) = + let tag = + if (ByteString.length creation) == 4 then + tagNewPortExt + else + tagPortExt in ok $ Builder.toLazyByteString $ - Builder.word8 tagPortExt <> + Builder.word8 tag <> Builder.word8 nodeTag <> Builder.byteString node <> Builder.byteString eid <> - Builder.word8 creation + Builder.byteString creation termsToBinary (OtpErlangReference (E.Reference nodeTag node eid creation)) = let length = (ByteString.length eid) `quot` 4 in if length == 0 then @@ -673,14 +698,19 @@ Builder.word8 nodeTag <> Builder.byteString node <> Builder.byteString eid <> - Builder.word8 creation + Builder.byteString creation else if length <= 65535 then + let tag = + if (ByteString.length creation) == 4 then + tagNewerReferenceExt + else + tagNewReferenceExt in ok $ Builder.toLazyByteString $ - Builder.word8 tagNewReferenceExt <> + Builder.word8 tag <> Builder.word16BE (fromIntegral length) <> Builder.word8 nodeTag <> Builder.byteString node <> - Builder.word8 creation <> + Builder.byteString creation <> Builder.byteString eid else errorType $ OutputError "uint16 overflow" diff --git a/src/Foreign/Erlang/Pid.hs b/src/Foreign/Erlang/Pid.hs --- a/src/Foreign/Erlang/Pid.hs +++ b/src/Foreign/Erlang/Pid.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -42,6 +42,6 @@ , node :: !ByteString , id :: !ByteString , serial :: !ByteString - , creation :: !Word8 + , creation :: !ByteString } deriving (Ord, Eq, Show) diff --git a/src/Foreign/Erlang/Port.hs b/src/Foreign/Erlang/Port.hs --- a/src/Foreign/Erlang/Port.hs +++ b/src/Foreign/Erlang/Port.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -41,6 +41,6 @@ { nodeTag :: !Word8 , node :: !ByteString , id :: !ByteString - , creation :: !Word8 + , creation :: !ByteString } deriving (Ord, Eq, Show) diff --git a/src/Foreign/Erlang/Reference.hs b/src/Foreign/Erlang/Reference.hs --- a/src/Foreign/Erlang/Reference.hs +++ b/src/Foreign/Erlang/Reference.hs @@ -5,7 +5,7 @@ MIT License - Copyright (c) 2017 Michael Truog + Copyright (c) 2017-2019 Michael Truog Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), @@ -41,6 +41,6 @@ { nodeTag :: !Word8 , node :: !ByteString , id :: !ByteString - , creation :: !Word8 + , creation :: !ByteString } deriving (Ord, Eq, Show)