From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- dht/Connection.hs | 135 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 135 insertions(+) create mode 100644 dht/Connection.hs (limited to 'dht/Connection.hs') diff --git a/dht/Connection.hs b/dht/Connection.hs new file mode 100644 index 00000000..9a4077f5 --- /dev/null +++ b/dht/Connection.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Connection where + +import Control.Applicative +import Control.Arrow +import Control.Concurrent.STM +import Data.Bits +import Data.Word +import qualified Data.Map as Map + ;import Data.Map (Map) +import Network.Socket (SockAddr(..)) + +import PingMachine + +-- | This type indicates the current status of a connection. The type +-- parameter indicates protocol-specific status information. To present +-- information as a user-comprehensible string, use 'showStatus'. +data Status status + = Dormant + | InProgress status + | Established + deriving (Show,Eq,Ord,Functor) + +-- | A policy indicates a desired connection status. +data Policy + = RefusingToConnect -- ^ We desire no connection. + | OpenToConnect -- ^ We will cooperate if a remote side initiates. + | TryingToConnect -- ^ We desire to be connected. + deriving (Eq,Ord,Show) + +-- | Information obtained via the 'connectionStatus' interface to +-- 'Manager'. +data Connection status = Connection + { connStatus :: Status status + , connPolicy :: Policy + } + deriving Functor + +-- | A 'PeerAddress' identifies an active session. For inactive sessions, multiple +-- values may be feasible. + +-- We use a 'SockAddr' as it is convenient for TCP and UDP connections. But if +-- that is not your use case, see 'uniqueAsKey'. +newtype PeerAddress = PeerAddress { peerAddress :: SockAddr } + deriving (Eq,Ord,Show) + +-- | A 24-byte word. +data Uniq24 = Uniq24 !Word64 !Word64 !Word64 + deriving (Eq,Ord,Show) + +-- | Coerce a 'Uniq24' to a useable 'PeerAddress'. Note that this stores the +-- special value 0 into the port number of the underlying 'SockAddr' and thus +-- should be compatible for mixing together with TCP/UDP peers. +uniqueAsKey :: Uniq24 -> PeerAddress +uniqueAsKey (Uniq24 x y z) = PeerAddress $ SockAddrInet6 (fromIntegral 0) a bcde f + where + a = fromIntegral (x `shiftR` 32) + b = fromIntegral x + c = fromIntegral (y `shiftR` 32) + d = fromIntegral y + e = fromIntegral (z `shiftR` 32) + f = fromIntegral z + bcde = (b,c,d,e) + +-- | Inverse of 'uniqueAsKey' +keyAsUnique :: PeerAddress -> Maybe Uniq24 +keyAsUnique (PeerAddress (SockAddrInet6 0 a bcde f)) = Just $ Uniq24 x y z + where + (b,c,d,e) = bcde + x = (fromIntegral a `shiftL` 32) .|. fromIntegral b + y = (fromIntegral c `shiftL` 32) .|. fromIntegral d + z = (fromIntegral e `shiftL` 32) .|. fromIntegral f +keyAsUniq _ = Nothing + + +-- | This is an interface to make or query status information about connections +-- of a specific kind. +-- +-- Type parameters: +-- +-- /k/ names a connection. It should implement Ord, and can be parsed and +-- displayed using 'stringToKey' and 'showKey'. +-- +-- /status/ indicates the progress of a connection. It is intended as a +-- parameter to the 'InProgress' constructor of 'Status'. +-- +data Manager status k = Manager + { -- | Connect or disconnect a connection. + setPolicy :: k -> Policy -> IO () + -- | Lookup a connection status. + , status :: k -> STM (Connection status) + -- | Obtain a list of all known connections. + , connections :: STM [k] + -- | Parse a connection key out of a string. Inverse of 'showKey'. + , stringToKey :: String -> Maybe k + -- | Convert a progress value to a string. + , showProgress :: status -> String + -- | Show a connection key as a string. + , showKey :: k -> String + -- | Obtain an address from a human-friendly name. For TCP/UDP + -- connections, this might be a forward-resolving DNS query. + , resolvePeer :: k -> IO [PeerAddress] + -- | This is the reverse of 'resolvePeer'. For TCP/UDP connections, this + -- might be a reverse-resolve DNS query. + , reverseAddress :: PeerAddress -> IO [k] + } + +-- | Present status information (visible in a UI) for a connection. +showStatus :: Manager status k -> Status status -> String +showStatus mgr Dormant = "dormant" +showStatus mgr Established = "established" +showStatus mgr (InProgress s) = "in progress ("++showProgress mgr s++")" + + +-- | Combine two different species of 'Manager' into a single interface using +-- 'Either' to combine key and status types. +addManagers :: (Ord kA, Ord kB) => + Manager statusA kA + -> Manager statusB kB + -> Manager (Either statusA statusB) (Either kA kB) +addManagers mgrA mgrB = Manager + { setPolicy = either (setPolicy mgrA) (setPolicy mgrB) + , status = \case + Left k -> fmap Left <$> status mgrA k + Right k -> fmap Right <$> status mgrB k + , connections = do + as <- connections mgrA + bs <- connections mgrB + return $ map Left as ++ map Right bs + , stringToKey = \str -> Left <$> stringToKey mgrA str + <|> Right <$> stringToKey mgrB str + , showProgress = either (showProgress mgrA) (showProgress mgrB) + , showKey = either (showKey mgrA) (showKey mgrB) + } -- cgit v1.2.3