module Erebos.Network.Protocol (
TransportPacket(..),
transportToObject,
TransportHeader(..),
TransportHeaderItem(..),
WaitingRef(..),
WaitingRefCallback,
wrDigest,
ChannelState(..),
ControlRequest(..),
ControlMessage(..),
erebosNetworkProtocol,
Connection,
connAddress,
connData,
connGetChannel,
connSetChannel,
module Erebos.Flow,
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import System.Clock
import Erebos.Channel
import Erebos.Flow
import Erebos.Identity
import Erebos.Service
import Erebos.Storage
protocolVersion :: Text
protocolVersion :: Text
protocolVersion = String -> Text
T.pack String
"0.1"
protocolVersions :: [Text]
protocolVersions :: [Text]
protocolVersions = [Text
protocolVersion]
data TransportPacket a = TransportPacket TransportHeader [a]
data = [TransportHeaderItem]
deriving (Int -> TransportHeader -> ShowS
[TransportHeader] -> ShowS
TransportHeader -> String
(Int -> TransportHeader -> ShowS)
-> (TransportHeader -> String)
-> ([TransportHeader] -> ShowS)
-> Show TransportHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportHeader -> ShowS
showsPrec :: Int -> TransportHeader -> ShowS
$cshow :: TransportHeader -> String
show :: TransportHeader -> String
$cshowList :: [TransportHeader] -> ShowS
showList :: [TransportHeader] -> ShowS
Show)
data
= Acknowledged RefDigest
| AcknowledgedSingle Integer
| Rejected RefDigest
| ProtocolVersion Text
| Initiation RefDigest
| CookieSet Cookie
| CookieEcho Cookie
| DataRequest RefDigest
| DataResponse RefDigest
| AnnounceSelf RefDigest
| AnnounceUpdate RefDigest
| TrChannelRequest RefDigest
| TrChannelAccept RefDigest
| ServiceType ServiceID
| ServiceRef RefDigest
deriving (TransportHeaderItem -> TransportHeaderItem -> Bool
(TransportHeaderItem -> TransportHeaderItem -> Bool)
-> (TransportHeaderItem -> TransportHeaderItem -> Bool)
-> Eq TransportHeaderItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportHeaderItem -> TransportHeaderItem -> Bool
== :: TransportHeaderItem -> TransportHeaderItem -> Bool
$c/= :: TransportHeaderItem -> TransportHeaderItem -> Bool
/= :: TransportHeaderItem -> TransportHeaderItem -> Bool
Eq, Int -> TransportHeaderItem -> ShowS
[TransportHeaderItem] -> ShowS
TransportHeaderItem -> String
(Int -> TransportHeaderItem -> ShowS)
-> (TransportHeaderItem -> String)
-> ([TransportHeaderItem] -> ShowS)
-> Show TransportHeaderItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportHeaderItem -> ShowS
showsPrec :: Int -> TransportHeaderItem -> ShowS
$cshow :: TransportHeaderItem -> String
show :: TransportHeaderItem -> String
$cshowList :: [TransportHeaderItem] -> ShowS
showList :: [TransportHeaderItem] -> ShowS
Show)
newtype Cookie = Cookie ByteString
deriving (Cookie -> Cookie -> Bool
(Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool) -> Eq Cookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
/= :: Cookie -> Cookie -> Bool
Eq, Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
(Int -> Cookie -> ShowS)
-> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cookie -> ShowS
showsPrec :: Int -> Cookie -> ShowS
$cshow :: Cookie -> String
show :: Cookie -> String
$cshowList :: [Cookie] -> ShowS
showList :: [Cookie] -> ShowS
Show)
isHeaderItemAcknowledged :: TransportHeaderItem -> Bool
= \case
Acknowledged {} -> Bool
False
AcknowledgedSingle {} -> Bool
False
Rejected {} -> Bool
False
ProtocolVersion {} -> Bool
False
Initiation {} -> Bool
False
CookieSet {} -> Bool
False
CookieEcho {} -> Bool
False
TransportHeaderItem
_ -> Bool
True
transportToObject :: PartialStorage -> TransportHeader -> PartialObject
transportToObject :: PartialStorage -> TransportHeader -> PartialObject
transportToObject PartialStorage
st (TransportHeader [TransportHeaderItem]
items) = [(ByteString, RecItem' Partial)] -> PartialObject
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec ([(ByteString, RecItem' Partial)] -> PartialObject)
-> [(ByteString, RecItem' Partial)] -> PartialObject
forall a b. (a -> b) -> a -> b
$ (TransportHeaderItem -> (ByteString, RecItem' Partial))
-> [TransportHeaderItem] -> [(ByteString, RecItem' Partial)]
forall a b. (a -> b) -> [a] -> [b]
map TransportHeaderItem -> (ByteString, RecItem' Partial)
single [TransportHeaderItem]
items
where single :: TransportHeaderItem -> (ByteString, RecItem' Partial)
single = \case
Acknowledged RefDigest
dgst -> (String -> ByteString
BC.pack String
"ACK", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
AcknowledgedSingle Integer
num -> (String -> ByteString
BC.pack String
"ACK", Integer -> RecItem' Partial
forall (c :: * -> *). Integer -> RecItem' c
RecInt Integer
num)
Rejected RefDigest
dgst -> (String -> ByteString
BC.pack String
"REJ", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
ProtocolVersion Text
ver -> (String -> ByteString
BC.pack String
"VER", Text -> RecItem' Partial
forall (c :: * -> *). Text -> RecItem' c
RecText Text
ver)
Initiation RefDigest
dgst -> (String -> ByteString
BC.pack String
"INI", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
CookieSet (Cookie ByteString
bytes) -> (String -> ByteString
BC.pack String
"CKS", ByteString -> RecItem' Partial
forall (c :: * -> *). ByteString -> RecItem' c
RecBinary ByteString
bytes)
CookieEcho (Cookie ByteString
bytes) -> (String -> ByteString
BC.pack String
"CKE", ByteString -> RecItem' Partial
forall (c :: * -> *). ByteString -> RecItem' c
RecBinary ByteString
bytes)
DataRequest RefDigest
dgst -> (String -> ByteString
BC.pack String
"REQ", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
DataResponse RefDigest
dgst -> (String -> ByteString
BC.pack String
"RSP", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
AnnounceSelf RefDigest
dgst -> (String -> ByteString
BC.pack String
"ANN", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
AnnounceUpdate RefDigest
dgst -> (String -> ByteString
BC.pack String
"ANU", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
TrChannelRequest RefDigest
dgst -> (String -> ByteString
BC.pack String
"CRQ", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
TrChannelAccept RefDigest
dgst -> (String -> ByteString
BC.pack String
"CAC", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
ServiceType ServiceID
stype -> (String -> ByteString
BC.pack String
"SVT", UUID -> RecItem' Partial
forall (c :: * -> *). UUID -> RecItem' c
RecUUID (UUID -> RecItem' Partial) -> UUID -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ ServiceID -> UUID
forall a. StorableUUID a => a -> UUID
toUUID ServiceID
stype)
ServiceRef RefDigest
dgst -> (String -> ByteString
BC.pack String
"SVR", Ref' Partial -> RecItem' Partial
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' Partial -> RecItem' Partial)
-> Ref' Partial -> RecItem' Partial
forall a b. (a -> b) -> a -> b
$ PartialStorage -> RefDigest -> Ref' Partial
partialRefFromDigest PartialStorage
st RefDigest
dgst)
transportFromObject :: PartialObject -> Maybe TransportHeader
transportFromObject :: PartialObject -> Maybe TransportHeader
transportFromObject (Rec [(ByteString, RecItem' Partial)]
items) = case [Maybe TransportHeaderItem] -> [TransportHeaderItem]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TransportHeaderItem] -> [TransportHeaderItem])
-> [Maybe TransportHeaderItem] -> [TransportHeaderItem]
forall a b. (a -> b) -> a -> b
$ ((ByteString, RecItem' Partial) -> Maybe TransportHeaderItem)
-> [(ByteString, RecItem' Partial)] -> [Maybe TransportHeaderItem]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem' Partial) -> Maybe TransportHeaderItem
forall {c :: * -> *}.
(ByteString, RecItem' c) -> Maybe TransportHeaderItem
single [(ByteString, RecItem' Partial)]
items of
[] -> Maybe TransportHeader
forall a. Maybe a
Nothing
[TransportHeaderItem]
titems -> TransportHeader -> Maybe TransportHeader
forall a. a -> Maybe a
Just (TransportHeader -> Maybe TransportHeader)
-> TransportHeader -> Maybe TransportHeader
forall a b. (a -> b) -> a -> b
$ [TransportHeaderItem] -> TransportHeader
TransportHeader [TransportHeaderItem]
titems
where single :: (ByteString, RecItem' c) -> Maybe TransportHeaderItem
single (ByteString
name, RecItem' c
content) = if
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"ACK", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
Acknowledged (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"ACK", RecInt Integer
num <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Integer -> TransportHeaderItem
AcknowledgedSingle Integer
num
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"REJ", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
Rejected (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"VER", RecText Text
ver <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Text -> TransportHeaderItem
ProtocolVersion Text
ver
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"INI", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
Initiation (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"CKS", RecBinary ByteString
bytes <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Cookie -> TransportHeaderItem
CookieSet (ByteString -> Cookie
Cookie ByteString
bytes)
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"CKE", RecBinary ByteString
bytes <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Cookie -> TransportHeaderItem
CookieEcho (ByteString -> Cookie
Cookie ByteString
bytes)
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"REQ", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
DataRequest (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"RSP", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
DataResponse (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"ANN", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
AnnounceSelf (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"ANU", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
AnnounceUpdate (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"CRQ", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
TrChannelRequest (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"CAC", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
TrChannelAccept (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"SVT", RecUUID UUID
uuid <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ ServiceID -> TransportHeaderItem
ServiceType (ServiceID -> TransportHeaderItem)
-> ServiceID -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ UUID -> ServiceID
forall a. StorableUUID a => UUID -> a
fromUUID UUID
uuid
| ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"SVR", RecRef Ref' c
ref <- RecItem' c
content -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> TransportHeaderItem -> Maybe TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ RefDigest -> TransportHeaderItem
ServiceRef (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref' c -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref' c
ref
| Bool
otherwise -> Maybe TransportHeaderItem
forall a. Maybe a
Nothing
transportFromObject PartialObject
_ = Maybe TransportHeader
forall a. Maybe a
Nothing
data GlobalState addr = (Eq addr, Show addr) => GlobalState
{ forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
, forall addr. GlobalState addr -> TVar [Connection addr]
gConnections :: TVar [Connection addr]
, forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gDataFlow :: SymFlow (addr, ByteString)
, forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
, forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
, forall addr. GlobalState addr -> String -> STM ()
gLog :: String -> STM ()
, forall addr. GlobalState addr -> PartialStorage
gStorage :: PartialStorage
, forall addr. GlobalState addr -> TVar TimeSpec
gNowVar :: TVar TimeSpec
, forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: TVar TimeSpec
, forall addr. GlobalState addr -> Ref
gInitConfig :: Ref
}
data Connection addr = Connection
{ forall addr. Connection addr -> addr
cAddress :: addr
, forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataUp :: Flow (Bool, TransportPacket PartialObject) (Bool, TransportPacket Ref, [TransportHeaderItem])
, forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cDataInternal :: Flow (Bool, TransportPacket Ref, [TransportHeaderItem]) (Bool, TransportPacket PartialObject)
, forall addr. Connection addr -> TVar ChannelState
cChannel :: TVar ChannelState
, forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
, forall addr. Connection addr -> TVar [SentPacket]
cSentPackets :: TVar [SentPacket]
, forall addr. Connection addr -> TVar [Integer]
cToAcknowledge :: TVar [Integer]
}
connAddress :: Connection addr -> addr
connAddress :: forall addr. Connection addr -> addr
connAddress = Connection addr -> addr
forall addr. Connection addr -> addr
cAddress
connData :: Connection addr -> Flow (Bool, TransportPacket PartialObject) (Bool, TransportPacket Ref, [TransportHeaderItem])
connData :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
connData = Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataUp
connGetChannel :: Connection addr -> STM ChannelState
connGetChannel :: forall addr. Connection addr -> STM ChannelState
connGetChannel Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} = TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel
connSetChannel :: Connection addr -> ChannelState -> STM ()
connSetChannel :: forall addr. Connection addr -> ChannelState -> STM ()
connSetChannel Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} ChannelState
ch = do
TVar ChannelState -> ChannelState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChannelState
cChannel ChannelState
ch
data WaitingRef = WaitingRef
{ WaitingRef -> Storage
wrefStorage :: Storage
, WaitingRef -> Ref' Partial
wrefPartial :: PartialRef
, WaitingRef -> Ref -> WaitingRefCallback
wrefAction :: Ref -> WaitingRefCallback
, WaitingRef -> TVar (Either [RefDigest] Ref)
wrefStatus :: TVar (Either [RefDigest] Ref)
}
type WaitingRefCallback = ExceptT String IO ()
wrDigest :: WaitingRef -> RefDigest
wrDigest :: WaitingRef -> RefDigest
wrDigest = Ref' Partial -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Partial -> RefDigest)
-> (WaitingRef -> Ref' Partial) -> WaitingRef -> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaitingRef -> Ref' Partial
wrefPartial
data ChannelState = ChannelNone
| ChannelCookieWait
| ChannelCookieReceived Cookie
| ChannelCookieConfirmed Cookie
| ChannelOurRequest (Maybe Cookie) (Stored ChannelRequest)
| ChannelPeerRequest (Maybe Cookie) WaitingRef
| ChannelOurAccept (Maybe Cookie) (Stored ChannelAccept) Channel
| ChannelEstablished Channel
data SentPacket = SentPacket
{ SentPacket -> TimeSpec
spTime :: TimeSpec
, SentPacket -> Int
spRetryCount :: Int
, SentPacket -> Maybe (TransportHeaderItem -> Bool)
spAckedBy :: Maybe (TransportHeaderItem -> Bool)
, SentPacket -> ByteString
spData :: BC.ByteString
}
data ControlRequest addr = RequestConnection addr
| SendAnnounce addr
| UpdateSelfIdentity UnifiedIdentity
data ControlMessage addr = NewConnection (Connection addr) (Maybe RefDigest)
| ReceivedAnnounce addr RefDigest
erebosNetworkProtocol :: (Eq addr, Ord addr, Show addr)
=> UnifiedIdentity
-> (String -> STM ())
-> SymFlow (addr, ByteString)
-> Flow (ControlRequest addr) (ControlMessage addr)
-> IO ()
erebosNetworkProtocol :: forall addr.
(Eq addr, Ord addr, Show addr) =>
UnifiedIdentity
-> (String -> STM ())
-> SymFlow (addr, ByteString)
-> Flow (ControlRequest addr) (ControlMessage addr)
-> IO ()
erebosNetworkProtocol UnifiedIdentity
initialIdentity String -> STM ()
gLog SymFlow (addr, ByteString)
gDataFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow = do
TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity <- (UnifiedIdentity, [UnifiedIdentity])
-> IO (TVar (UnifiedIdentity, [UnifiedIdentity]))
forall a. a -> IO (TVar a)
newTVarIO (UnifiedIdentity
initialIdentity, [])
TVar [Connection addr]
gConnections <- [Connection addr] -> IO (TVar [Connection addr])
forall a. a -> IO (TVar a)
newTVarIO []
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gNextUp <- IO (TMVar (Connection addr, (Bool, TransportPacket PartialObject)))
forall a. IO (TMVar a)
newEmptyTMVarIO
Storage
mStorage <- IO Storage
memoryStorage
PartialStorage
gStorage <- Storage -> IO PartialStorage
derivePartialStorage Storage
mStorage
TimeSpec
startTime <- Clock -> IO TimeSpec
getTime Clock
MonotonicRaw
TVar TimeSpec
gNowVar <- TimeSpec -> IO (TVar TimeSpec)
forall a. a -> IO (TVar a)
newTVarIO TimeSpec
startTime
TVar TimeSpec
gNextTimeout <- TimeSpec -> IO (TVar TimeSpec)
forall a. a -> IO (TVar a)
newTVarIO TimeSpec
startTime
Ref
gInitConfig <- Storage -> Object -> IO Ref
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
Storage' c -> a -> IO (Ref' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Object -> IO (Ref' c)
store Storage
mStorage (Object -> IO Ref) -> Object -> IO Ref
forall a b. (a -> b) -> a -> b
$ ([(ByteString, RecItem' Complete)] -> Object
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec [] :: Object)
let gs :: GlobalState addr
gs = GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
gLog :: String -> STM ()
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..}
let signalTimeouts :: IO Any
signalTimeouts = IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
TimeSpec
now <- Clock -> IO TimeSpec
getTime Clock
MonotonicRaw
TimeSpec
next <- STM TimeSpec -> IO TimeSpec
forall a. STM a -> IO a
atomically (STM TimeSpec -> IO TimeSpec) -> STM TimeSpec -> IO TimeSpec
forall a b. (a -> b) -> a -> b
$ do
TVar TimeSpec -> TimeSpec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar TimeSpec
gNowVar TimeSpec
now
TVar TimeSpec -> STM TimeSpec
forall a. TVar a -> STM a
readTVar TVar TimeSpec
gNextTimeout
let waitTill :: TimeSpec -> IO ()
waitTill TimeSpec
time
| TimeSpec
time TimeSpec -> TimeSpec -> Bool
forall a. Ord a => a -> a -> Bool
> TimeSpec
now = Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (TimeSpec -> Integer
toNanoSecs (TimeSpec
time TimeSpec -> TimeSpec -> TimeSpec
forall a. Num a => a -> a -> a
- TimeSpec
now)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000
| Bool
otherwise = Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
waitForUpdate :: IO ()
waitForUpdate = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TimeSpec
next' <- TVar TimeSpec -> STM TimeSpec
forall a. TVar a -> STM a
readTVar TVar TimeSpec
gNextTimeout
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeSpec
next' TimeSpec -> TimeSpec -> Bool
forall a. Eq a => a -> a -> Bool
== TimeSpec
next) STM ()
forall a. STM a
retry
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ (TimeSpec -> IO ()
waitTill TimeSpec
next) IO ()
waitForUpdate
IO Any -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ IO Any
signalTimeouts (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
GlobalState addr -> STM (IO ())
forall addr. GlobalState addr -> STM (IO ())
passUpIncoming GlobalState addr
gs STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GlobalState addr -> STM (IO ())
forall addr. GlobalState addr -> STM (IO ())
processIncoming GlobalState addr
gs STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GlobalState addr -> STM (IO ())
forall addr. GlobalState addr -> STM (IO ())
processOutgoing GlobalState addr
gs
getConnection :: GlobalState addr -> addr -> STM (Connection addr)
getConnection :: forall addr. GlobalState addr -> addr -> STM (Connection addr)
getConnection GlobalState addr
gs addr
addr = do
STM (Connection addr)
-> (Connection addr -> STM (Connection addr))
-> Maybe (Connection addr)
-> STM (Connection addr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GlobalState addr -> addr -> STM (Connection addr)
forall addr. GlobalState addr -> addr -> STM (Connection addr)
newConnection GlobalState addr
gs addr
addr) Connection addr -> STM (Connection addr)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Connection addr) -> STM (Connection addr))
-> STM (Maybe (Connection addr)) -> STM (Connection addr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GlobalState addr -> addr -> STM (Maybe (Connection addr))
forall addr.
GlobalState addr -> addr -> STM (Maybe (Connection addr))
findConnection GlobalState addr
gs addr
addr
findConnection :: GlobalState addr -> addr -> STM (Maybe (Connection addr))
findConnection :: forall addr.
GlobalState addr -> addr -> STM (Maybe (Connection addr))
findConnection GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} addr
addr = do
(Connection addr -> Bool)
-> [Connection addr] -> Maybe (Connection addr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((addr
addraddr -> addr -> Bool
forall a. Eq a => a -> a -> Bool
==) (addr -> Bool)
-> (Connection addr -> addr) -> Connection addr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection addr -> addr
forall addr. Connection addr -> addr
cAddress) ([Connection addr] -> Maybe (Connection addr))
-> STM [Connection addr] -> STM (Maybe (Connection addr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [Connection addr] -> STM [Connection addr]
forall a. TVar a -> STM a
readTVar TVar [Connection addr]
gConnections
newConnection :: GlobalState addr -> addr -> STM (Connection addr)
newConnection :: forall addr. GlobalState addr -> addr -> STM (Connection addr)
newConnection GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} addr
addr = do
[Connection addr]
conns <- TVar [Connection addr] -> STM [Connection addr]
forall a. TVar a -> STM a
readTVar TVar [Connection addr]
gConnections
let cAddress :: addr
cAddress = addr
addr
(Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataUp, Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cDataInternal) <- STM
(Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem]),
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject))
forall a b. STM (Flow a b, Flow b a)
newFlow
TVar ChannelState
cChannel <- ChannelState -> STM (TVar ChannelState)
forall a. a -> STM (TVar a)
newTVar ChannelState
ChannelNone
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSecureOutQueue <- STM (TQueue (Bool, TransportPacket Ref, [TransportHeaderItem]))
forall a. STM (TQueue a)
newTQueue
TVar [SentPacket]
cSentPackets <- [SentPacket] -> STM (TVar [SentPacket])
forall a. a -> STM (TVar a)
newTVar []
TVar [Integer]
cToAcknowledge <- [Integer] -> STM (TVar [Integer])
forall a. a -> STM (TVar a)
newTVar []
let conn :: Connection addr
conn = Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..}
TVar [Connection addr] -> [Connection addr] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Connection addr]
gConnections (Connection addr
conn Connection addr -> [Connection addr] -> [Connection addr]
forall a. a -> [a] -> [a]
: [Connection addr]
conns)
Connection addr -> STM (Connection addr)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Connection addr
conn
passUpIncoming :: GlobalState addr -> STM (IO ())
passUpIncoming :: forall addr. GlobalState addr -> STM (IO ())
passUpIncoming GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} = do
(Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..}, (Bool, TransportPacket PartialObject)
up) <- TMVar (Connection addr, (Bool, TransportPacket PartialObject))
-> STM (Connection addr, (Bool, TransportPacket PartialObject))
forall a. TMVar a -> STM a
takeTMVar TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gNextUp
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
-> (Bool, TransportPacket PartialObject) -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cDataInternal (Bool, TransportPacket PartialObject)
up
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
processIncoming :: GlobalState addr -> STM (IO ())
processIncoming :: forall addr. GlobalState addr -> STM (IO ())
processIncoming gs :: GlobalState addr
gs@GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} = do
Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> STM ()) -> STM Bool -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMVar (Connection addr, (Bool, TransportPacket PartialObject))
-> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gNextUp
Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> STM ()) -> STM Bool -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Flow (ControlRequest addr) (ControlMessage addr) -> STM Bool
forall r w. Flow r w -> STM Bool
canWriteFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow
(addr
addr, ByteString
msg) <- SymFlow (addr, ByteString) -> STM (addr, ByteString)
forall r w. Flow r w -> STM r
readFlow SymFlow (addr, ByteString)
gDataFlow
Maybe (Connection addr)
mbconn <- GlobalState addr -> addr -> STM (Maybe (Connection addr))
forall addr.
GlobalState addr -> addr -> STM (Maybe (Connection addr))
findConnection GlobalState addr
gs addr
addr
Maybe Channel
mbch <- case Maybe (Connection addr)
mbconn of
Maybe (Connection addr)
Nothing -> Maybe Channel -> STM (Maybe Channel)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Channel
forall a. Maybe a
Nothing
Just Connection addr
conn -> TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar (Connection addr -> TVar ChannelState
forall addr. Connection addr -> TVar ChannelState
cChannel Connection addr
conn) STM ChannelState
-> (ChannelState -> STM (Maybe Channel)) -> STM (Maybe Channel)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Channel -> STM (Maybe Channel)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Channel -> STM (Maybe Channel))
-> (ChannelState -> Maybe Channel)
-> ChannelState
-> STM (Maybe Channel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
ChannelEstablished Channel
ch -> Channel -> Maybe Channel
forall a. a -> Maybe a
Just Channel
ch
ChannelOurAccept Maybe Cookie
_ Stored ChannelAccept
_ Channel
ch -> Channel -> Maybe Channel
forall a. a -> Maybe a
Just Channel
ch
ChannelState
_ -> Maybe Channel
forall a. Maybe a
Nothing
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
let deserialize :: ByteString -> ExceptT String IO [PartialObject]
deserialize = Either String [PartialObject] -> ExceptT String IO [PartialObject]
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String [PartialObject]
-> ExceptT String IO [PartialObject])
-> (ByteString -> Either String [PartialObject])
-> ByteString
-> ExceptT String IO [PartialObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except String [PartialObject] -> Either String [PartialObject]
forall e a. Except e a -> Either e a
runExcept (Except String [PartialObject] -> Either String [PartialObject])
-> (ByteString -> Except String [PartialObject])
-> ByteString
-> Either String [PartialObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartialStorage -> ByteString -> Except String [PartialObject]
deserializeObjects PartialStorage
gStorage (ByteString -> Except String [PartialObject])
-> (ByteString -> ByteString)
-> ByteString
-> Except String [PartialObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict
let parse :: ExceptT String IO (Bool, [PartialObject], Maybe Word64)
parse = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
msg of
Just (Word8
b, ByteString
enc)
| Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xE0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 -> do
Channel
ch <- ExceptT String IO Channel
-> (Channel -> ExceptT String IO Channel)
-> Maybe Channel
-> ExceptT String IO Channel
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ExceptT String IO Channel
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"unexpected encrypted packet") Channel -> ExceptT String IO Channel
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Channel
mbch
(ByteString
dec, Word64
counter) <- Channel -> ByteString -> ExceptT String IO (ByteString, Word64)
forall ba (m :: * -> *).
(ByteArray ba, MonadIO m, MonadError String m) =>
Channel -> ba -> m (ba, Word64)
channelDecrypt Channel
ch ByteString
enc
case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
dec of
Just (Word8
0x00, ByteString
content) -> do
[PartialObject]
objs <- ByteString -> ExceptT String IO [PartialObject]
deserialize ByteString
content
(Bool, [PartialObject], Maybe Word64)
-> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [PartialObject]
objs, Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
counter)
Just (Word8
_, ByteString
_) -> do
String -> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"streams not implemented"
Maybe (Word8, ByteString)
Nothing -> do
String -> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"empty decrypted content"
| Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xE0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x60 -> do
[PartialObject]
objs <- ByteString -> ExceptT String IO [PartialObject]
deserialize ByteString
msg
(Bool, [PartialObject], Maybe Word64)
-> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [PartialObject]
objs, Maybe Word64
forall a. Maybe a
Nothing)
| Bool
otherwise -> String -> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"invalid packet"
Maybe (Word8, ByteString)
Nothing -> String -> ExceptT String IO (Bool, [PartialObject], Maybe Word64)
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"empty packet"
ExceptT String IO (Bool, [PartialObject], Maybe Word64)
-> IO (Either String (Bool, [PartialObject], Maybe Word64))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String IO (Bool, [PartialObject], Maybe Word64)
parse IO (Either String (Bool, [PartialObject], Maybe Word64))
-> (Either String (Bool, [PartialObject], Maybe Word64) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right (Bool
secure, [PartialObject]
objs, Maybe Word64
mbcounter)
| PartialObject
hobj:[PartialObject]
content <- [PartialObject]
objs
, Just header :: TransportHeader
header@(TransportHeader [TransportHeaderItem]
items) <- PartialObject -> Maybe TransportHeader
transportFromObject PartialObject
hobj
-> GlobalState addr
-> Either addr (Connection addr)
-> Bool
-> TransportPacket PartialObject
-> IO
(Maybe (Connection addr, Maybe (TransportPacket PartialObject)))
forall addr a.
GlobalState addr
-> Either addr (Connection addr)
-> Bool
-> TransportPacket a
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
processPacket GlobalState addr
gs (Either addr (Connection addr)
-> (Connection addr -> Either addr (Connection addr))
-> Maybe (Connection addr)
-> Either addr (Connection addr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (addr -> Either addr (Connection addr)
forall a b. a -> Either a b
Left addr
addr) Connection addr -> Either addr (Connection addr)
forall a b. b -> Either a b
Right Maybe (Connection addr)
mbconn) Bool
secure (TransportHeader -> [PartialObject] -> TransportPacket PartialObject
forall a. TransportHeader -> [a] -> TransportPacket a
TransportPacket TransportHeader
header [PartialObject]
content) IO (Maybe (Connection addr, Maybe (TransportPacket PartialObject)))
-> (Maybe (Connection addr, Maybe (TransportPacket PartialObject))
-> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..}, Maybe (TransportPacket PartialObject)
mbup) -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case Maybe Word64
mbcounter of
Just Word64
counter | (TransportHeaderItem -> Bool) -> [TransportHeaderItem] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TransportHeaderItem -> Bool
isHeaderItemAcknowledged [TransportHeaderItem]
items ->
TVar [Integer] -> ([Integer] -> [Integer]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Integer]
cToAcknowledge (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
counter Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
:)
Maybe Word64
_ -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
GlobalState addr
-> Connection addr -> [TransportHeaderItem] -> STM ()
forall addr.
GlobalState addr
-> Connection addr -> [TransportHeaderItem] -> STM ()
processAcknowledgements GlobalState addr
gs Connection addr
conn [TransportHeaderItem]
items
case Maybe (TransportPacket PartialObject)
mbup of
Just TransportPacket PartialObject
up -> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
-> (Connection addr, (Bool, TransportPacket PartialObject))
-> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gNextUp (Connection addr
conn, (Bool
secure, TransportPacket PartialObject
up))
Maybe (TransportPacket PartialObject)
Nothing -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (Connection addr, Maybe (TransportPacket PartialObject))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": invalid objects"
String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ [PartialObject] -> String
forall a. Show a => a -> String
show [PartialObject]
objs
Left String
err -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": failed to parse packet: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
processPacket :: forall addr a.
GlobalState addr
-> Either addr (Connection addr)
-> Bool
-> TransportPacket a
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
processPacket gs :: GlobalState addr
gs@GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} Either addr (Connection addr)
econn Bool
secure packet :: TransportPacket a
packet@(TransportPacket (TransportHeader [TransportHeaderItem]
header) [a]
_) = if
| Right Connection addr
conn <- Either addr (Connection addr)
econn, Bool
secure
-> Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a))))
-> Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ (Connection addr, Maybe (TransportPacket a))
-> Maybe (Connection addr, Maybe (TransportPacket a))
forall a. a -> Maybe a
Just (Connection addr
conn, TransportPacket a -> Maybe (TransportPacket a)
forall a. a -> Maybe a
Just TransportPacket a
packet)
| Cookie
cookie:[Cookie]
_ <- (TransportHeaderItem -> Maybe Cookie)
-> [TransportHeaderItem] -> [Cookie]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case CookieEcho Cookie
x -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
x; TransportHeaderItem
_ -> Maybe Cookie
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
-> GlobalState addr -> addr -> Cookie -> IO Bool
forall addr. GlobalState addr -> addr -> Cookie -> IO Bool
verifyCookie GlobalState addr
gs addr
addr Cookie
cookie IO Bool
-> (Bool
-> IO (Maybe (Connection addr, Maybe (TransportPacket a))))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. STM a -> IO a
atomically (STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a))))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ do
conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} <- GlobalState addr -> addr -> STM (Connection addr)
forall addr. GlobalState addr -> addr -> STM (Connection addr)
getConnection GlobalState addr
gs addr
addr
ChannelState
channel <- TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel
let received :: Maybe Cookie
received = [Cookie] -> Maybe Cookie
forall a. [a] -> Maybe a
listToMaybe ([Cookie] -> Maybe Cookie) -> [Cookie] -> Maybe Cookie
forall a b. (a -> b) -> a -> b
$ (TransportHeaderItem -> Maybe Cookie)
-> [TransportHeaderItem] -> [Cookie]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case CookieSet Cookie
x -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
x; TransportHeaderItem
_ -> Maybe Cookie
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
case Maybe Cookie
received Maybe Cookie -> Maybe Cookie -> Maybe Cookie
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ChannelState -> Maybe Cookie
channelCurrentCookie ChannelState
channel of
Just Cookie
current -> do
GlobalState addr
-> Connection addr -> Maybe RefDigest -> Cookie -> STM ()
forall addr.
GlobalState addr
-> Connection addr -> Maybe RefDigest -> Cookie -> STM ()
cookieEchoReceived GlobalState addr
gs Connection addr
conn Maybe RefDigest
mbpid Cookie
current
Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a))))
-> Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ (Connection addr, Maybe (TransportPacket a))
-> Maybe (Connection addr, Maybe (TransportPacket a))
forall a. a -> Maybe a
Just (Connection addr
conn, TransportPacket a -> Maybe (TransportPacket a)
forall a. a -> Maybe a
Just TransportPacket a
packet)
Maybe Cookie
Nothing -> do
String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": missing cookie set, dropping " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TransportHeaderItem] -> String
forall a. Show a => a -> String
show [TransportHeaderItem]
header
Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a))))
-> Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
Bool
False -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": cookie verification failed, dropping " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TransportHeaderItem] -> String
forall a. Show a => a -> String
show [TransportHeaderItem]
header
Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
| Cookie
cookie:[Cookie]
_ <- (TransportHeaderItem -> Maybe Cookie)
-> [TransportHeaderItem] -> [Cookie]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case CookieSet Cookie
x -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
x; TransportHeaderItem
_ -> Maybe Cookie
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
, Just Text
_ <- Maybe Text
version
, Right conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} <- Either addr (Connection addr)
econn
-> do
STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. STM a -> IO a
atomically (STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a))))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel STM ChannelState
-> (ChannelState
-> STM (Maybe (Connection addr, Maybe (TransportPacket a))))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ChannelState
ChannelCookieWait -> do
TVar ChannelState -> ChannelState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChannelState
cChannel (ChannelState -> STM ()) -> ChannelState -> STM ()
forall a b. (a -> b) -> a -> b
$ Cookie -> ChannelState
ChannelCookieReceived Cookie
cookie
Flow (ControlRequest addr) (ControlMessage addr)
-> ControlMessage addr -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow (Connection addr -> Maybe RefDigest -> ControlMessage addr
forall addr.
Connection addr -> Maybe RefDigest -> ControlMessage addr
NewConnection Connection addr
conn Maybe RefDigest
mbpid)
Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a))))
-> Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a b. (a -> b) -> a -> b
$ (Connection addr, Maybe (TransportPacket a))
-> Maybe (Connection addr, Maybe (TransportPacket a))
forall a. a -> Maybe a
Just (Connection addr
conn, Maybe (TransportPacket a)
forall a. Maybe a
Nothing)
ChannelState
_ -> Maybe (Connection addr, Maybe (TransportPacket a))
-> STM (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
| RefDigest
_:[RefDigest]
_ <- (TransportHeaderItem -> Maybe RefDigest)
-> [TransportHeaderItem] -> [RefDigest]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case Initiation RefDigest
x -> RefDigest -> Maybe RefDigest
forall a. a -> Maybe a
Just RefDigest
x; TransportHeaderItem
_ -> Maybe RefDigest
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
, Just Text
ver <- Maybe Text
version
-> do
Cookie
cookie <- GlobalState addr -> addr -> IO Cookie
forall addr. GlobalState addr -> addr -> IO Cookie
createCookie GlobalState addr
gs addr
addr
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UnifiedIdentity
identity <- (UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity
forall a b. (a, b) -> a
fst ((UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity)
-> STM (UnifiedIdentity, [UnifiedIdentity]) -> STM UnifiedIdentity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UnifiedIdentity, [UnifiedIdentity])
-> STM (UnifiedIdentity, [UnifiedIdentity])
forall a. TVar a -> STM a
readTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity
let reply :: ByteString
reply = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialObject -> ByteString
forall (c :: * -> *). Object' c -> ByteString
serializeObject (PartialObject -> ByteString) -> PartialObject -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialStorage -> TransportHeader -> PartialObject
transportToObject PartialStorage
gStorage (TransportHeader -> PartialObject)
-> TransportHeader -> PartialObject
forall a b. (a -> b) -> a -> b
$ [TransportHeaderItem] -> TransportHeader
TransportHeader
[ Cookie -> TransportHeaderItem
CookieSet Cookie
cookie
, RefDigest -> TransportHeaderItem
AnnounceSelf (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Signed IdentityData) -> Ref)
-> Stored (Signed IdentityData) -> Ref
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Stored (Signed IdentityData)
idData UnifiedIdentity
identity
, Text -> TransportHeaderItem
ProtocolVersion Text
ver
]
SymFlow (addr, ByteString) -> (addr, ByteString) -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow SymFlow (addr, ByteString)
gDataFlow (addr
addr, ByteString
reply)
Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
| RefDigest
dgst:[RefDigest]
_ <- (TransportHeaderItem -> Maybe RefDigest)
-> [TransportHeaderItem] -> [RefDigest]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case AnnounceSelf RefDigest
x -> RefDigest -> Maybe RefDigest
forall a. a -> Maybe a
Just RefDigest
x; TransportHeaderItem
_ -> Maybe RefDigest
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
, Just Text
_ <- Maybe Text
version
-> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(UnifiedIdentity
cur, [UnifiedIdentity]
past) <- TVar (UnifiedIdentity, [UnifiedIdentity])
-> STM (UnifiedIdentity, [UnifiedIdentity])
forall a. TVar a -> STM a
readTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RefDigest
dgst RefDigest -> [RefDigest] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (UnifiedIdentity -> RefDigest) -> [UnifiedIdentity] -> [RefDigest]
forall a b. (a -> b) -> [a] -> [b]
map (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest)
-> (UnifiedIdentity -> Ref) -> UnifiedIdentity -> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Signed IdentityData) -> Ref)
-> (UnifiedIdentity -> Stored (Signed IdentityData))
-> UnifiedIdentity
-> Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnifiedIdentity -> Stored (Signed IdentityData)
idData) (UnifiedIdentity
cur UnifiedIdentity -> [UnifiedIdentity] -> [UnifiedIdentity]
forall a. a -> [a] -> [a]
: [UnifiedIdentity]
past)) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
Flow (ControlRequest addr) (ControlMessage addr)
-> ControlMessage addr -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow (ControlMessage addr -> STM ()) -> ControlMessage addr -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> RefDigest -> ControlMessage addr
forall addr. addr -> RefDigest -> ControlMessage addr
ReceivedAnnounce addr
addr RefDigest
dgst
Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
| Bool
otherwise -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": dropping packet " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TransportHeaderItem] -> String
forall a. Show a => a -> String
show [TransportHeaderItem]
header
Maybe (Connection addr, Maybe (TransportPacket a))
-> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Connection addr, Maybe (TransportPacket a))
forall a. Maybe a
Nothing
where
addr :: addr
addr = (addr -> addr)
-> (Connection addr -> addr)
-> Either addr (Connection addr)
-> addr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either addr -> addr
forall a. a -> a
id Connection addr -> addr
forall addr. Connection addr -> addr
cAddress Either addr (Connection addr)
econn
mbpid :: Maybe RefDigest
mbpid = [RefDigest] -> Maybe RefDigest
forall a. [a] -> Maybe a
listToMaybe ([RefDigest] -> Maybe RefDigest) -> [RefDigest] -> Maybe RefDigest
forall a b. (a -> b) -> a -> b
$ (TransportHeaderItem -> Maybe RefDigest)
-> [TransportHeaderItem] -> [RefDigest]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case AnnounceSelf RefDigest
dgst -> RefDigest -> Maybe RefDigest
forall a. a -> Maybe a
Just RefDigest
dgst; TransportHeaderItem
_ -> Maybe RefDigest
forall a. Maybe a
Nothing) [TransportHeaderItem]
header
version :: Maybe Text
version = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
v -> Text -> TransportHeaderItem
ProtocolVersion Text
v TransportHeaderItem -> [TransportHeaderItem] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TransportHeaderItem]
header) [Text]
protocolVersions
channelCurrentCookie :: ChannelState -> Maybe Cookie
channelCurrentCookie :: ChannelState -> Maybe Cookie
channelCurrentCookie = \case
ChannelCookieReceived Cookie
cookie -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
cookie
ChannelCookieConfirmed Cookie
cookie -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
cookie
ChannelOurRequest Maybe Cookie
mbcookie Stored ChannelRequest
_ -> Maybe Cookie
mbcookie
ChannelPeerRequest Maybe Cookie
mbcookie WaitingRef
_ -> Maybe Cookie
mbcookie
ChannelOurAccept Maybe Cookie
mbcookie Stored ChannelAccept
_ Channel
_ -> Maybe Cookie
mbcookie
ChannelState
_ -> Maybe Cookie
forall a. Maybe a
Nothing
cookieEchoReceived :: GlobalState addr -> Connection addr -> Maybe RefDigest -> Cookie -> STM ()
cookieEchoReceived :: forall addr.
GlobalState addr
-> Connection addr -> Maybe RefDigest -> Cookie -> STM ()
cookieEchoReceived GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} Maybe RefDigest
mbpid Cookie
cookieSet = do
TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel STM ChannelState -> (ChannelState -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ChannelState
ChannelNone -> STM ()
newConn
ChannelState
ChannelCookieWait -> STM ()
newConn
ChannelCookieReceived {} -> STM ()
update
ChannelState
_ -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
update :: STM ()
update = do
TVar ChannelState -> ChannelState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChannelState
cChannel (ChannelState -> STM ()) -> ChannelState -> STM ()
forall a b. (a -> b) -> a -> b
$ Cookie -> ChannelState
ChannelCookieConfirmed Cookie
cookieSet
newConn :: STM ()
newConn = do
STM ()
update
Flow (ControlRequest addr) (ControlMessage addr)
-> ControlMessage addr -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow (Connection addr -> Maybe RefDigest -> ControlMessage addr
forall addr.
Connection addr -> Maybe RefDigest -> ControlMessage addr
NewConnection Connection addr
conn Maybe RefDigest
mbpid)
generateCookieHeaders :: GlobalState addr -> addr -> ChannelState -> IO [TransportHeaderItem]
GlobalState addr
gs addr
addr ChannelState
ch = [Maybe TransportHeaderItem] -> [TransportHeaderItem]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TransportHeaderItem] -> [TransportHeaderItem])
-> IO [Maybe TransportHeaderItem] -> IO [TransportHeaderItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO (Maybe TransportHeaderItem)] -> IO [Maybe TransportHeaderItem]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ IO (Maybe TransportHeaderItem)
echoHeader, IO (Maybe TransportHeaderItem)
setHeader ]
where
echoHeader :: IO (Maybe TransportHeaderItem)
echoHeader = Maybe TransportHeaderItem -> IO (Maybe TransportHeaderItem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TransportHeaderItem -> IO (Maybe TransportHeaderItem))
-> Maybe TransportHeaderItem -> IO (Maybe TransportHeaderItem)
forall a b. (a -> b) -> a -> b
$ Cookie -> TransportHeaderItem
CookieEcho (Cookie -> TransportHeaderItem)
-> Maybe Cookie -> Maybe TransportHeaderItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChannelState -> Maybe Cookie
channelCurrentCookie ChannelState
ch
setHeader :: IO (Maybe TransportHeaderItem)
setHeader = case ChannelState
ch of
ChannelCookieWait {} -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> (Cookie -> TransportHeaderItem)
-> Cookie
-> Maybe TransportHeaderItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> TransportHeaderItem
CookieSet (Cookie -> Maybe TransportHeaderItem)
-> IO Cookie -> IO (Maybe TransportHeaderItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobalState addr -> addr -> IO Cookie
forall addr. GlobalState addr -> addr -> IO Cookie
createCookie GlobalState addr
gs addr
addr
ChannelCookieReceived {} -> TransportHeaderItem -> Maybe TransportHeaderItem
forall a. a -> Maybe a
Just (TransportHeaderItem -> Maybe TransportHeaderItem)
-> (Cookie -> TransportHeaderItem)
-> Cookie
-> Maybe TransportHeaderItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> TransportHeaderItem
CookieSet (Cookie -> Maybe TransportHeaderItem)
-> IO Cookie -> IO (Maybe TransportHeaderItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobalState addr -> addr -> IO Cookie
forall addr. GlobalState addr -> addr -> IO Cookie
createCookie GlobalState addr
gs addr
addr
ChannelState
_ -> Maybe TransportHeaderItem -> IO (Maybe TransportHeaderItem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TransportHeaderItem
forall a. Maybe a
Nothing
createCookie :: GlobalState addr -> addr -> IO Cookie
createCookie :: forall addr. GlobalState addr -> addr -> IO Cookie
createCookie GlobalState {} addr
addr = Cookie -> IO Cookie
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Cookie
Cookie (ByteString -> Cookie) -> ByteString -> Cookie
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr)
verifyCookie :: GlobalState addr -> addr -> Cookie -> IO Bool
verifyCookie :: forall addr. GlobalState addr -> addr -> Cookie -> IO Bool
verifyCookie GlobalState {} addr
addr (Cookie ByteString
cookie) = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ addr -> String
forall a. Show a => a -> String
show addr
addr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> String
BC.unpack ByteString
cookie
resendBytes :: GlobalState addr -> Connection addr -> SentPacket -> IO ()
resendBytes :: forall addr.
GlobalState addr -> Connection addr -> SentPacket -> IO ()
resendBytes GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} SentPacket
sp = do
TimeSpec
now <- Clock -> IO TimeSpec
getTime Clock
MonotonicRaw
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (TransportHeaderItem -> Bool) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TransportHeaderItem -> Bool) -> Bool)
-> Maybe (TransportHeaderItem -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ SentPacket -> Maybe (TransportHeaderItem -> Bool)
spAckedBy SentPacket
sp) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
TVar [SentPacket] -> ([SentPacket] -> [SentPacket]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [SentPacket]
cSentPackets (([SentPacket] -> [SentPacket]) -> STM ())
-> ([SentPacket] -> [SentPacket]) -> STM ()
forall a b. (a -> b) -> a -> b
$ (:) SentPacket
sp
{ spTime = now
, spRetryCount = spRetryCount sp + 1
}
SymFlow (addr, ByteString) -> (addr, ByteString) -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow SymFlow (addr, ByteString)
gDataFlow (addr
cAddress, SentPacket -> ByteString
spData SentPacket
sp)
sendBytes :: GlobalState addr -> Connection addr -> ByteString -> Maybe (TransportHeaderItem -> Bool) -> IO ()
sendBytes :: forall addr.
GlobalState addr
-> Connection addr
-> ByteString
-> Maybe (TransportHeaderItem -> Bool)
-> IO ()
sendBytes GlobalState addr
gs Connection addr
conn ByteString
bs Maybe (TransportHeaderItem -> Bool)
ackedBy = GlobalState addr -> Connection addr -> SentPacket -> IO ()
forall addr.
GlobalState addr -> Connection addr -> SentPacket -> IO ()
resendBytes GlobalState addr
gs Connection addr
conn
SentPacket
{ spTime :: TimeSpec
spTime = TimeSpec
forall a. HasCallStack => a
undefined
, spRetryCount :: Int
spRetryCount = -Int
1
, spAckedBy :: Maybe (TransportHeaderItem -> Bool)
spAckedBy = Maybe (TransportHeaderItem -> Bool)
ackedBy
, spData :: ByteString
spData = ByteString
bs
}
processOutgoing :: forall addr. GlobalState addr -> STM (IO ())
processOutgoing :: forall addr. GlobalState addr -> STM (IO ())
processOutgoing gs :: GlobalState addr
gs@GlobalState {TVar [Connection addr]
TVar (UnifiedIdentity, [UnifiedIdentity])
TVar TimeSpec
TMVar (Connection addr, (Bool, TransportPacket PartialObject))
SymFlow (addr, ByteString)
Flow (ControlRequest addr) (ControlMessage addr)
Ref
PartialStorage
String -> STM ()
gIdentity :: forall addr.
GlobalState addr -> TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: forall addr. GlobalState addr -> TVar [Connection addr]
gDataFlow :: forall addr. GlobalState addr -> SymFlow (addr, ByteString)
gControlFlow :: forall addr.
GlobalState addr
-> Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: forall addr.
GlobalState addr
-> TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: forall addr. GlobalState addr -> String -> STM ()
gStorage :: forall addr. GlobalState addr -> PartialStorage
gNowVar :: forall addr. GlobalState addr -> TVar TimeSpec
gNextTimeout :: forall addr. GlobalState addr -> TVar TimeSpec
gInitConfig :: forall addr. GlobalState addr -> Ref
gIdentity :: TVar (UnifiedIdentity, [UnifiedIdentity])
gConnections :: TVar [Connection addr]
gDataFlow :: SymFlow (addr, ByteString)
gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
gLog :: String -> STM ()
gStorage :: PartialStorage
gNowVar :: TVar TimeSpec
gNextTimeout :: TVar TimeSpec
gInitConfig :: Ref
..} = do
let sendNextPacket :: Connection addr -> STM (IO ())
sendNextPacket :: Connection addr -> STM (IO ())
sendNextPacket conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} = do
ChannelState
channel <- TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel
let mbch :: Maybe Channel
mbch = case ChannelState
channel of
ChannelEstablished Channel
ch -> Channel -> Maybe Channel
forall a. a -> Maybe a
Just Channel
ch
ChannelState
_ -> Maybe Channel
forall a. Maybe a
Nothing
let checkOutstanding :: STM (Bool, TransportPacket Ref, [TransportHeaderItem])
checkOutstanding
| Maybe Channel -> Bool
forall a. Maybe a -> Bool
isJust Maybe Channel
mbch = TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. TQueue a -> STM a
readTQueue TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSecureOutQueue
| Bool
otherwise = STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. STM a
retry
checkAcknowledgements :: STM (Bool, TransportPacket Ref, [TransportHeaderItem])
checkAcknowledgements
| Maybe Channel -> Bool
forall a. Maybe a -> Bool
isJust Maybe Channel
mbch = do
[Integer]
acks <- TVar [Integer] -> STM [Integer]
forall a. TVar a -> STM a
readTVar TVar [Integer]
cToAcknowledge
if [Integer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integer]
acks then STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. STM a
retry
else (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, TransportHeader -> [Ref] -> TransportPacket Ref
forall a. TransportHeader -> [a] -> TransportPacket a
TransportPacket ([TransportHeaderItem] -> TransportHeader
TransportHeader []) [], [])
| Bool
otherwise = STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. STM a
retry
(Bool
secure, packet :: TransportPacket Ref
packet@(TransportPacket (TransportHeader [TransportHeaderItem]
hitems) [Ref]
content), [TransportHeaderItem]
plainAckedBy) <-
STM (Bool, TransportPacket Ref, [TransportHeaderItem])
checkOutstanding STM (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall r w. Flow r w -> STM r
readFlow Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cDataInternal STM (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
-> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> STM (Bool, TransportPacket Ref, [TransportHeaderItem])
checkAcknowledgements
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Channel -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Channel
mbch Bool -> Bool -> Bool
&& Bool
secure) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
-> (Bool, TransportPacket Ref, [TransportHeaderItem]) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSecureOutQueue (Bool
secure, TransportPacket Ref
packet, [TransportHeaderItem]
plainAckedBy)
[Integer]
acknowledge <- case Maybe Channel
mbch of
Maybe Channel
Nothing -> [Integer] -> STM [Integer]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Channel
_ -> TVar [Integer] -> [Integer] -> STM [Integer]
forall a. TVar a -> a -> STM a
swapTVar TVar [Integer]
cToAcknowledge []
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
[TransportHeaderItem]
cookieHeaders <- GlobalState addr
-> addr -> ChannelState -> IO [TransportHeaderItem]
forall addr.
GlobalState addr
-> addr -> ChannelState -> IO [TransportHeaderItem]
generateCookieHeaders GlobalState addr
gs addr
cAddress ChannelState
channel
let header :: TransportHeader
header = [TransportHeaderItem] -> TransportHeader
TransportHeader ([TransportHeaderItem] -> TransportHeader)
-> [TransportHeaderItem] -> TransportHeader
forall a b. (a -> b) -> a -> b
$ (Integer -> TransportHeaderItem)
-> [Integer] -> [TransportHeaderItem]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> TransportHeaderItem
AcknowledgedSingle [Integer]
acknowledge [TransportHeaderItem]
-> [TransportHeaderItem] -> [TransportHeaderItem]
forall a. [a] -> [a] -> [a]
++ [TransportHeaderItem]
cookieHeaders [TransportHeaderItem]
-> [TransportHeaderItem] -> [TransportHeaderItem]
forall a. [a] -> [a] -> [a]
++ [TransportHeaderItem]
hitems
let plain :: ByteString
plain = [ByteString] -> ByteString
BL.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
(PartialObject -> ByteString
forall (c :: * -> *). Object' c -> ByteString
serializeObject (PartialObject -> ByteString) -> PartialObject -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialStorage -> TransportHeader -> PartialObject
transportToObject PartialStorage
gStorage TransportHeader
header)
ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Ref -> ByteString) -> [Ref] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Ref -> ByteString
Ref -> LoadResult Complete ByteString
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c ByteString
lazyLoadBytes [Ref]
content
Maybe (ByteString, [TransportHeaderItem])
mbs <- case Maybe Channel
mbch of
Just Channel
ch -> do
ExceptT String IO (ByteString, Word64)
-> IO (Either String (ByteString, Word64))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Channel -> ByteString -> ExceptT String IO (ByteString, Word64)
forall ba (m :: * -> *).
(ByteArray ba, MonadIO m, MonadError String m) =>
Channel -> ba -> m (ba, Word64)
channelEncrypt Channel
ch (ByteString -> ExceptT String IO (ByteString, Word64))
-> ByteString -> ExceptT String IO (ByteString, Word64)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Word8
0x00 Word8 -> ByteString -> ByteString
`BL.cons` ByteString
plain) IO (Either String (ByteString, Word64))
-> (Either String (ByteString, Word64)
-> IO (Maybe (ByteString, [TransportHeaderItem])))
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right (ByteString
ctext, Word64
counter) -> do
let isAcked :: Bool
isAcked = (TransportHeaderItem -> Bool) -> [TransportHeaderItem] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TransportHeaderItem -> Bool
isHeaderItemAcknowledged [TransportHeaderItem]
hitems
Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem])))
-> Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a b. (a -> b) -> a -> b
$ (ByteString, [TransportHeaderItem])
-> Maybe (ByteString, [TransportHeaderItem])
forall a. a -> Maybe a
Just (Word8
0x80 Word8 -> ByteString -> ByteString
`B.cons` ByteString
ctext, if Bool
isAcked then [ Integer -> TransportHeaderItem
AcknowledgedSingle (Integer -> TransportHeaderItem) -> Integer -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
counter ] else [])
Left String
err -> do STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
gLog (String -> STM ()) -> String -> STM ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to encrypt data: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, [TransportHeaderItem])
forall a. Maybe a
Nothing
Maybe Channel
Nothing | Bool
secure -> Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, [TransportHeaderItem])
forall a. Maybe a
Nothing
| Bool
otherwise -> Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem])))
-> Maybe (ByteString, [TransportHeaderItem])
-> IO (Maybe (ByteString, [TransportHeaderItem]))
forall a b. (a -> b) -> a -> b
$ (ByteString, [TransportHeaderItem])
-> Maybe (ByteString, [TransportHeaderItem])
forall a. a -> Maybe a
Just (ByteString -> ByteString
BL.toStrict ByteString
plain, [TransportHeaderItem]
plainAckedBy)
case Maybe (ByteString, [TransportHeaderItem])
mbs of
Just (ByteString
bs, [TransportHeaderItem]
ackedBy) -> GlobalState addr
-> Connection addr
-> ByteString
-> Maybe (TransportHeaderItem -> Bool)
-> IO ()
forall addr.
GlobalState addr
-> Connection addr
-> ByteString
-> Maybe (TransportHeaderItem -> Bool)
-> IO ()
sendBytes GlobalState addr
gs Connection addr
conn ByteString
bs (Maybe (TransportHeaderItem -> Bool) -> IO ())
-> Maybe (TransportHeaderItem -> Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TransportHeaderItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TransportHeaderItem]
ackedBy) Maybe ()
-> Maybe (TransportHeaderItem -> Bool)
-> Maybe (TransportHeaderItem -> Bool)
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (TransportHeaderItem -> Bool)
-> Maybe (TransportHeaderItem -> Bool)
forall a. a -> Maybe a
Just (TransportHeaderItem -> [TransportHeaderItem] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TransportHeaderItem]
ackedBy)
Maybe (ByteString, [TransportHeaderItem])
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let retransmitPacket :: Connection addr -> STM (IO ())
retransmitPacket :: Connection addr -> STM (IO ())
retransmitPacket conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} = do
TimeSpec
now <- TVar TimeSpec -> STM TimeSpec
forall a. TVar a -> STM a
readTVar TVar TimeSpec
gNowVar
(SentPacket
sp, [SentPacket]
rest) <- TVar [SentPacket] -> STM [SentPacket]
forall a. TVar a -> STM a
readTVar TVar [SentPacket]
cSentPackets STM [SentPacket]
-> ([SentPacket] -> STM (SentPacket, [SentPacket]))
-> STM (SentPacket, [SentPacket])
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
sps :: [SentPacket]
sps@(SentPacket
_:[SentPacket]
_) -> (SentPacket, [SentPacket]) -> STM (SentPacket, [SentPacket])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SentPacket] -> SentPacket
forall a. HasCallStack => [a] -> a
last [SentPacket]
sps, [SentPacket] -> [SentPacket]
forall a. HasCallStack => [a] -> [a]
init [SentPacket]
sps)
[SentPacket]
_ -> STM (SentPacket, [SentPacket])
forall a. STM a
retry
let nextTry :: TimeSpec
nextTry = SentPacket -> TimeSpec
spTime SentPacket
sp TimeSpec -> TimeSpec -> TimeSpec
forall a. Num a => a -> a -> a
+ Integer -> TimeSpec
fromNanoSecs Integer
1000000000
if TimeSpec
now TimeSpec -> TimeSpec -> Bool
forall a. Ord a => a -> a -> Bool
< TimeSpec
nextTry
then do
TimeSpec
nextTimeout <- TVar TimeSpec -> STM TimeSpec
forall a. TVar a -> STM a
readTVar TVar TimeSpec
gNextTimeout
if TimeSpec
nextTimeout TimeSpec -> TimeSpec -> Bool
forall a. Ord a => a -> a -> Bool
<= TimeSpec
now Bool -> Bool -> Bool
|| TimeSpec
nextTry TimeSpec -> TimeSpec -> Bool
forall a. Ord a => a -> a -> Bool
< TimeSpec
nextTimeout
then do TVar TimeSpec -> TimeSpec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar TimeSpec
gNextTimeout TimeSpec
nextTry
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else STM (IO ())
forall a. STM a
retry
else do
TVar [SentPacket] -> [SentPacket] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [SentPacket]
cSentPackets [SentPacket]
rest
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ GlobalState addr -> Connection addr -> SentPacket -> IO ()
forall addr.
GlobalState addr -> Connection addr -> SentPacket -> IO ()
resendBytes GlobalState addr
gs Connection addr
conn SentPacket
sp
let handleControlRequests :: STM (IO ())
handleControlRequests = Flow (ControlRequest addr) (ControlMessage addr)
-> STM (ControlRequest addr)
forall r w. Flow r w -> STM r
readFlow Flow (ControlRequest addr) (ControlMessage addr)
gControlFlow STM (ControlRequest addr)
-> (ControlRequest addr -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
RequestConnection addr
addr -> do
conn :: Connection addr
conn@Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} <- GlobalState addr -> addr -> STM (Connection addr)
forall addr. GlobalState addr -> addr -> STM (Connection addr)
getConnection GlobalState addr
gs addr
addr
UnifiedIdentity
identity <- (UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity
forall a b. (a, b) -> a
fst ((UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity)
-> STM (UnifiedIdentity, [UnifiedIdentity]) -> STM UnifiedIdentity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UnifiedIdentity, [UnifiedIdentity])
-> STM (UnifiedIdentity, [UnifiedIdentity])
forall a. TVar a -> STM a
readTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity
TVar ChannelState -> STM ChannelState
forall a. TVar a -> STM a
readTVar TVar ChannelState
cChannel STM ChannelState -> (ChannelState -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ChannelState
ChannelNone -> do
let packet :: ByteString
packet = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.concat
[ PartialObject -> ByteString
forall (c :: * -> *). Object' c -> ByteString
serializeObject (PartialObject -> ByteString) -> PartialObject -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialStorage -> TransportHeader -> PartialObject
transportToObject PartialStorage
gStorage (TransportHeader -> PartialObject)
-> TransportHeader -> PartialObject
forall a b. (a -> b) -> a -> b
$ [TransportHeaderItem] -> TransportHeader
TransportHeader ([TransportHeaderItem] -> TransportHeader)
-> [TransportHeaderItem] -> TransportHeader
forall a b. (a -> b) -> a -> b
$
[ RefDigest -> TransportHeaderItem
Initiation (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref
gInitConfig
, RefDigest -> TransportHeaderItem
AnnounceSelf (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Signed IdentityData) -> Ref)
-> Stored (Signed IdentityData) -> Ref
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Stored (Signed IdentityData)
idData UnifiedIdentity
identity
] [TransportHeaderItem]
-> [TransportHeaderItem] -> [TransportHeaderItem]
forall a. [a] -> [a] -> [a]
++ (Text -> TransportHeaderItem) -> [Text] -> [TransportHeaderItem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> TransportHeaderItem
ProtocolVersion [Text]
protocolVersions
, Ref -> LoadResult Complete ByteString
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c ByteString
lazyLoadBytes Ref
gInitConfig
]
TVar ChannelState -> ChannelState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ChannelState
cChannel ChannelState
ChannelCookieWait
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ GlobalState addr
-> Connection addr
-> ByteString
-> Maybe (TransportHeaderItem -> Bool)
-> IO ()
forall addr.
GlobalState addr
-> Connection addr
-> ByteString
-> Maybe (TransportHeaderItem -> Bool)
-> IO ()
sendBytes GlobalState addr
gs Connection addr
conn ByteString
packet (Maybe (TransportHeaderItem -> Bool) -> IO ())
-> Maybe (TransportHeaderItem -> Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ (TransportHeaderItem -> Bool)
-> Maybe (TransportHeaderItem -> Bool)
forall a. a -> Maybe a
Just ((TransportHeaderItem -> Bool)
-> Maybe (TransportHeaderItem -> Bool))
-> (TransportHeaderItem -> Bool)
-> Maybe (TransportHeaderItem -> Bool)
forall a b. (a -> b) -> a -> b
$ \case CookieSet {} -> Bool
True; TransportHeaderItem
_ -> Bool
False
ChannelState
_ -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
SendAnnounce addr
addr -> do
UnifiedIdentity
identity <- (UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity
forall a b. (a, b) -> a
fst ((UnifiedIdentity, [UnifiedIdentity]) -> UnifiedIdentity)
-> STM (UnifiedIdentity, [UnifiedIdentity]) -> STM UnifiedIdentity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (UnifiedIdentity, [UnifiedIdentity])
-> STM (UnifiedIdentity, [UnifiedIdentity])
forall a. TVar a -> STM a
readTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity
let packet :: ByteString
packet = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialObject -> ByteString
forall (c :: * -> *). Object' c -> ByteString
serializeObject (PartialObject -> ByteString) -> PartialObject -> ByteString
forall a b. (a -> b) -> a -> b
$ PartialStorage -> TransportHeader -> PartialObject
transportToObject PartialStorage
gStorage (TransportHeader -> PartialObject)
-> TransportHeader -> PartialObject
forall a b. (a -> b) -> a -> b
$ [TransportHeaderItem] -> TransportHeader
TransportHeader ([TransportHeaderItem] -> TransportHeader)
-> [TransportHeaderItem] -> TransportHeader
forall a b. (a -> b) -> a -> b
$
[ RefDigest -> TransportHeaderItem
AnnounceSelf (RefDigest -> TransportHeaderItem)
-> RefDigest -> TransportHeaderItem
forall a b. (a -> b) -> a -> b
$ Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest) -> Ref -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored (Signed IdentityData) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Signed IdentityData) -> Ref)
-> Stored (Signed IdentityData) -> Ref
forall a b. (a -> b) -> a -> b
$ UnifiedIdentity -> Stored (Signed IdentityData)
idData UnifiedIdentity
identity
] [TransportHeaderItem]
-> [TransportHeaderItem] -> [TransportHeaderItem]
forall a. [a] -> [a] -> [a]
++ (Text -> TransportHeaderItem) -> [Text] -> [TransportHeaderItem]
forall a b. (a -> b) -> [a] -> [b]
map Text -> TransportHeaderItem
ProtocolVersion [Text]
protocolVersions
SymFlow (addr, ByteString) -> (addr, ByteString) -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow SymFlow (addr, ByteString)
gDataFlow (addr
addr, ByteString
packet)
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
UpdateSelfIdentity UnifiedIdentity
nid -> do
(UnifiedIdentity
cur, [UnifiedIdentity]
past) <- TVar (UnifiedIdentity, [UnifiedIdentity])
-> STM (UnifiedIdentity, [UnifiedIdentity])
forall a. TVar a -> STM a
readTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity
TVar (UnifiedIdentity, [UnifiedIdentity])
-> (UnifiedIdentity, [UnifiedIdentity]) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (UnifiedIdentity, [UnifiedIdentity])
gIdentity (UnifiedIdentity
nid, UnifiedIdentity
cur UnifiedIdentity -> [UnifiedIdentity] -> [UnifiedIdentity]
forall a. a -> [a] -> [a]
: [UnifiedIdentity]
past)
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Connection addr]
conns <- TVar [Connection addr] -> STM [Connection addr]
forall a. TVar a -> STM a
readTVar TVar [Connection addr]
gConnections
[STM (IO ())] -> STM (IO ())
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([STM (IO ())] -> STM (IO ())) -> [STM (IO ())] -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ [[STM (IO ())]] -> [STM (IO ())]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[STM (IO ())]] -> [STM (IO ())])
-> [[STM (IO ())]] -> [STM (IO ())]
forall a b. (a -> b) -> a -> b
$
[ (Connection addr -> STM (IO ()))
-> [Connection addr] -> [STM (IO ())]
forall a b. (a -> b) -> [a] -> [b]
map Connection addr -> STM (IO ())
retransmitPacket [Connection addr]
conns
, (Connection addr -> STM (IO ()))
-> [Connection addr] -> [STM (IO ())]
forall a b. (a -> b) -> [a] -> [b]
map Connection addr -> STM (IO ())
sendNextPacket [Connection addr]
conns
, [ STM (IO ())
handleControlRequests ]
]
processAcknowledgements :: GlobalState addr -> Connection addr -> [TransportHeaderItem] -> STM ()
processAcknowledgements :: forall addr.
GlobalState addr
-> Connection addr -> [TransportHeaderItem] -> STM ()
processAcknowledgements GlobalState {} Connection {addr
TVar [Integer]
TVar [SentPacket]
TVar ChannelState
TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cAddress :: forall addr. Connection addr -> addr
cDataUp :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: forall addr.
Connection addr
-> Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: forall addr. Connection addr -> TVar ChannelState
cSecureOutQueue :: forall addr.
Connection addr
-> TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: forall addr. Connection addr -> TVar [SentPacket]
cToAcknowledge :: forall addr. Connection addr -> TVar [Integer]
cAddress :: addr
cDataUp :: Flow
(Bool, TransportPacket PartialObject)
(Bool, TransportPacket Ref, [TransportHeaderItem])
cDataInternal :: Flow
(Bool, TransportPacket Ref, [TransportHeaderItem])
(Bool, TransportPacket PartialObject)
cChannel :: TVar ChannelState
cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
cSentPackets :: TVar [SentPacket]
cToAcknowledge :: TVar [Integer]
..} = (TransportHeaderItem -> STM ()) -> [TransportHeaderItem] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((TransportHeaderItem -> STM ())
-> [TransportHeaderItem] -> STM ())
-> (TransportHeaderItem -> STM ())
-> [TransportHeaderItem]
-> STM ()
forall a b. (a -> b) -> a -> b
$ \TransportHeaderItem
hitem -> do
TVar [SentPacket] -> ([SentPacket] -> [SentPacket]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [SentPacket]
cSentPackets (([SentPacket] -> [SentPacket]) -> STM ())
-> ([SentPacket] -> [SentPacket]) -> STM ()
forall a b. (a -> b) -> a -> b
$ (SentPacket -> Bool) -> [SentPacket] -> [SentPacket]
forall a. (a -> Bool) -> [a] -> [a]
filter ((SentPacket -> Bool) -> [SentPacket] -> [SentPacket])
-> (SentPacket -> Bool) -> [SentPacket] -> [SentPacket]
forall a b. (a -> b) -> a -> b
$ \SentPacket
sp -> Bool -> Bool
not (Maybe (TransportHeaderItem -> Bool) -> TransportHeaderItem -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (SentPacket -> Maybe (TransportHeaderItem -> Bool)
spAckedBy SentPacket
sp) TransportHeaderItem
hitem)