diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 1a866395..a7db92a9 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -158,6 +158,7 @@ instance ( Serialise (PeerCredentials e) where bs = LBS.toStrict $ serialise c +-- FIXME: move-thouse-instances-to-appropriate-place-ASAP instance Pretty (AsBase58 Sign.PublicKey) where pretty (AsBase58 pk) = pretty $ B8.unpack $ toBase58 (Crypto.encode pk) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 0def4283..7c365324 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -42,6 +42,8 @@ import Crypto.Saltine.Core.Sign qualified as Sign import Crypto.Saltine.Core.Box qualified as Encrypt + +-- FIXME: move-to-types-crypto-ASAP type instance Encryption L4Proto = HBS2Basic type instance Encryption UNIX = HBS2Basic diff --git a/hbs2-core/lib/HBS2/Net/Proto/Service.hs b/hbs2-core/lib/HBS2/Net/Proto/Service.hs index 0da8c1ef..1e0b95de 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Service.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Service.hs @@ -27,7 +27,7 @@ import System.Random (randomIO) import Data.Word import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap - +import Control.Exception (bracket_) type family Input a :: Type type family Output a :: Type @@ -243,22 +243,24 @@ callService caller input = do resp <- UIO.newTQueueIO - atomically $ do - UIO.modifyTVar (callWaiters caller) (HashMap.insert (reqNum req) resp) - UIO.writeTQueue (callInQ caller) req + let addWaiter = atomically $ do + UIO.modifyTVar (callWaiters caller) (HashMap.insert (reqNum req) resp) + UIO.writeTQueue (callInQ caller) req - msg <- atomically $ UIO.readTQueue resp + let removeWaiter = atomically $ + UIO.modifyTVar (callWaiters caller) (HashMap.delete (reqNum req)) - case msg of - ServiceResponse _ (Right bs) -> do - case deserialiseOrFail @(Output method) bs of - Left _ -> pure (Left ErrorInvalidResponse) - Right x -> pure (Right x) + liftIO $ bracket_ addWaiter removeWaiter $ do + msg <- atomically $ UIO.readTQueue resp + case msg of + ServiceResponse _ (Right bs) -> + case deserialiseOrFail @(Output method) bs of + Left _ -> pure (Left ErrorInvalidResponse) + Right x -> pure (Right x) - ServiceResponse _ (Left wtf) -> pure (Left wtf) - - _ -> pure (Left ErrorInvalidResponse) + ServiceResponse _ (Left wtf) -> pure (Left wtf) + _ -> pure (Left ErrorInvalidResponse) makeClient :: forall api e m . ( MonadIO m diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 30cb280c..9d581f75 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -46,6 +46,9 @@ import GHC.Generics import Data.Time.Clock (NominalDiffTime(..)) import Codec.Serialise +import UnliftIO +import Control.Monad.IO.Unlift + none :: forall m . Monad m => m () none = pure ()