@@ -1,4 +1,4 @@
1−{-# LANGUAGE DerivingVia, DeriveGeneric, RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, OverloadedStrings, GeneralizedNewtypeDeriving, CPP, ExistentialQuantification, StandaloneDeriving, GADTs #-}
1+{-# LANGUAGE DerivingVia, DeriveGeneric, RankNTypes, ScopedTypeVariables, MultiParamTypeClasses, OverloadedStrings, GeneralizedNewtypeDeriving, CPP, ExistentialQuantification, StandaloneDeriving, GADTs, RecordWildCards #-}
22{-# OPTIONS_GHC -fno-warn-orphans #-}
33{- HLINT ignore "Use lambda-case" -}
44module Network.RPC.Curryer.Server where
@@ -35,13 +35,13 @@ import Data.Hashable
3535import System.Timeout
3636import qualified Network.ByteOrder as BO
3737
38+
3839-- for toArrayS conversion
39−{-import qualified Data.ByteString.Internal as BSI
40−import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as SA
41−import Foreign.ForeignPtr (plusForeignPtr)
40+import qualified Data.ByteString.Internal as BSI
41+import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as Arr
4242import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
43−import GHC.Ptr (plusPtr)
44−-}
43+import GHC.Ptr (minusPtr)
44+
4545-- define CURRYER_SHOW_BYTES 1
4646#if CURRYER_SHOW_BYTES == 1
4747import Debug.Trace
@@ -111,13 +111,14 @@ data ConnectionState a = ConnectionState {
111111 connectionSocket :: Locking Socket
112112 }
113113
114−-- | Used by server-side request handlers to send additional messages to the client. This is useful for sending asynchronous responses to the client outside of the normal request-response flow.
115−sendMessage :: Serialise a => ConnectionState s -> a -> IO ()
116−sendMessage sState msg = do
114+-- | Used by server-side request handlers to send additional messages to the client. This is useful for sending asynchronous responses to the client outside of the normal request-response flow. The locking socket can be found in the ConnectionState when a request handler is called.
115+sendMessage :: Serialise a => Locking Socket -> a -> IO ()
116+sendMessage lockSock msg = do
117117 requestID <- UUID <$> UUIDBase.nextRandom
118118 let env =
119− Envelope (fingerprint msg) (RequestMessage 0) requestID (serialise msg)
120− sendEnvelope env (connectionSocket sState)
119+ Envelope (fingerprint msg) (RequestMessage timeout') requestID (serialise msg)
120+ timeout' = 0
121+ sendEnvelope env lockSock
121122
122123--avoid orphan instance
123124newtype UUID = UUID { _unUUID :: UUIDBase.UUID }
@@ -158,8 +159,7 @@ localHostAddr = (127,0,0,1)
158159-- Each message is length-prefixed by a 32-bit unsigned length.
159160envelopeP :: Parser IO Word8 Envelope
160161envelopeP = do
161− let s = FL.toList
162− msgTypeP = (P.satisfy (== 0) *>
162+ let msgTypeP = (P.satisfy (== 0) *>
163163 (RequestMessage . fromIntegral <$> word32P)) `P.alt`
164164 (P.satisfy (== 1) $> ResponseMessage) `P.alt`
165165 (P.satisfy (== 2) $> TimeoutResponseMessage) `P.alt`
@@ -170,7 +170,7 @@ envelopeP = do
170170 if c == 0 then
171171 pure BS.empty
172172 else
173− BS.pack <$> P.takeEQ c s
173+ fromArray <$> P.takeEQ c (Arr.writeN c)
174174 Envelope <$> fingerprintP <*> msgTypeP <*> uuidP <*> lenPrefixedByteStringP
175175
176176encodeEnvelope :: Envelope -> BS.ByteString
@@ -333,3 +333,10 @@ sendEnvelope envelope sockLock = do
333333fingerprint :: Typeable a => a -> Fingerprint
334334fingerprint = typeRepFingerprint . typeOf
335335
336+fromArray :: Arr.Array Word8 -> BSI.ByteString
337+fromArray Arr.Array {..}
338+ | aLen == 0 = mempty
339+ | otherwise = BSI.PS aStart 0 aLen
340+ where
341+ aStartPtr = unsafeForeignPtrToPtr aStart
342+ aLen = aEnd `minusPtr` aStartPtr