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 TransportHeader = TransportHeader [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 TransportHeaderItem
    = 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
isHeaderItemAcknowledged :: TransportHeaderItem -> Bool
isHeaderItemAcknowledged = \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 -- sent initiation, waiting for response
                  | ChannelCookieReceived Cookie -- received cookie, but no cookie echo yet
                  | ChannelCookieConfirmed Cookie -- received cookie echo, no need to send from our side
                  | 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
    -- Established secure communication
    | 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)

    -- Plaintext communication with cookies to prove origin
    | 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

    -- Response to initiation packet
    | 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

    -- Initiation packet
    | 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

    -- Announce packet outside any connection
    | 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]
generateCookieHeaders :: forall addr.
GlobalState addr
-> addr -> ChannelState -> IO [TransportHeaderItem]
generateCookieHeaders 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)