server library.

16 files changed, 2991 insertions, 0 deletions

diff --git a/server/server.cabal b/server/server.cabal
new file mode 100644
index 00000000..95d7aacf
--- /dev/null
+++ b/server/server.cabal
@@ -0,0 +1,25 @@
+cabal-version:       2.2
+-- Initial package description 'server.cabal' generated by 'cabal init'.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name:                server
+version:             0.1.0.0
+synopsis:            TCP/UDP server library.
+-- description:
+-- bug-reports:
+license:             NONE
+-- license-file:        LICENSE
+author:              Joe Crayne
+maintainer:          joe@jerkface.net
+-- copyright:
+category:            Network
+extra-source-files:  CHANGELOG.md
+
+library
+  exposed-modules:     Network.QueryResponse, Network.StreamServer, Network.SocketLike, Network.QueryResponse.TCP, Data.TableMethods, Connection.Tcp, Control.Concurrent.Delay, DNSCache, GetHostByAddr, ControlMaybe, SockAddr, Control.Concurrent.PingMachine, Connection
+  other-modules: ForkLabeled, DebugTag
+  other-extensions:    CPP, GADTs, LambdaCase, PartialTypeSignatures, RankNTypes, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving, DoAndIfThenElse, FlexibleInstances, StandaloneDeriving
+  build-depends:       base, stm, bytestring, dependent-map, dependent-sum, contravariant, containers, time, network, cpu, dput-hslogger, directory, lifted-base, hashable, conduit, text, psq-wrap, minmax-psq, lifted-concurrent, word64-map, network-addr
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  cpp-options: -DTHREAD_DEBUG
diff --git a/server/src/Connection.hs b/server/src/Connection.hs
new file mode 100644
index 00000000..ea86f4bb
--- /dev/null
+++ b/server/src/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 Control.Concurrent.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)
+    }
diff --git a/server/src/Connection/Tcp.hs b/server/src/Connection/Tcp.hs
new file mode 100644
index 00000000..7d93e7de
--- /dev/null
+++ b/server/src/Connection/Tcp.hs
@@ -0,0 +1,825 @@
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE DoAndIfThenElse          #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE TupleSections            #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Connection.Tcp
+--
+-- Maintainer  :  joe@jerkface.net
+-- Stability   :  experimental
+--
+-- A TCP client/server library.
+--
+-- TODO:
+--
+--  * interface tweaks
+--
+module Connection.Tcp
+    ( module Connection.Tcp
+    , module Control.Concurrent.PingMachine ) where
+
+import Data.ByteString (ByteString,hGetNonBlocking)
+import qualified Data.ByteString.Char8 as S -- ( hPutStrLn, hPutStr, pack)
+import Data.Conduit ( ConduitT, Void, Flush )
+#if MIN_VERSION_containers(0,5,0)
+import qualified Data.Map.Strict as Map
+import           Data.Map.Strict (Map)
+#else
+import qualified Data.Map as Map
+import           Data.Map (Map)
+#endif
+import Data.Monoid ( (<>) )
+import Control.Concurrent.ThreadUtil
+
+import Control.Arrow
+import Control.Concurrent.STM
+-- import Control.Concurrent.STM.TMVar
+-- import Control.Concurrent.STM.TChan
+-- import Control.Concurrent.STM.Delay
+import Control.Exception ({-evaluate,-}handle,SomeException(..),ErrorCall(..),onException)
+import Control.Monad
+import Control.Monad.Fix
+-- import Control.Monad.STM
+-- import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Maybe
+import System.IO.Error (isDoesNotExistError)
+import System.IO
+    ( IOMode(..)
+    , hSetBuffering
+    , BufferMode(..)
+    , hWaitForInput
+    , hClose
+    , hIsEOF
+    , Handle
+    )
+import Network.Socket as Socket
+import Network.BSD
+    ( getProtocolNumber
+    )
+import Debug.Trace
+import Data.Time.Clock (getCurrentTime,diffUTCTime)
+-- import SockAddr ()
+-- import System.Locale (defaultTimeLocale)
+
+import qualified Data.Text as Text
+         ;import Data.Text (Text)
+import DNSCache
+import Control.Concurrent.Delay
+import Control.Concurrent.PingMachine
+import Network.StreamServer
+import Network.SocketLike hiding (sClose)
+import qualified Connection as G
+         ;import Connection (Manager (..), PeerAddress (..), Policy (..))
+import Network.Address (localhost4)
+import DPut
+import DebugTag
+
+
+type Microseconds = Int
+
+-- | This object is passed with the 'Listen' and 'Connect'
+-- instructions in order to control the behavior of the
+-- connections that are established.  It is parameterized
+-- by a user-suplied type @conkey@ that is used as a lookup
+-- key for connections.
+data ConnectionParameters conkey u =
+  ConnectionParameters
+    { pingInterval :: PingInterval
+    -- ^ The miliseconds of idle to allow before a 'RequiresPing'
+    -- event is signaled.
+    , timeout :: TimeOut
+    -- ^ The miliseconds of idle after 'RequiresPing' is signaled
+    -- that are necessary for the connection to be considered
+    -- lost and signalling 'EOF'.
+    , makeConnKey :: (RestrictedSocket,(Local SockAddr, Remote SockAddr)) -> IO (conkey,u)
+    -- ^ This action creates a lookup key for a new connection.  If 'duplex'
+    -- is 'True' and the result is already assocatied with an established
+    -- connection, then an 'EOF' will be forced before the the new
+    -- connection becomes active.
+    --
+    , duplex :: Bool
+    -- ^ If True, then the connection will be treated as a normal
+    -- two-way socket.  Otherwise, a readable socket is established
+    -- with 'Listen' and a writable socket is established with
+    -- 'Connect' and they are associated when 'makeConnKey' yields
+    -- same value for each.
+    }
+
+-- | Use this function to select appropriate default values for
+-- 'ConnectionParameters' other than 'makeConnKey'.
+--
+-- Current defaults:
+--
+--  * 'pingInterval' = 28000
+--
+--  * 'timeout' = 2000
+--
+--  * 'duplex' = True
+--
+connectionDefaults
+  :: ((RestrictedSocket,(Local SockAddr,Remote SockAddr)) -> IO (conkey,u)) -> ConnectionParameters conkey u
+connectionDefaults f = ConnectionParameters
+    { pingInterval = 28000
+    , timeout = 2000
+    , makeConnKey = f
+    , duplex = True
+    }
+
+-- | Instructions for a 'Server' object
+--
+-- To issue a command, put it into the 'serverCommand' TMVar.
+data ServerInstruction conkey u
+    = Quit
+    -- ^ kill the server.  This command is automatically issued when
+    -- the server is released.
+    | Listen SockAddr (ConnectionParameters conkey u)
+    -- ^ listen for incoming connections on the given bind address.
+    | Connect SockAddr  (ConnectionParameters conkey u)
+    -- ^ connect to addresses
+    | ConnectWithEndlessRetry SockAddr
+                              (ConnectionParameters conkey u)
+                              Miliseconds
+    -- ^ keep retrying the connection
+    | Ignore SockAddr
+    -- ^ stop listening on specified bind address
+    | Send conkey ByteString
+    -- ^ send bytes to an established connection
+
+#ifdef TEST
+deriving instance Show conkey => Show (ServerInstruction conkey u)
+instance Show (a -> b) where show _ = "<function>"
+deriving instance Show conkey => Show (ConnectionParameters conkey u)
+#endif
+
+-- | This type specifies which which half of a half-duplex
+-- connection is of interest.
+data InOrOut = In | Out
+ deriving (Enum,Eq,Ord,Show,Read)
+
+-- | These events may be read from 'serverEvent' TChannel.
+--
+data ConnectionEvent b
+    = Connection (STM Bool) (ConduitT () b IO ()) (ConduitT (Flush b) Void IO ())
+    -- ^ A new connection was established
+    | ConnectFailure SockAddr
+    -- ^ A 'Connect' command failed.
+    | HalfConnection InOrOut
+    -- ^ Half of a half-duplex connection is avaliable.
+    | EOF
+    -- ^ A connection was terminated
+    | RequiresPing
+    -- ^ 'pingInterval' miliseconds of idle was experienced
+
+#ifdef TEST
+instance Show (IO a) where show _ = "<IO action>"
+instance Show (STM a) where show _ = "<STM action>"
+instance Eq (ByteString -> IO Bool) where (==) _ _ = True
+instance Eq (IO (Maybe ByteString)) where (==) _ _ = True
+instance Eq (STM Bool) where (==) _ _ = True
+deriving instance Show b => Show (ConnectionEvent b)
+deriving instance Eq   b => Eq   (ConnectionEvent b)
+#endif
+
+-- | This is the per-connection state.
+data ConnectionRecord u
+ = ConnectionRecord { ckont  :: TMVar (STM (IO ())) -- ^ used to pass a continuation to update the eof-handler
+                    , cstate :: ConnectionState     -- ^ used to send/receive data to the connection
+                    , cdata  :: u                   -- ^ user data, stored in the connection map for convenience
+                    }
+
+-- | This object accepts commands and signals events and maintains
+-- the list of currently listening ports and established connections.
+data Server a u releaseKey b
+ = Server { serverCommand    :: TMVar (ServerInstruction a u)
+          , serverEvent      :: TChan ((a,u), ConnectionEvent b)
+          , serverReleaseKey :: releaseKey
+          , conmap           :: TVar (Map a (ConnectionRecord u))
+          , listenmap        :: TVar (Map SockAddr ServerHandle)
+          , retrymap         :: TVar (Map SockAddr (TVar Bool,InterruptibleDelay))
+          }
+
+control :: Server a u releaseKey b -> ServerInstruction a u -> IO ()
+control sv = atomically . putTMVar (serverCommand sv)
+
+type Allocate releaseKey m = forall b. IO b -> (b -> IO ()) -> m (releaseKey, b)
+
+noCleanUp :: MonadIO m => Allocate () m
+noCleanUp io _ = ( (,) () ) `liftM` liftIO io
+
+-- | Construct a 'Server' object.  Use 'Control.Monad.Trans.Resource.ResourceT'
+-- to ensure proper cleanup.  For example,
+--
+-- > import Connection.Tcp
+-- > import Control.Monad.Trans.Resource (runResourceT)
+-- > import Control.Monad.IO.Class       (liftIO)
+-- > import Control.Monad.STM            (atomically)
+-- > import Control.Concurrent.STM.TMVar (putTMVar)
+-- > import Control.Concurrent.STM.TChan (readTChan)
+-- >
+-- > main = runResourceT $ do
+-- >   sv <- server allocate
+-- >   let params = connectionDefaults (return . snd)
+-- >   liftIO . atomically $ putTMVar (serverCommand sv) (Listen 2942 params)
+-- >   let loop = do
+-- >          (_,event) <- atomically $ readTChan (serverEvent sv)
+-- >          case event of
+-- >            Connection getPingFlag readData writeData -> do
+-- >              forkIO $ do
+-- >                fix $ \readLoop -> do
+-- >                    readData >>= mapM $ \bytes ->
+-- >                        putStrLn $ "got: " ++ show bytes
+-- >                        readLoop
+-- >          case event of EOF -> return ()
+-- >                        _   -> loop
+-- >   liftIO loop
+--
+-- Using 'Control.Monad.Trans.Resource.ResourceT' is optional.  Pass 'noCleanUp'
+-- to do without automatic cleanup and be sure to remember to write 'Quit' to
+-- the 'serverCommand' variable.
+server ::
+    -- forall (m :: * -> *) a u conkey releaseKey.
+    (Show conkey, MonadIO m, Ord conkey) =>
+    Allocate releaseKey m
+    -> ( IO (Maybe ByteString) -> (ByteString -> IO Bool) -> ( ConduitT () x IO (), ConduitT (Flush x) Void IO () ) )
+    -> m (Server conkey u releaseKey x)
+server allocate sessionConduits = do
+    (key,cmds) <- allocate (atomically newEmptyTMVar)
+                           (atomically . flip putTMVar Quit)
+    server <- liftIO . atomically $ do
+        tchan    <- newTChan
+        conmap   <- newTVar Map.empty
+        listenmap<- newTVar Map.empty
+        retrymap <- newTVar Map.empty
+        return Server { serverCommand = cmds
+                      , serverEvent = tchan
+                      , serverReleaseKey = key
+                      , conmap = conmap
+                      , listenmap = listenmap
+                      , retrymap = retrymap
+                      }
+    liftIO $ do
+        forkLabeled "server" $ fix $ \loop -> do
+            instr <- atomically $ takeTMVar cmds
+            -- warn $ "instr = " <> bshow instr
+            let again = do doit server instr
+                           -- warn $ "finished " <> bshow instr
+                           loop
+            case instr of Quit -> closeAll server
+                          _    -> again
+        return server
+ where
+  closeAll server = do
+    listening <- atomically . readTVar $ listenmap server
+    mapM_ quitListening   (Map.elems listening)
+    let stopRetry (v,d) = do atomically $ writeTVar v False
+                             interruptDelay d
+    retriers <- atomically $ do
+        rmap <- readTVar $ retrymap server
+        writeTVar (retrymap server) Map.empty
+        return rmap
+    mapM_ stopRetry (Map.elems retriers)
+    cons <- atomically . readTVar $ conmap server
+    atomically $ mapM_ (connClose . cstate) (Map.elems cons)
+    atomically $ mapM_ (connWait . cstate) (Map.elems cons)
+    atomically $ writeTVar (conmap server) Map.empty
+
+
+  doit server (Listen port params) = do
+
+    listening <- Map.member port
+                 `fmap` atomically (readTVar $ listenmap server)
+    when (not listening) $ do
+
+    dput XMisc $ "Started listening on "++show port
+
+    sserv <- flip streamServer [port] ServerConfig
+        { serverWarn    = dput XMisc
+        , serverSession = \sock _ h -> do
+            (conkey,u) <- makeConnKey params sock
+            _ <- newConnection server sessionConduits params conkey u h In
+            return ()
+        }
+
+    atomically $ listenmap server `modifyTVar'` Map.insert port sserv
+
+  doit server (Ignore port) = do
+    dput XMisc $ "Stopping listen on "++show port
+    mb <- atomically $ do
+        map <- readTVar $ listenmap server
+        modifyTVar' (listenmap server) $ Map.delete port
+        return $ Map.lookup port map
+    maybe (return ()) quitListening $ mb
+
+  doit server (Send con bs) = do -- . void . forkIO $ do
+    map <- atomically $ readTVar (conmap server)
+    let post False = (trace ("cant send: "++show bs) $ return ())
+        post True  = return ()
+    maybe (post False)
+          (post <=< flip connWrite bs . cstate)
+      $ Map.lookup con map
+
+  doit server (Connect addr params) = join $ atomically $ do
+    Map.lookup addr <$> readTVar (retrymap server)
+      >>= return . \case
+        Nothing    -> forkit
+        Just (v,d) -> do b <- atomically $ readTVar v
+                         interruptDelay d
+                         when (not b) forkit
+    where
+    forkit = void . forkLabeled ( "Connect." ++ show addr ) $ do
+        proto <- getProtocolNumber "tcp"
+        sock <- socket (socketFamily addr) Stream proto
+        handle (\e -> do -- let t = ioeGetErrorType e
+                         when (isDoesNotExistError e) $ return () -- warn "GOTCHA"
+                         -- warn $ "connect-error: " <> bshow e
+                         (conkey,u) <- makeConnKey params (restrictSocket sock,(Local localhost4, Remote addr)) -- XXX: ?
+                         Socket.close sock
+                         atomically
+                            $ writeTChan (serverEvent server)
+                                $ ((conkey,u),ConnectFailure addr))
+               $ do
+        connect sock addr
+        laddr <- Socket.getSocketName sock
+        (conkey,u) <- makeConnKey params (restrictSocket sock, (Local laddr, Remote addr))
+        h <- socketToHandle sock ReadWriteMode
+        newConnection server sessionConduits params conkey u h Out
+        return ()
+
+  doit server (ConnectWithEndlessRetry addr params interval) = do
+    proto <- getProtocolNumber "tcp"
+    void . forkLabeled ("ConnectWithEndlessRetry." ++ show addr) $ do
+        timer <- interruptibleDelay
+        (retryVar,action) <- atomically $ do
+            map <- readTVar (retrymap server)
+            action <- case Map.lookup addr map of
+                Nothing    -> return $ return ()
+                Just (v,d) -> do writeTVar v False
+                                 return $ interruptDelay d
+            v <- newTVar True
+            writeTVar (retrymap server) $! Map.insert addr (v,timer) map
+            return (v,action :: IO ())
+        action
+        fix $ \retryLoop -> do
+        utc <- getCurrentTime
+        shouldRetry <- do
+            handle (\(SomeException e) -> do
+                -- Exceptions thrown by 'socket' need to be handled specially
+                -- since we don't have enough information to broadcast a ConnectFailure
+                -- on serverEvent.
+                warn $ "Failed to create socket: " <> bshow e
+                atomically $ readTVar retryVar) $ do
+            sock <- socket (socketFamily addr) Stream proto
+            handle (\(SomeException e) -> do
+                -- Any thing else goes wrong and we broadcast ConnectFailure.
+                do (conkey,u) <- makeConnKey params (restrictSocket sock,(Local localhost4, Remote addr))
+                   Socket.close sock
+                   atomically $ writeTChan (serverEvent server) ((conkey,u),ConnectFailure addr)
+                 `onException` return ()
+                atomically $ readTVar retryVar) $ do
+            connect sock addr
+            laddr <- Socket.getSocketName sock
+            (conkey,u) <- makeConnKey params (restrictSocket sock, (Local laddr, Remote addr))
+            h <- socketToHandle sock ReadWriteMode
+            threads <- newConnection server sessionConduits params conkey u h Out
+            atomically $ do threadsWait threads
+                            readTVar retryVar
+        fin_utc <- getCurrentTime
+        when shouldRetry $ do
+        let elapsed = 1000.0 * (fin_utc `diffUTCTime` utc)
+            expected = fromIntegral interval
+        when (shouldRetry && elapsed < expected) $ do
+            debugNoise $ "Waiting to retry " <> bshow addr
+            void $ startDelay timer (round $ 1000 * (expected-elapsed))
+        debugNoise $ "retry " <> bshow (shouldRetry,addr)
+        when shouldRetry $ retryLoop
+
+
+-- INTERNAL ----------------------------------------------------------
+
+{-
+hWriteUntilNothing h outs =
+    fix $ \loop -> do
+        mb <- atomically $ takeTMVar outs
+        case mb of Just bs -> do S.hPutStrLn h bs
+                                 warn $ "wrote " <> bs
+                                 loop
+                   Nothing -> do warn $ "wrote Nothing"
+                                 hClose h
+
+-}
+connRead :: ConnectionState -> IO (Maybe ByteString)
+connRead (WriteOnlyConnection w) = do
+    -- atomically $ discardContents (threadsChannel w)
+    return Nothing
+connRead conn = do
+    c <- atomically $ getThreads
+    threadsRead c
+ where
+    getThreads =
+        case conn of SaneConnection c     -> return c
+                     ReadOnlyConnection c -> return c
+                     ConnectionPair c w   -> do
+                        -- discardContents (threadsChannel w)
+                        return c
+
+socketFamily :: SockAddr -> Family
+socketFamily (SockAddrInet _ _)      = AF_INET
+socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+socketFamily (SockAddrUnix _)        = AF_UNIX
+
+
+conevent :: ( IO (Maybe ByteString) -> (ByteString -> IO Bool) -> ( ConduitT () x IO (), ConduitT (Flush x) Void IO () ) )
+            -> ConnectionState
+            -> ConnectionEvent x
+conevent sessionConduits con = Connection pingflag read write
+ where
+    pingflag     = swapTVar (pingFlag (connPingTimer con)) False
+    (read,write) = sessionConduits (connRead con) (connWrite con)
+
+newConnection :: Ord a
+                 => Server a u1 releaseKey x
+                 -> ( IO (Maybe ByteString) -> (ByteString -> IO Bool) -> ( ConduitT () x IO (), ConduitT (Flush x) Void IO () ) )
+                 -> ConnectionParameters conkey u
+                 -> a
+                 -> u1
+                 -> Handle
+                 -> InOrOut
+                 -> IO ConnectionThreads
+newConnection server sessionConduits params conkey u h inout = do
+    hSetBuffering h NoBuffering
+    let (idle_ms,timeout_ms) =
+            case (inout,duplex params) of
+                (Out,False) -> ( 0, 0 )
+                _ -> ( pingInterval params
+                     , timeout params )
+
+    new <- do pinglogic <- forkPingMachine "newConnection" idle_ms timeout_ms
+              connectionThreads h pinglogic
+    started <- atomically $ newEmptyTMVar
+    kontvar <- atomically newEmptyTMVar
+    -- XXX: Why does kontvar store STM (IO ()) instead of just IO () ?
+    let _ = kontvar :: TMVar (STM (IO ()))
+    forkLabeled ("connecting...") $ do
+        getkont <- atomically $ takeTMVar kontvar
+        kont <- atomically getkont
+        kont
+
+    atomically $ do
+        current <- fmap (Map.lookup conkey) $ readTVar (conmap server)
+        case current of
+          Nothing -> do
+            (newCon,e) <- return $
+              if duplex params
+                then let newcon = SaneConnection new
+                     in ( newcon, ((conkey,u), conevent sessionConduits newcon) )
+                else ( case inout of
+                        In  -> ReadOnlyConnection new
+                        Out -> WriteOnlyConnection new
+                     , ((conkey,u), HalfConnection inout) )
+            modifyTVar' (conmap server) $ Map.insert conkey
+                ConnectionRecord { ckont = kontvar
+                                 , cstate = newCon
+                                 , cdata = u }
+            announce e
+            putTMVar kontvar $ return $ do
+                myThreadId >>= flip labelThread ("connection."++show inout) -- XXX: more info would be nice.
+                atomically $ putTMVar started ()
+                -- Wait for something interesting.
+                handleEOF conkey u kontvar newCon
+          Just what@ConnectionRecord { ckont =mvar }-> do
+            putTMVar kontvar $ return $ return () -- Kill redundant "connecting..." thread.
+            putTMVar mvar $ do
+                -- The action returned by updateConMap, eventually invokes handleEOF,
+                -- so the sequencer thread will not be terminated.
+                kont <- updateConMap conkey u new what
+                putTMVar started ()
+                return kont
+    return new
+ where
+
+  announce e = writeTChan (serverEvent server) e
+
+  -- This function loops and will not quit unless an action is posted to the
+  -- mvar that does not in turn invoke this function, or if an EOF occurs.
+  handleEOF conkey u mvar newCon = do
+    action <- atomically . foldr1 orElse $
+        [ takeTMVar mvar >>= id -- passed continuation
+        , connWait newCon     >> return eof
+        , connWaitPing newCon >>= return . sendPing
+        -- , pingWait pingTimer >>= return . sendPing
+        ]
+    action :: IO ()
+   where
+    eof = do
+            -- warn $ "EOF " <>bshow conkey
+            connCancelPing newCon
+            atomically $ do connFlush newCon
+                            announce ((conkey,u),EOF)
+                            modifyTVar' (conmap server)
+                                        $ Map.delete conkey
+            -- warn $ "fin-EOF "<>bshow conkey
+
+    sendPing PingTimeOut = do
+        {-
+        utc <- getCurrentTime
+        let utc' = formatTime defaultTimeLocale "%s" utc
+        warn $ "ping:TIMEOUT " <> bshow utc'
+        -}
+        atomically (connClose newCon)
+        eof
+
+    sendPing PingIdle = do
+        {-
+        utc <- getCurrentTime
+        let utc' = formatTime defaultTimeLocale "%s" utc
+        -- warn $ "ping:IDLE " <> bshow utc'
+        -}
+        atomically $ announce ((conkey,u),RequiresPing)
+        handleEOF conkey u mvar newCon
+
+
+  updateConMap conkey u new (ConnectionRecord { ckont=mvar, cstate=replaced, cdata=u0 }) = do
+    new' <-
+        if duplex params then do
+            announce ((conkey,u),EOF)
+            connClose replaced
+            let newcon = SaneConnection new
+            announce $ ((conkey,u),conevent sessionConduits newcon)
+            return $ newcon
+        else
+         case replaced of
+            WriteOnlyConnection w | inout==In ->
+                 do let newcon = ConnectionPair new w
+                    announce ((conkey,u),conevent sessionConduits newcon)
+                    return newcon
+            ReadOnlyConnection r  | inout==Out ->
+                 do let newcon = ConnectionPair r new
+                    announce ((conkey,u),conevent sessionConduits newcon)
+                    return newcon
+            _ -> do -- connFlush todo
+                    announce ((conkey,u0), EOF)
+                    connClose replaced
+                    announce ((conkey,u), HalfConnection inout)
+                    return $ case inout of
+                                In  -> ReadOnlyConnection new
+                                Out -> WriteOnlyConnection new
+    modifyTVar' (conmap server) $ Map.insert conkey
+        ConnectionRecord { ckont = mvar
+                         , cstate = new'
+                         , cdata = u }
+    return $ handleEOF conkey u mvar new'
+
+
+getPacket :: Handle -> IO ByteString
+getPacket h = do hWaitForInput h (-1)
+                 hGetNonBlocking h 1024
+
+
+
+-- | 'ConnectionThreads' is an interface to a pair of threads
+-- that are reading and writing a 'Handle'.
+data ConnectionThreads = ConnectionThreads
+    { threadsWriter  :: TMVar (Maybe ByteString)
+    , threadsChannel :: TChan ByteString
+    , threadsWait    :: STM () -- ^ waits for a 'ConnectionThreads' object to close
+    , threadsPing    :: PingMachine
+    }
+
+-- | This spawns the reader and writer threads and returns a newly
+-- constructed 'ConnectionThreads' object.
+connectionThreads :: Handle -> PingMachine -> IO ConnectionThreads
+connectionThreads h pinglogic = do
+
+    (donew,outs) <- atomically $ liftM2 (,) newEmptyTMVar newEmptyTMVar
+
+    (doner,incomming) <- atomically $ liftM2 (,) newEmptyTMVar newTChan
+    readerThread <- forkLabeled "readerThread" $ do
+        let finished e  = do
+                          hClose h
+                          -- warn $ "finished read: " <> bshow (fmap ioeGetErrorType e)
+                          -- let _ = fmap ioeGetErrorType e -- type hint
+                          let _ = fmap what e where what (SomeException _) = undefined
+                          atomically $ do tryTakeTMVar outs
+                                          putTMVar outs Nothing -- quit writer
+                                          putTMVar doner ()
+        handle (finished . Just) $ do
+            pingBump pinglogic -- start the ping timer
+            fix $ \loop -> do
+            packet <- getPacket h
+            -- warn $ "read: " <> S.take 60 packet
+            atomically $ writeTChan incomming packet
+            pingBump pinglogic
+            -- warn $ "bumped: " <> S.take 60 packet
+            isEof <- hIsEOF h
+            if isEof then finished Nothing else loop
+
+    writerThread <- forkLabeled "writerThread" . fix $ \loop -> do
+        let finished = do -- warn $ "finished write"
+                          -- hClose h -- quit reader
+                          throwTo readerThread (ErrorCall "EOF")
+                          atomically $ putTMVar donew ()
+        mb <- atomically $ readTMVar outs
+        case mb of Just bs -> handle (\(SomeException e)->finished)
+                                     (do -- warn $ "writing: " <> S.take 60 bs
+                                         S.hPutStr h bs
+                                         -- warn $ "wrote: " <> S.take 60 bs
+                                         atomically $ takeTMVar outs
+                                         loop)
+                   Nothing -> finished
+
+    let wait = do readTMVar donew
+                  readTMVar doner
+                  return ()
+    return ConnectionThreads { threadsWriter  = outs
+                             , threadsChannel = incomming
+                             , threadsWait    = wait
+                             , threadsPing    = pinglogic }
+
+
+-- | 'threadsWrite' writes the given 'ByteString' to the
+-- 'ConnectionThreads' object.  It blocks until the ByteString
+-- is written and 'True' is returned, or the connection is
+-- interrupted and 'False' is returned.
+threadsWrite :: ConnectionThreads -> ByteString -> IO Bool
+threadsWrite c bs = atomically $
+    orElse (const False `fmap` threadsWait c)
+           (const True  `fmap` putTMVar (threadsWriter c) (Just bs))
+
+-- | 'threadsClose' signals for the 'ConnectionThreads' object
+-- to quit and close the associated 'Handle'.  This operation
+-- is non-blocking, follow it with 'threadsWait' if you want
+-- to wait for the operation to complete.
+threadsClose :: ConnectionThreads -> STM ()
+threadsClose c = do
+    let mvar = threadsWriter c
+    v <- tryReadTMVar mvar
+    case v of
+        Just Nothing -> return () -- already closed
+        _            -> putTMVar mvar Nothing
+
+-- | 'threadsRead' blocks until a 'ByteString' is available which
+-- is returned to the caller, or the connection is interrupted and
+-- 'Nothing' is returned.
+threadsRead :: ConnectionThreads -> IO (Maybe ByteString)
+threadsRead c = atomically $
+    orElse (const Nothing `fmap` threadsWait c)
+           (Just          `fmap` readTChan (threadsChannel c))
+
+-- | A 'ConnectionState' is an interface to a single 'ConnectionThreads'
+-- or to a pair of 'ConnectionThreads' objects that are considered as one
+-- connection.
+data ConnectionState =
+        SaneConnection ConnectionThreads
+        -- ^ ordinary read/write connection
+        | WriteOnlyConnection ConnectionThreads
+        | ReadOnlyConnection ConnectionThreads
+        | ConnectionPair ConnectionThreads ConnectionThreads
+        -- ^ Two 'ConnectionThreads' objects, read operations use the
+        -- first, write operations use the second.
+
+
+
+connWrite :: ConnectionState -> ByteString -> IO Bool
+connWrite (ReadOnlyConnection _) bs = return False
+connWrite conn bs = threadsWrite c bs
+ where
+    c = case conn of SaneConnection c      -> c
+                     WriteOnlyConnection c -> c
+                     ConnectionPair _ c    -> c
+
+
+mapConn :: Bool ->
+            (ConnectionThreads -> STM ()) -> ConnectionState -> STM ()
+mapConn both action c =
+    case c of
+        SaneConnection rw     -> action rw
+        ReadOnlyConnection r  -> action r
+        WriteOnlyConnection w -> action w
+        ConnectionPair r w -> do
+            rem <- orElse (const w `fmap` action r)
+                          (const r `fmap` action w)
+            when both $ action rem
+
+connClose :: ConnectionState -> STM ()
+connClose c = mapConn True threadsClose c
+
+connWait :: ConnectionState -> STM ()
+connWait c = doit -- mapConn False threadsWait c
+ where
+    action = threadsWait
+    doit =
+      case c of
+        SaneConnection rw     -> action rw
+        ReadOnlyConnection r  -> action r
+        WriteOnlyConnection w -> action w
+        ConnectionPair r w -> do
+            rem <- orElse (const w `fmap` action r)
+                          (const r `fmap` action w)
+            threadsClose rem
+
+connPingTimer :: ConnectionState -> PingMachine
+connPingTimer c =
+    case c of
+        SaneConnection rw     -> threadsPing rw
+        ReadOnlyConnection r  -> threadsPing r
+        WriteOnlyConnection w -> threadsPing w -- should be disabled.
+        ConnectionPair r w    -> threadsPing r
+
+connCancelPing :: ConnectionState -> IO ()
+connCancelPing c = pingCancel (connPingTimer c)
+
+connWaitPing :: ConnectionState -> STM PingEvent
+connWaitPing c = pingWait (connPingTimer c)
+
+connFlush :: ConnectionState -> STM ()
+connFlush c =
+    case c of
+        SaneConnection rw     -> waitChan rw
+        ReadOnlyConnection r  -> waitChan r
+        WriteOnlyConnection w -> return ()
+        ConnectionPair r w    -> waitChan r
+  where
+    waitChan t = do
+        b <- isEmptyTChan (threadsChannel t)
+        when (not b) retry
+
+bshow :: Show a => a -> ByteString
+bshow e = S.pack . show $ e
+
+warn :: ByteString -> IO ()
+warn str =dputB XMisc str
+
+debugNoise :: Monad m => t -> m ()
+debugNoise str = return ()
+
+data TCPStatus = Resolving | AwaitingRead | AwaitingWrite
+
+-- SockAddr -> (SockAddr, ConnectionParameters SockAddr ConnectionData, Miliseconds)
+
+
+tcpManager :: (PeerAddress -> (SockAddr, ConnectionParameters PeerAddress u, Miliseconds))
+              -- -> (String -> Maybe Text)
+              -- -> (Text -> IO (Maybe PeerAddress))
+              -> Server PeerAddress u releaseKey x
+              -> IO (Manager TCPStatus Text)
+tcpManager grokKey sv = do
+    rmap <- atomically $ newTVar Map.empty -- Map k (Maybe conkey)
+    nullping <- forkPingMachine "tcpManager" 0 0
+    (rslv,rev) <- do
+        dns <- newDNSCache
+        let rslv k = map PeerAddress <$> forwardResolve dns k
+            rev (PeerAddress addr) = reverseResolve dns addr
+        return (rslv,rev)
+    return Manager {
+      setPolicy = \k -> \case
+        TryingToConnect -> join $ atomically $ do
+            r <- readTVar rmap
+            case Map.lookup k r of
+                Just {} -> return $ return () -- Connection already in progress.
+                Nothing -> do
+                    modifyTVar' rmap $ Map.insert k Nothing
+                    return $ void $ forkLabeled ("resolve."++show k) $ do
+                    mconkey <- listToMaybe <$> rslv k
+                    case mconkey of
+                        Nothing     -> atomically $ modifyTVar' rmap $ Map.delete k
+                        Just conkey -> do
+                            control sv $ case grokKey conkey of
+                                    (saddr,params,ms) -> ConnectWithEndlessRetry saddr params ms
+        OpenToConnect     -> dput XMisc "TODO: TCP OpenToConnect"
+        RefusingToConnect -> dput XMisc "TODO: TCP RefusingToConnect"
+    , status = \k -> do
+        c <- readTVar (conmap sv)
+        ck <- Map.lookup k <$> readTVar rmap
+        return $ exportConnection c (join ck)
+    , connections = Map.keys <$> readTVar rmap
+    , stringToKey = Just . Text.pack
+    , showProgress = \case
+        Resolving     -> "resolving"
+        AwaitingRead  -> "awaiting inbound"
+        AwaitingWrite -> "awaiting outbound"
+    , showKey = show
+    , resolvePeer    = rslv
+    , reverseAddress = rev
+    }
+
+exportConnection :: Ord conkey => Map conkey (ConnectionRecord u) -> Maybe conkey -> G.Connection TCPStatus
+exportConnection conmap mkey = G.Connection
+    { G.connStatus    = case mkey of
+        Nothing     -> G.Dormant
+        Just conkey -> case Map.lookup conkey conmap of
+            Nothing                                    -> G.InProgress Resolving
+            Just (ConnectionRecord ckont cstate cdata) -> case cstate of
+                SaneConnection      {} -> G.Established
+                ConnectionPair      {} -> G.Established
+                ReadOnlyConnection  {} -> G.InProgress AwaitingWrite
+                WriteOnlyConnection {} -> G.InProgress AwaitingRead
+    , G.connPolicy    = TryingToConnect
+    }
diff --git a/server/src/Control/Concurrent/Delay.hs b/server/src/Control/Concurrent/Delay.hs
new file mode 100644
index 00000000..5cc1f99a
--- /dev/null
+++ b/server/src/Control/Concurrent/Delay.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+module Control.Concurrent.Delay where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Exception ({-evaluate,-}handle,finally,throwIO)
+import Data.Time.Clock (NominalDiffTime)
+import System.IO.Error
+
+type Microseconds = Int
+
+microseconds :: NominalDiffTime -> Microseconds
+microseconds d = round $ 1000000 * d
+
+data InterruptibleDelay = InterruptibleDelay
+        { delayThread :: MVar ThreadId
+        }
+
+interruptibleDelay :: IO InterruptibleDelay
+interruptibleDelay = do
+    fmap InterruptibleDelay newEmptyMVar
+
+-- | Delay for the given number of microseconds and return 'True' if the delay
+-- is not interrupted.
+--
+-- Note: If a thread is already waiting on the given 'InterruptibleDelay'
+-- object, then this will block until it becomes available and only then start
+-- the delay timer.
+startDelay :: InterruptibleDelay -> Microseconds -> IO Bool
+startDelay d interval = do
+    thread <- myThreadId
+    handle (\e -> do when (not $ isUserError e) (throwIO e)
+                     return False) $ do
+        putMVar (delayThread d) thread
+        threadDelay interval
+        void $ takeMVar (delayThread d)
+        return True
+     -- The following cleanup shouldn't be necessary, but I'm paranoid.
+     `finally` tryTakeMVar (delayThread d)
+
+  where debugNoise str = return ()
+
+-- | Signal the thread waiting on the given 'InterruptibleDelay' object to
+-- continue even though the timeout has not elapsed. If no thread is waiting,
+-- then this is a no-op.
+interruptDelay :: InterruptibleDelay -> IO ()
+interruptDelay d = do
+    mthread <- tryTakeMVar (delayThread d)
+    forM_ mthread $ \thread -> do
+    throwTo thread (userError "Interrupted delay")
diff --git a/server/src/Control/Concurrent/PingMachine.hs b/server/src/Control/Concurrent/PingMachine.hs
new file mode 100644
index 00000000..5de0e2e5
--- /dev/null
+++ b/server/src/Control/Concurrent/PingMachine.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TupleSections            #-}
+module Control.Concurrent.PingMachine where
+
+import Control.Monad
+import Data.Function
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent        (forkIO)
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Concurrent.STM
+
+import Control.Concurrent.Delay
+
+type Miliseconds = Int
+type TimeOut = Miliseconds
+type PingInterval = Miliseconds
+
+-- | Events that occur as a result of the 'PingMachine' watchdog.
+--
+-- Use 'pingWait' to wait for one of these to occur.
+data PingEvent
+    = PingIdle    -- ^ You should send a ping if you observe this event.
+    | PingTimeOut -- ^ You should give up on the connection in case of this event.
+
+data PingMachine = PingMachine
+    { pingFlag          :: TVar Bool
+    , pingInterruptible :: InterruptibleDelay
+    , pingEvent         :: TMVar PingEvent
+    , pingStarted       :: TMVar Bool
+    }
+
+-- | Fork a thread to monitor a connection for a ping timeout.
+--
+-- If 'pingBump' is not invoked after a idle is signaled, a timeout event will
+-- occur.  When that happens, even if the caller chooses to ignore this event,
+-- the watchdog thread will be terminated and no more ping events will be
+-- signaled.
+--
+-- An idle connection will be signaled by:
+--
+--   (1) 'pingFlag' is set 'True'
+--
+--   (2) 'pingWait' returns 'PingIdle'
+--
+-- Either may be tested to determine whether a ping should be sent but
+-- 'pingFlag' is difficult to use properly because it is up to the caller to
+-- remember that the ping is already in progress.
+forkPingMachine
+    :: String
+    -> PingInterval -- ^ Milliseconds of idle before a ping is considered necessary.
+    -> TimeOut      -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'.
+    -> IO PingMachine
+forkPingMachine label idle timeout = do
+    d <- interruptibleDelay
+    flag <- atomically $ newTVar False
+    canceled <- atomically $ newTVar False
+    event <- atomically newEmptyTMVar
+    started <- atomically $ newEmptyTMVar
+    when (idle/=0) $ void . forkIO $ do
+        myThreadId >>= flip labelThread ("Ping." ++ label) -- ("ping.watchdog")
+        (>>=) (atomically (readTMVar started)) $ flip when $ do
+        fix $ \loop -> do
+            atomically $ writeTVar flag False
+            fin <- startDelay d (1000*idle)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            if (not fin) then loop
+            else do
+            -- Idle event
+            atomically $ do
+                tryTakeTMVar event
+                putTMVar event PingIdle
+                writeTVar flag True
+            fin <- startDelay d (1000*timeout)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            me <- myThreadId
+            if (not fin) then loop
+            else do
+            -- Timeout event
+            atomically $ do
+                tryTakeTMVar event
+                writeTVar flag False
+                putTMVar event PingTimeOut
+    return PingMachine
+        { pingFlag          = flag
+        , pingInterruptible = d
+        , pingEvent         = event
+        , pingStarted       = started
+        }
+
+-- | like 'forkPingMachine'  but the timeout and idle parameters can be changed dynamically
+--  Unlike 'forkPingMachine', 'forkPingMachineDynamic' always launches a thread
+--  regardless of idle value.
+forkPingMachineDynamic
+    :: String
+    -> TVar PingInterval -- ^ Milliseconds of idle before a ping is considered necessary.
+    -> TVar TimeOut      -- ^ Milliseconds after 'PingIdle' before we signal 'PingTimeOut'.
+    -> IO PingMachine
+forkPingMachineDynamic label idleV timeoutV = do
+    d <- interruptibleDelay
+    flag <- atomically $ newTVar False
+    canceled <- atomically $ newTVar False
+    event <- atomically newEmptyTMVar
+    started <- atomically $ newEmptyTMVar
+    void . forkIO $ do
+        myThreadId >>= flip labelThread ("Ping." ++ label) -- ("ping.watchdog")
+        (>>=) (atomically (readTMVar started)) $ flip when $ do
+        fix $ \loop -> do
+            atomically $ writeTVar flag False
+            (idle,timeout) <- atomically $ (,) <$> readTVar idleV <*> readTVar timeoutV
+            fin <- startDelay d (1000*idle)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            if (not fin) then loop
+            else do
+            -- Idle event
+            atomically $ do
+                tryTakeTMVar event
+                putTMVar event PingIdle
+                writeTVar flag True
+            fin <- startDelay d (1000*timeout)
+            (>>=) (atomically (readTMVar started)) $ flip when $ do
+            me <- myThreadId
+            if (not fin) then loop
+            else do
+            -- Timeout event
+            atomically $ do
+                tryTakeTMVar event
+                writeTVar flag False
+                putTMVar event PingTimeOut
+    return PingMachine
+        { pingFlag          = flag
+        , pingInterruptible = d
+        , pingEvent         = event
+        , pingStarted       = started
+        }
+
+-- | Terminate the watchdog thread.  Call this upon connection close.
+--
+-- You should ensure no threads are waiting on 'pingWait' because there is no
+-- 'PingEvent' signaling termination.
+pingCancel :: PingMachine -> IO ()
+pingCancel me = do
+    atomically $ do tryTakeTMVar (pingStarted me)
+                    putTMVar (pingStarted me) False
+    interruptDelay (pingInterruptible me)
+
+-- | Reset the ping timer.  Call this regularly to prevent 'PingTimeOut'.
+pingBump :: PingMachine -> IO ()
+pingBump me = do
+    atomically $ do
+            b <- tryReadTMVar (pingStarted me)
+            when (b/=Just False) $ do
+                tryTakeTMVar (pingStarted me)
+                putTMVar (pingStarted me) True
+    interruptDelay (pingInterruptible me)
+
+-- | Retries until a 'PingEvent' occurs.
+pingWait :: PingMachine -> STM PingEvent
+pingWait me = takeTMVar (pingEvent me)
diff --git a/server/src/ControlMaybe.hs b/server/src/ControlMaybe.hs
new file mode 100644
index 00000000..a101d667
--- /dev/null
+++ b/server/src/ControlMaybe.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module ControlMaybe
+   ( module ControlMaybe
+   , module Data.Functor
+   ) where
+
+-- import GHC.IO.Exception (IOException(..))
+import Control.Monad
+import Data.Functor
+import System.IO.Error
+
+
+-- forM_ with less polymorphism.
+withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
+withJust m f = forM_ m f
+{-# INLINE withJust #-}
+
+whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
+whenJust acn f = acn >>= mapM_ f
+{-# INLINE whenJust #-}
+
+
+catchIO_ :: IO a -> IO a -> IO a
+catchIO_ body catcher = catchIOError body (\_ -> catcher)
+{-# INLINE catchIO_ #-}
+
+handleIO_ :: IO a -> IO a -> IO a
+handleIO_ catcher body = catchIOError body (\_ -> catcher)
+{-# INLINE handleIO_ #-}
+
+
+handleIO :: (IOError -> IO a) -> IO a -> IO a
+handleIO catcher body = catchIOError body catcher
+{-# INLINE handleIO #-}
+
+#if !MIN_VERSION_base(4,11,0)
+-- | Flipped version of '<$>'.
+--
+-- @
+-- ('<&>') = 'flip' 'fmap'
+-- @
+--
+-- @since 4.11.0.0
+--
+-- ==== __Examples__
+-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':
+--
+-- >>> Just 2 <&> (+1)
+-- Just 3
+--
+-- >>> [1,2,3] <&> (+1)
+-- [2,3,4]
+--
+-- >>> Right 3 <&> (+1)
+-- Right 4
+--
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+as <&> f = f <$> as
+
+infixl 1 <&>
+#endif
+
+
diff --git a/server/src/DNSCache.hs b/server/src/DNSCache.hs
new file mode 100644
index 00000000..f539c71f
--- /dev/null
+++ b/server/src/DNSCache.hs
@@ -0,0 +1,286 @@
+-- | Both 'getAddrInfo' and 'getHostByAddr' have hard-coded timeouts for
+-- waiting upon network queries that can be a little too long for some use
+-- cases. This module wraps both of them so that they block for at most one
+-- second.  It caches late-arriving results so that they can be returned by
+-- repeated timed-out queries.
+--
+-- In order to achieve the shorter timeout, it is likely that the you will need
+-- to build with GHC's -threaded option.  Otherwise, if the wrapped FFI calls
+-- to resolve the address will block Haskell threads.  Note: I didn't verify
+-- this.
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE TupleSections            #-}
+module DNSCache
+    ( DNSCache
+    , reverseResolve
+    , forwardResolve
+    , newDNSCache
+    , parseAddress
+    , unsafeParseAddress
+    , strip_brackets
+    , withPort
+    ) where
+
+import Control.Concurrent.ThreadUtil
+import Control.Arrow
+import Control.Concurrent.STM
+import Data.Text       ( Text )
+import Network.Socket  ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
+import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime )
+import System.IO.Error ( isDoesNotExistError )
+import System.Endian   ( fromBE32, toBE32 )
+import Control.Exception ( handle )
+import Data.Map        ( Map )
+import qualified Data.Map    as Map
+import qualified Network.BSD as BSD
+import qualified Data.Text   as Text
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Ord
+import Data.Maybe
+import System.IO.Error
+import System.IO.Unsafe
+
+import SockAddr      ()
+import ControlMaybe  ( handleIO_ )
+import GetHostByAddr ( getHostByAddr )
+import Control.Concurrent.Delay
+import DPut
+import DebugTag
+
+type TimeStamp = UTCTime
+
+data DNSCache =
+    DNSCache
+    { fcache :: TVar (Map Text [(TimeStamp, SockAddr)])
+    , rcache :: TVar (Map SockAddr [(TimeStamp, Text)])
+    }
+
+
+newDNSCache :: IO DNSCache
+newDNSCache = do
+        fcache <- newTVarIO Map.empty
+        rcache <- newTVarIO Map.empty
+        return DNSCache { fcache=fcache, rcache=rcache }
+
+updateCache :: Eq x =>
+    Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)]
+updateCache withScrub utc xs mys = do
+    let ys = maybe [] id mys
+        ys' = filter scrub ys
+        ys'' = map (utc,) xs ++ ys'
+        minute = 60
+        scrub (t,x) | withScrub && diffUTCTime utc t < minute = False
+        scrub (t,x) | x `elem` xs = False
+        scrub _ = True
+    guard $ not (null ys'')
+    return ys''
+
+dnsObserve :: DNSCache -> Bool -> TimeStamp -> [(Text,SockAddr)] -> STM ()
+dnsObserve dns withScrub utc obs = do
+    f <- readTVar $ fcache dns
+    r <- readTVar $ rcache dns
+    let obs' = map (\(n,a)->(n,a `withPort` 0)) obs
+        gs = do
+            g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs'
+            (n,_) <- take 1 g
+            return (n,map snd g)
+        f' = foldl' updatef f gs
+        hs = do
+            h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs'
+            (_,a) <- take 1 h
+            return (a,map fst h)
+        r' = foldl' updater r hs
+    writeTVar (fcache dns) f'
+    writeTVar (rcache dns) r'
+ where
+    updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
+    updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
+
+make6mapped4 :: SockAddr -> SockAddr
+make6mapped4 addr@(SockAddrInet6 {}) = addr
+make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
+
+tryForkOS :: String -> IO () -> IO ThreadId
+tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do
+    dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
+    forkLabeled lbl action
+
+
+-- Attempt to resolve the given domain name.  Returns an empty list if the
+-- resolve operation takes longer than the timeout, but the 'DNSCache' will be
+-- updated when the resolve completes.
+--
+-- When the resolve operation does complete, any entries less than a minute old
+-- will be overwritten with the new results.  Older entries are allowed to
+-- persist for reasons I don't understand as of this writing. (See 'updateCache')
+rawForwardResolve ::
+    DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
+rawForwardResolve dns onFail timeout addrtext = do
+    r <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
+    rt <- tryForkOS ("resolve."++show addrtext) $ do
+        resolver r mvar
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addrtext)
+    atomically $ readTMVar r
+ where
+    resolver r mvar = do
+      xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
+            $ do fmap (nub . map (make6mapped4 . addrAddress)) $ 
+                  getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
+                    (Just $ Text.unpack $ strip_brackets addrtext)
+                    (Just "5269")
+      did <- atomically $ tryPutTMVar r xs
+      when did $ do
+      interruptDelay mvar
+      utc <- getCurrentTime
+      atomically $ dnsObserve dns True utc $ map (addrtext,) xs
+      return ()
+
+strip_brackets :: Text -> Text
+strip_brackets s =
+      case Text.uncons s of
+          Just ('[',t) -> Text.takeWhile (/=']') t
+          _            -> s
+
+
+reportTimeout :: forall a. Show a => a -> IO ()
+reportTimeout addrtext = do
+      dput XMisc $ "timeout resolving: "++show addrtext
+      -- killThread rt
+
+unmap6mapped4 :: SockAddr -> SockAddr
+unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
+    SockAddrInet port (toBE32 a)
+unmap6mapped4 addr = addr
+
+rawReverseResolve ::
+    DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
+rawReverseResolve dns onFail timeout addr = do
+    r <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
+    rt <- forkOS $ resolver r mvar
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addr)
+    atomically $ readTMVar r
+ where
+    resolver r mvar = 
+      handleIO_ (return ()) $ do
+        ent <- getHostByAddr (unmap6mapped4 addr) --  AF_UNSPEC addr
+        let names = BSD.hostName ent : BSD.hostAliases ent
+            xs = map Text.pack $ nub names
+        forkIO $ do
+            utc <- getCurrentTime
+            atomically $ dnsObserve dns False utc $ map (,addr) xs
+        atomically $ putTMVar r  xs
+
+-- Returns expired (older than a minute) cached reverse-dns results
+-- and removes them from the cache.
+expiredReverse :: DNSCache -> SockAddr -> IO [Text]
+expiredReverse dns addr = do
+    utc <- getCurrentTime
+    addr <- return $ addr `withPort` 0
+    es <- atomically $ do
+        r <- readTVar $ rcache dns
+        let ns = maybe [] id $ Map.lookup addr r
+            minute = 60 -- seconds
+            -- XXX: Is this right?  flip diffUTCTime utc returns the age of the 
+            -- cache entry?
+            (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns
+            es = map snd es0
+        modifyTVar' (rcache dns) $ Map.insert addr ns'
+        f <- readTVar $ fcache dns
+        let f' = foldl' (flip $ Map.alter (expire utc)) f es
+            expire utc Nothing   = Nothing
+            expire utc (Just as) = if null as' then Nothing else Just as'
+                where as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
+        writeTVar (fcache dns) f'
+        return es
+    return es
+
+cachedReverse :: DNSCache -> SockAddr -> IO [Text]
+cachedReverse dns addr = do
+    utc <- getCurrentTime
+    addr <- return $ addr `withPort` 0
+    atomically $ do
+        r <- readTVar (rcache dns)
+        let ns = maybe [] id $ Map.lookup addr r
+        {-
+            ns' = filter ( (<minute) . flip diffUTCTime utc . fst) ns
+            minute = 60 -- seconds
+        modifyTVar' (rcache dns) $ Map.insert addr ns'
+        return $ map snd ns'
+        -}
+        return $ map snd ns
+
+-- Returns any dns query results for the given name that were observed less
+-- than a minute ago and updates the forward-cache to remove any results older
+-- than that.
+cachedForward :: DNSCache -> Text -> IO [SockAddr]
+cachedForward dns n = do
+    utc <- getCurrentTime
+    atomically $ do
+        f <- readTVar (fcache dns)
+        let as = maybe [] id $ Map.lookup n f
+            as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
+            minute = 60 -- seconds
+        modifyTVar' (fcache dns) $ Map.insert n as'
+        return $ map snd as'
+
+-- Reverse-resolves an address to a domain name.  Returns both the result of a
+-- new query and any freshly cached results.  Cache entries older than a minute
+-- will not be returned, but will be refreshed in spawned threads so that they
+-- may be available for the next call.
+reverseResolve :: DNSCache -> SockAddr -> IO [Text]
+reverseResolve dns addr = do
+    expired <- expiredReverse dns addr
+    forM_ expired $ \n -> forkIO $ do
+        rawForwardResolve dns (const $ return ()) 1000000 n
+        return ()
+    xs <- rawReverseResolve dns (const $ return ()) 1000000 addr
+    cs <- cachedReverse dns addr
+    return $ xs ++ filter (not . flip elem xs) cs
+
+-- Resolves a name, if there's no result within one second, then any cached
+-- results that are less than a minute old are returned.
+forwardResolve :: DNSCache -> Text -> IO [SockAddr]
+forwardResolve dns n = do
+    as <- rawForwardResolve dns (const $ return ()) 1000000 n
+    if null as
+      then cachedForward dns n
+      else return as
+
+parseAddress :: Text -> IO (Maybe SockAddr)
+parseAddress addr_str = do
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) 
+                        (Just . Text.unpack $ addr_str) 
+                        (Just "0")
+    return . listToMaybe $ map addrAddress info
+
+
+splitAtPort :: String -> (String,String)
+splitAtPort s = second sanitizePort $ case s of
+    ('[':t) -> break (==']') t
+    _       -> break (==':') s
+ where
+    sanitizePort (']':':':p) = p
+    sanitizePort (':':p)     = p
+    sanitizePort _           = "0"
+
+unsafeParseAddress :: String -> Maybe SockAddr
+unsafeParseAddress addr_str = unsafePerformIO $ do
+    let (ipstr,portstr) = splitAtPort addr_str
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
+                        (Just ipstr)
+                        (Just portstr)
+    return . listToMaybe $ map addrAddress info
+
+withPort :: SockAddr -> Int -> SockAddr
+withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
+withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
diff --git a/server/src/Data/TableMethods.hs b/server/src/Data/TableMethods.hs
new file mode 100644
index 00000000..e4208a69
--- /dev/null
+++ b/server/src/Data/TableMethods.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+module Data.TableMethods where
+
+import Data.Functor.Contravariant
+import Data.Time.Clock.POSIX
+import Data.Word
+import qualified Data.IntMap.Strict as IntMap
+         ;import Data.IntMap.Strict (IntMap)
+import qualified Data.Map.Strict    as Map
+         ;import Data.Map.Strict    (Map)
+import qualified Data.Word64Map     as W64Map
+         ;import Data.Word64Map     (Word64Map)
+
+import Data.Wrapper.PSQ as PSQ
+
+type Priority = POSIXTime
+
+data OptionalPriority t tid x
+    = NoPriority
+    | HasPriority (Priority -> t x -> ([(tid, Priority, x)], t x))
+
+-- | The standard lookup table methods.
+data TableMethods t tid = TableMethods
+    { -- | Insert a new /tid/ entry into the transaction table.
+      tblInsert :: forall a. tid -> a -> Priority -> t a -> t a
+      -- | Delete transaction /tid/ from the transaction table.
+    , tblDelete :: forall a. tid -> t a -> t a
+       -- | Lookup the value associated with transaction /tid/.
+    , tblLookup :: forall a. tid -> t a -> Maybe a
+    }
+
+data QMethods t tid x = QMethods
+    { qTbl           :: TableMethods t tid
+    , qAtMostView    :: OptionalPriority t tid x
+    }
+
+vanillaTable :: TableMethods t tid -> QMethods t tid x
+vanillaTable tbl = QMethods tbl NoPriority
+
+priorityTable :: TableMethods t tid
+                 -> (Priority -> t x -> ([(k, Priority, x)], t x))
+                 -> (k -> x -> tid)
+                 -> QMethods t tid x
+priorityTable tbl atmost f = QMethods
+    { qTbl        = tbl
+    , qAtMostView = HasPriority $ \p t -> case atmost p t of
+        (es,t') -> (map (\(k,p,a) -> (f k a, p, a)) es, t')
+    }
+
+-- | Methods for using 'Data.IntMap'.
+intMapMethods :: TableMethods IntMap Int
+intMapMethods = TableMethods
+    { tblInsert     = \tid a p -> IntMap.insert tid a
+    , tblDelete     = IntMap.delete
+    , tblLookup     = IntMap.lookup
+    }
+
+-- | Methods for using 'Data.Word64Map'.
+w64MapMethods :: TableMethods Word64Map Word64
+w64MapMethods = TableMethods
+    { tblInsert     = \tid a p -> W64Map.insert tid a
+    , tblDelete     = W64Map.delete
+    , tblLookup     = W64Map.lookup
+    }
+
+-- | Methods for using 'Data.Map'
+mapMethods :: Ord tid => TableMethods (Map tid) tid
+mapMethods = TableMethods
+    { tblInsert     = \tid a p -> Map.insert tid a
+    , tblDelete     = Map.delete
+    , tblLookup     = Map.lookup
+    }
+
+-- psqMethods :: PSQKey tid => QMethods (HashPSQ tid Priority) tid x
+psqMethods :: PSQKey k => (tid -> k) -> (k -> x -> tid) -> QMethods (PSQ' k Priority) tid x
+psqMethods g f = priorityTable (contramap g tbl) PSQ.atMostView f
+ where
+    tbl :: PSQKey tid => TableMethods (PSQ' tid Priority) tid
+    tbl = TableMethods
+        { tblInsert = PSQ.insert'
+        , tblDelete = PSQ.delete
+        , tblLookup = \tid t -> case PSQ.lookup tid t of
+            Just (p,a) -> Just a
+            Nothing    -> Nothing
+        }
+
+
+-- | Change the key type for a lookup table implementation.
+--
+-- This can be used with 'intMapMethods' or 'mapMethods' to restrict lookups to
+-- only a part of the generated /tid/ value.  This is useful for /tid/ types
+-- that are especially large due their use for other purposes, such as secure
+-- nonces for encryption.
+instance Contravariant (TableMethods t) where
+    -- contramap :: (tid -> t1) -> TableMethods t t1 -> TableMethods t tid
+    contramap f (TableMethods ins del lookup) =
+        TableMethods (\k p v t -> ins (f k) p v t)
+                     (\k t     -> del (f k) t)
+                     (\k t     -> lookup (f k) t)
diff --git a/server/src/DebugTag.hs b/server/src/DebugTag.hs
new file mode 100644
index 00000000..9ac04bb0
--- /dev/null
+++ b/server/src/DebugTag.hs
@@ -0,0 +1,24 @@
+module DebugTag where
+
+import Data.Typeable
+
+-- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
+data DebugTag
+  = XAnnounce
+  | XBitTorrent
+  | XDHT
+  | XLan
+  | XMan
+  | XNetCrypto
+  | XNetCryptoOut
+  | XOnion
+  | XRoutes
+  | XPing
+  | XRefresh
+  | XJabber
+  | XTCP
+  | XMisc
+  | XNodeinfoSearch
+  | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen.
+  | XUnused     -- Never commit code that uses XUnused.
+  deriving (Eq, Ord, Show, Read, Enum, Bounded,Typeable)
diff --git a/server/src/ForkLabeled.hs b/server/src/ForkLabeled.hs
new file mode 100644
index 00000000..50b5d76c
--- /dev/null
+++ b/server/src/ForkLabeled.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+module ForkLabeled where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread,forkIO)
+#endif
+
+forkLabeled :: String -> IO () -> IO ThreadId
+forkLabeled s io = do
+    t <- forkIO io
+    labelThread t s
+    return t
+
diff --git a/server/src/GetHostByAddr.hs b/server/src/GetHostByAddr.hs
new file mode 100644
index 00000000..068fc93d
--- /dev/null
+++ b/server/src/GetHostByAddr.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+module GetHostByAddr where
+
+import Network.BSD
+import Foreign.Ptr
+import Foreign.C.Types
+import Foreign.Storable (Storable(..))
+import Foreign.Marshal.Utils (with)
+import Foreign.Marshal.Alloc
+import Control.Concurrent
+import System.IO.Unsafe
+import System.IO.Error (ioeSetErrorString, mkIOError)
+import Network.Socket
+import GHC.IO.Exception
+
+
+throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a)
+throwNoSuchThingIfNull loc desc act = do
+  ptr <- act
+  if (ptr == nullPtr)
+       then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc)
+       else return ptr
+
+{-# NOINLINE lock #-}
+lock :: MVar ()
+lock = unsafePerformIO $ newMVar ()
+
+withLock :: IO a -> IO a
+withLock act = withMVar lock (\_ -> act)
+
+trySysCall :: IO a -> IO a
+trySysCall act = act
+
+{-
+-- The locking of gethostbyaddr is similar to gethostbyname.
+-- | Get a 'HostEntry' corresponding to the given address and family.
+-- Note that only IPv4 is currently supported.
+getHostByAddr :: Family -> SockAddr -> IO HostEntry
+getHostByAddr family addr = do
+ withSockAddr addr $ \ ptr_addr len -> withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral len) (packFamily family)
+ >>= peek
+-}
+
+
+-- The locking of gethostbyaddr is similar to gethostbyname.
+-- | Get a 'HostEntry' corresponding to the given address and family.
+-- Note that only IPv4 is currently supported.
+-- getHostByAddr :: Family -> HostAddress -> IO HostEntry
+-- getHostByAddr family addr = do
+getHostByAddr :: SockAddr -> IO HostEntry
+getHostByAddr (SockAddrInet port addr ) = do
+ let family = AF_INET
+ with addr $ \ ptr_addr -> withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family)
+ >>= peek
+getHostByAddr (SockAddrInet6 port flow (a,b,c,d) scope) = do
+ let family = AF_INET6
+ allocaBytes 16 $ \ ptr_addr -> do
+ pokeElemOff ptr_addr 0 a
+ pokeElemOff ptr_addr 1 b
+ pokeElemOff ptr_addr 2 c
+ pokeElemOff ptr_addr 3 d
+ withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr 16 (packFamily family)
+ >>= peek
+
+
+foreign import ccall safe "gethostbyaddr"
+   c_gethostbyaddr :: Ptr a -> CInt -> CInt -> IO (Ptr HostEntry)
+
+
+
+-- vim:ft=haskell:
diff --git a/server/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs
new file mode 100644
index 00000000..20e7ecf0
--- /dev/null
+++ b/server/src/Network/QueryResponse.hs
@@ -0,0 +1,716 @@
+-- | This module can implement any query\/response protocol.  It was written
+-- with Kademlia implementations in mind.
+
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+module Network.QueryResponse where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent
+import GHC.Conc           (labelThread)
+#endif
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString    as B
+         ;import Data.ByteString    (ByteString)
+import Data.Dependent.Map as DMap
+import Data.Dependent.Sum
+import Data.Function
+import Data.Functor.Contravariant
+import Data.Functor.Identity
+import Data.GADT.Show
+import qualified Data.IntMap.Strict as IntMap
+         ;import Data.IntMap.Strict (IntMap)
+import qualified Data.Map.Strict    as Map
+         ;import Data.Map.Strict    (Map)
+import Data.Time.Clock.POSIX
+import qualified Data.Word64Map     as W64Map
+         ;import Data.Word64Map     (Word64Map)
+import Data.Word
+import Data.Maybe
+import GHC.Conc (closeFdWith)
+import GHC.Event
+import Network.Socket
+import Network.Socket.ByteString    as B
+import System.Endian
+import System.IO
+import System.IO.Error
+import System.Timeout
+
+import DPut
+import DebugTag
+import Data.TableMethods
+
+-- | An inbound packet or condition raised while monitoring a connection.
+data Arrival err addr x
+    = Terminated       -- ^ Virtual message that signals EOF.
+    | ParseError !err  -- ^ A badly-formed message was received.
+    | Arrival { arrivedFrom :: !addr , arrivedMsg  :: !x } -- ^ Inbound message.
+
+-- | Three methods are required to implement a datagram based query\/response protocol.
+data TransportA err addr x y = Transport
+    { -- | Blocks until an inbound packet is available. Then calls the provided
+      -- continuation with the packet and origin addres or an error condition.
+      awaitMessage :: forall a. (Arrival err addr x -> IO a) -> STM (IO a)
+      -- | Send an /y/ packet to the given destination /addr/.
+    , sendMessage :: addr -> y -> IO ()
+      -- | Shutdown and clean up any state related to this 'Transport'.
+    , setActive :: Bool -> IO ()
+    }
+
+type Transport err addr x = TransportA err addr x x
+
+closeTransport :: TransportA err addr x y -> IO ()
+closeTransport tr = setActive tr False
+
+-- | This function modifies a 'Transport' to use higher-level addresses and
+-- packet representations.  It could be used to change UDP 'ByteString's into
+-- bencoded syntax trees or to add an encryption layer in which addresses have
+-- associated public keys.
+layerTransportM ::
+        (x -> addr -> IO (Either err (x', addr')))
+        -- ^ Function that attempts to transform a low-level address/packet
+        -- pair into a higher level representation.
+        -> (y' -> addr' -> IO (y, addr))
+        -- ^ Function to encode a high-level address/packet into a lower level
+        -- representation.
+        -> TransportA err addr x y
+        -- ^ The low-level transport to be transformed.
+        -> TransportA err addr' x' y'
+layerTransportM parse encode tr =
+    tr { awaitMessage = \kont ->
+                awaitMessage tr $ \case
+                    Terminated     -> kont $ Terminated
+                    ParseError e   -> kont $ ParseError e
+                    Arrival addr x -> parse x addr >>= \case
+                        Left e           -> kont $ ParseError e
+                        Right (x',addr') -> kont $ Arrival addr' x'
+       , sendMessage = \addr' msg' -> do
+                (msg,addr) <- encode msg' addr'
+                sendMessage tr addr msg
+       }
+
+
+-- | This function modifies a 'Transport' to use higher-level addresses and
+-- packet representations.  It could be used to change UDP 'ByteString's into
+-- bencoded syntax trees or to add an encryption layer in which addresses have
+-- associated public keys.
+layerTransport ::
+        (x -> addr -> Either err (x', addr'))
+        -- ^ Function that attempts to transform a low-level address/packet
+        -- pair into a higher level representation.
+        -> (y' -> addr' -> (y, addr))
+        -- ^ Function to encode a high-level address/packet into a lower level
+        -- representation.
+        -> TransportA err addr x y
+        -- ^ The low-level transport to be transformed.
+        -> TransportA err addr' x' y'
+layerTransport parse encode tr =
+    layerTransportM (\x addr -> return $ parse x addr)
+                    (\x' addr' -> return $ encode x' addr')
+                    tr
+
+-- | Paritions a 'Transport' into two higher-level transports.  Note: A 'TChan'
+-- is used to share the same underlying socket, so be sure to fork a thread for
+-- both returned 'Transport's to avoid hanging.
+partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a)))
+                      -> ((y,xaddr) -> IO (Maybe (c,a)))
+                      -> TransportA err a b c
+                      -> IO (TransportA err xaddr x y, TransportA err a b c)
+partitionTransportM parse encodex tr = do
+    tchan <- atomically newTChan
+    let ytr = tr { awaitMessage = \kont -> fix $ \again -> do
+                    awaitMessage tr $ \m -> case m of
+                        Arrival adr msg  -> parse (msg,adr) >>= \case
+                            Left x          -> atomically (writeTChan tchan (Just x)) >> join (atomically again)
+                            Right (y,yaddr) -> kont $ Arrival yaddr y
+                        ParseError e     -> kont $ ParseError e
+                        Terminated       -> atomically (writeTChan tchan Nothing) >> kont Terminated
+                 , sendMessage = sendMessage tr
+                 }
+        xtr = Transport
+                { awaitMessage = \kont -> readTChan tchan >>= pure . kont . \case
+                    Nothing        -> Terminated
+                    Just (x,xaddr) -> Arrival xaddr x
+                , sendMessage = \addr' msg' -> do
+                    msg_addr <- encodex (msg',addr')
+                    mapM_ (uncurry . flip $ sendMessage tr) msg_addr
+                , setActive = const $ return ()
+                }
+    return (xtr, ytr)
+
+-- | Paritions a 'Transport' into two higher-level transports.  Note: An 'TChan'
+-- is used to share the same underlying socket, so be sure to fork a thread for
+-- both returned 'Transport's to avoid hanging.
+partitionTransport :: ((b,a) -> Either (x,xaddr) (b,a))
+                      -> ((y,xaddr) -> Maybe (c,a))
+                      -> TransportA err a b c
+                      -> IO (TransportA err xaddr x y, TransportA err a b c)
+partitionTransport parse encodex tr =
+    partitionTransportM (return . parse) (return . encodex) tr
+
+-- |
+--      * f add x --> Nothing, consume x
+--                --> Just id, leave x to a different handler
+--                --> Just g, apply g to x and leave that to a different handler
+--
+-- Note: If you add a handler to one of the branches before applying a
+-- 'mergeTransports' combinator, then this handler may not block or return
+-- Nothing.
+addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> TransportA err addr x y -> TransportA err addr x y
+addHandler onParseError f tr = tr
+    { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \case
+        Arrival addr x -> f addr x >>= maybe (join $ atomically eat) (kont . Arrival addr . ($ x))
+        ParseError e   -> onParseError e >> kont (ParseError e)
+        Terminated     -> kont Terminated
+    }
+
+-- | Modify a 'Transport' to invoke an action upon every received packet.
+onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x
+onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr
+
+-- * Using a query\/response client.
+
+-- | Fork a thread that handles inbound packets.  The returned action may be used
+-- to terminate the thread and clean up any related state.
+--
+--  Example usage:
+--
+--  > -- Start client.
+--  > quitServer <- forkListener "listener" (clientNet client)
+--  > -- Send a query q, recieve a response r.
+--  > r <- sendQuery client method q
+--  > -- Quit client.
+--  > quitServer
+forkListener :: String -> Transport err addr x -> IO (IO ())
+forkListener name client = do
+    setActive client True
+    thread_id <- forkIO $ do
+        myThreadId >>= flip labelThread ("listener."++name)
+        fix $ \loop -> join $ atomically $ awaitMessage client $ \case
+            Terminated -> return ()
+            _          -> loop
+        dput XMisc $ "Listener died: " ++ name
+    return $ do
+        setActive client False
+        -- killThread thread_id
+
+-- * Implementing a query\/response 'Client'.
+
+-- | These methods indicate what should be done upon various conditions.  Write
+-- to a log file, make debug prints, or simply ignore them.
+--
+--   [ /addr/ ]  Address of remote peer.
+--
+--   [ /x/ ]     Incoming or outgoing packet.
+--
+--   [ /meth/ ]  Method id of incoming or outgoing request.
+--
+--   [ /tid/ ]   Transaction id for outgoing packet.
+--
+--   [ /err/ ]   Error information, typically a 'String'.
+data ErrorReporter addr x meth tid err = ErrorReporter
+    { -- | Incoming: failed to parse packet.
+      reportParseError :: err -> IO ()
+      -- | Incoming: no handler for request.
+    , reportMissingHandler :: meth -> addr -> x -> IO ()
+      -- | Incoming: unable to identify request.
+    , reportUnknown :: addr -> x -> err -> IO ()
+    }
+
+ignoreErrors :: ErrorReporter addr x meth tid err
+ignoreErrors = ErrorReporter
+    { reportParseError = \_ -> return ()
+    , reportMissingHandler = \_ _ _ -> return ()
+    , reportUnknown = \_ _ _ -> return ()
+    }
+
+logErrors :: ( Show addr
+               , Show meth
+               ) => ErrorReporter addr x meth tid String
+logErrors = ErrorReporter
+    { reportParseError = \err -> dput XMisc err
+    , reportMissingHandler = \meth addr x -> dput XMisc $ show addr ++ " --> Missing handler ("++show meth++")"
+    , reportUnknown = \addr x err -> dput XMisc $ show addr ++ " --> " ++ err
+    }
+
+printErrors :: ( Show addr
+               , Show meth
+               ) => Handle -> ErrorReporter addr x meth tid String
+printErrors h = ErrorReporter
+    { reportParseError = \err -> hPutStrLn h err
+    , reportMissingHandler = \meth addr x -> hPutStrLn h $ show addr ++ " --> Missing handler ("++show meth++")"
+    , reportUnknown = \addr x err -> hPutStrLn h $ show addr ++ " --> " ++ err
+    }
+
+-- Change the /err/ type for an 'ErrorReporter'.
+instance Contravariant (ErrorReporter addr x meth tid) where
+    -- contramap :: (t5 -> t4) -> ErrorReporter t3 t2 t1 t t4 -> ErrorReporter t3 t2 t1 t t5
+    contramap f (ErrorReporter pe mh unk)
+        = ErrorReporter (\e -> pe (f e))
+                        mh
+                        (\addr x e -> unk addr x (f e))
+
+-- | An incoming message can be classified into three cases.
+data MessageClass err meth tid addr x
+    = IsQuery meth tid                                    -- ^ An unsolicited query is handled based on it's /meth/ value.  Any response
+                                                          -- should include the provided /tid/ value.
+    | IsResponse tid                                      -- ^ A response to a outgoing query we associated with a /tid/ value.
+    | IsUnsolicited (addr -> addr -> IO (Maybe (x -> x))) -- ^ Transactionless informative packet.  The io action will be invoked
+                                                          -- with the source and destination address of a message.  If it handles the
+                                                          -- message, it should return Nothing. Otherwise, it should return a transform
+                                                          -- (usually /id/) to apply before the next handler examines it.
+    | IsUnknown err                                       -- ^ None of the above.
+
+-- | Handler for an inbound query of type /x/ from an address of type _addr_.
+type MethodHandler err tid addr x = MethodHandlerA  err tid addr x x
+
+-- | Handler for an inbound query of type /x/ with outbound response of type
+-- /y/ to an address of type /addr/.
+data MethodHandlerA err tid addr x y = forall a b. MethodHandler
+    { -- | Parse the query into a more specific type for this method.
+      methodParse :: x -> Either err a
+      -- | Serialize the response for transmission, given a context /ctx/ and the origin
+      -- and destination addresses.
+    , methodSerialize :: tid -> addr -> addr -> b -> y
+      -- | Fully typed action to perform upon the query.  The remote origin
+      -- address of the query is provided to the handler.
+      --
+      -- TODO: Allow queries to be ignored?
+    , methodAction :: addr -> a -> IO b
+    }
+      -- | See also 'IsUnsolicited' which likely makes this constructor unnecessary.
+    | forall a. NoReply
+    { -- | Parse the query into a more specific type for this method.
+      methodParse :: x -> Either err a
+      -- | Fully typed action to perform upon the query.  The remote origin
+      -- address of the query is provided to the handler.
+    , noreplyAction :: addr -> a -> IO ()
+    }
+
+
+-- | To dispatch responses to our outbound queries, we require three
+-- primitives.  See the 'transactionMethods' function to create these
+-- primitives out of a lookup table and a generator for transaction ids.
+--
+-- The type variable /d/ is used to represent the current state of the
+-- transaction generator and the table of pending transactions.
+data TransactionMethods d qid addr x = TransactionMethods
+    {
+      -- | Before a query is sent, this function stores an 'MVar' to which the
+      -- response will be written too.  The returned /qid/ is a transaction id
+      -- that can be used to forget the 'MVar' if the remote peer is not
+      -- responding.
+      dispatchRegister :: POSIXTime -- time of expiry
+                          -> (Maybe x -> IO ()) -- callback upon response (or timeout)
+                          -> addr
+                          -> d
+                          -> STM (qid, d)
+      -- | This method is invoked when an incoming packet /x/ indicates it is
+      -- a response to the transaction with id /qid/.  The returned IO action
+      -- will write the packet to the correct 'MVar' thus completing the
+      -- dispatch.
+    , dispatchResponse :: qid -> x -> d -> STM (d, IO ())
+      -- | When a timeout interval elapses, this method is called to remove the
+      -- transaction from the table.
+    , dispatchCancel :: qid -> d -> STM d
+    }
+
+-- | A set of methods necessary for dispatching incoming packets.
+type DispatchMethods tbl err meth tid addr x = DispatchMethodsA tbl err meth tid addr x x
+
+-- | A set of methods necessary for dispatching incoming packets.
+data DispatchMethodsA tbl err meth tid addr x y = DispatchMethods
+    { -- | Classify an inbound packet as a query or response.
+      classifyInbound :: x -> MessageClass err meth tid addr x
+      -- | Lookup the handler for a inbound query.
+    , lookupHandler :: meth -> Maybe (MethodHandlerA err tid addr x y)
+      -- | Methods for handling incoming responses.
+    , tableMethods :: TransactionMethods tbl tid addr x
+    }
+
+-- | All inputs required to implement a query\/response client.
+type Client err meth tid addr x = ClientA err meth tid addr x x
+
+-- | All inputs required to implement a query\/response client.
+data ClientA err meth tid addr x y = forall tbl. Client
+    { -- | The 'Transport' used to dispatch and receive packets.
+      clientNet :: TransportA err addr x y
+      -- | Methods for handling inbound packets.
+    , clientDispatcher :: DispatchMethodsA tbl err meth tid addr x y
+      -- | Methods for reporting various conditions.
+    , clientErrorReporter :: ErrorReporter addr x meth tid err
+      -- | State necessary for routing inbound responses and assigning unique
+      -- /tid/ values for outgoing queries.
+    , clientPending :: TVar tbl
+      -- | An action yielding this client\'s own address.  It is invoked once
+      -- on each outbound and inbound packet.  It is valid for this to always
+      -- return the same value.
+      --
+      -- The argument, if supplied, is the remote address for the transaction.
+      -- This can be used to maintain consistent aliases for specific peers.
+    , clientAddress :: Maybe addr -> IO addr
+      -- | Transform a query /tid/ value to an appropriate response /tid/
+      -- value.  Normally, this would be the identity transformation, but if
+      -- /tid/ includes a unique cryptographic nonce, then it should be
+      -- generated here.
+    , clientResponseId :: tid -> IO tid
+    }
+
+-- | These four parameters are required to implement an outgoing query.  A
+-- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that
+-- might be returned by 'lookupHandler'.
+data MethodSerializerA tid addr x y meth a b = MethodSerializer
+    { -- | Returns the microseconds to wait for a response to this query being
+      -- sent to the given address.  The /addr/ may also be modified to add
+      -- routing information.
+      methodTimeout :: addr -> STM (addr,Int)
+      -- | A method identifier used for error reporting.  This needn't be the
+      -- same as the /meth/ argument to 'MethodHandler', but it is suggested.
+    , method :: meth
+      -- | Serialize the outgoing query /a/ into a transmittable packet /x/.
+      -- The /addr/ arguments are, respectively, our own origin address and the
+      -- destination of the request.  The /tid/ argument is useful for attaching
+      -- auxiliary notations on all outgoing packets.
+    , wrapQuery :: tid -> addr -> addr -> a -> x
+      -- | Parse an inbound packet /x/ into a response /b/ for this query.
+    , unwrapResponse :: y -> b
+    }
+
+type MethodSerializer tid addr x meth a b = MethodSerializerA tid addr x x meth a b
+
+microsecondsDiff :: Int -> POSIXTime
+microsecondsDiff us = fromIntegral us / 1000000
+
+asyncQuery_ :: Client err meth tid addr x
+              -> MethodSerializer tid addr x meth a b
+              -> a
+              -> addr
+              -> (Maybe b -> IO ())
+              -> IO (tid,POSIXTime,Int)
+asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do
+    now <- getPOSIXTime
+    (tid,addr,expiry) <- atomically $ do
+        tbl <- readTVar pending
+        (addr,expiry) <- methodTimeout meth addr0
+        (tid, tbl') <- dispatchRegister (tableMethods d)
+                (now + microsecondsDiff expiry)
+                (withResponse . fmap (unwrapResponse meth))
+                addr -- XXX: Should be addr0 or addr?
+                tbl
+        -- (addr,expiry) <- methodTimeout meth tid addr0
+        writeTVar pending tbl'
+        return (tid,addr,expiry)
+    self <- whoami (Just addr)
+    mres <- do sendMessage net addr (wrapQuery meth tid self addr q)
+               return $ Just ()
+             `catchIOError` (\e -> return Nothing)
+    return (tid,now,expiry)
+
+asyncQuery :: Show meth => Client err meth tid addr x
+              -> MethodSerializer tid addr x meth a b
+              -> a
+              -> addr
+              -> (Maybe b -> IO ())
+              -> IO ()
+asyncQuery client meth q addr withResponse0 = do
+    tm <- getSystemTimerManager
+    tidvar <- newEmptyMVar
+    timedout <- registerTimeout tm 1000000 $ do
+            dput XMisc $ "async TIMEDOUT " ++ show (method meth)
+            withResponse0 Nothing
+            tid <- takeMVar tidvar
+            dput XMisc $ "async TIMEDOUT mvar " ++ show (method meth)
+            case client of
+                Client { clientDispatcher = d, clientPending = pending } -> do
+                    atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending
+    (tid,now,expiry) <- asyncQuery_ client meth q addr $ \x -> do
+        unregisterTimeout tm timedout
+        withResponse0 x
+    putMVar tidvar tid
+    updateTimeout tm timedout expiry
+    dput XMisc $ "FIN asyncQuery "++show (method meth)++" TIMEOUT="++show expiry
+
+-- | Send a query to a remote peer.  Note that this function will always time
+-- out if 'forkListener' was never invoked to spawn a thread to receive and
+-- dispatch the response.
+sendQuery ::
+    forall err a b tbl x meth tid addr.
+        Client err meth tid addr x              -- ^ A query/response implementation.
+        -> MethodSerializer tid addr x meth a b -- ^ Information for marshaling the query.
+        -> a                                    -- ^ The outbound query.
+        -> addr                                 -- ^ Destination address of query.
+        -> IO (Maybe b)                         -- ^ The response, or 'Nothing' if it timed out.
+sendQuery c@(Client net d err pending whoami _) meth q addr0 = do
+    mvar <- newEmptyMVar
+    (tid,now,expiry) <- asyncQuery_ c meth q addr0 $ mapM_ (putMVar mvar)
+    mres <- timeout expiry $ takeMVar mvar
+    case mres of
+        Just b -> return $ Just b
+        Nothing -> do
+            atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending
+            return Nothing
+
+contramapAddr :: (a -> b) -> MethodHandler err tid b x -> MethodHandler err tid a x
+contramapAddr f (MethodHandler p s a)
+    = MethodHandler
+        p
+        (\tid src dst result -> s tid (f src) (f dst) result)
+        (\addr arg -> a (f addr) arg)
+contramapAddr f (NoReply p a)
+    = NoReply p (\addr arg -> a (f addr) arg)
+
+-- | Query handlers can throw this to ignore a query instead of responding to
+-- it.
+data DropQuery = DropQuery
+ deriving Show
+
+instance Exception DropQuery
+
+-- | Attempt to invoke a 'MethodHandler' upon a given inbound query.  If the
+-- parse is successful, the returned IO action will construct our reply if
+-- there is one.  Otherwise, a parse err is returned.
+dispatchQuery :: MethodHandlerA err tid addr x y -- ^ Handler to invoke.
+                 -> tid                          -- ^ The transaction id for this query\/response session.
+                 -> addr                         -- ^ Our own address, to which the query was sent.
+                 -> x                            -- ^ The query packet.
+                 -> addr                         -- ^ The origin address of the query.
+                 -> Either err (IO (Maybe y))
+dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr =
+    fmap (\a -> catch (Just . wrapR tid self addr <$> f addr a)
+                      (\DropQuery -> return Nothing))
+        $ unwrapQ x
+dispatchQuery (NoReply unwrapQ f) tid self x addr =
+    fmap (\a -> f addr a >> return Nothing) $ unwrapQ x
+
+-- | Like 'transactionMethods' but allows extra information to be stored in the
+-- table of pending transactions.  This also enables multiple 'Client's to
+-- share a single transaction table.
+transactionMethods' ::
+    ((Maybe x -> IO ()) -> a)    -- ^ store MVar into table entry
+    -> (a -> Maybe x -> IO void) -- ^ load MVar from table entry
+    -> TableMethods t tid        -- ^ Table methods to lookup values by /tid/.
+    -> (g -> (tid,g))            -- ^ Generate a new unique /tid/ value and update the generator state /g/.
+    -> TransactionMethods (g,t a) tid addr x
+transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
+    { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
+    , dispatchRegister = \nowPlusExpiry v a (g,t) -> do
+        let (tid,g') = generate g
+        let t' = insert tid (store v) nowPlusExpiry t -- (now + microsecondsDiff expiry) t
+        return ( tid, (g',t') )
+    , dispatchResponse = \tid x (g,t) ->
+        case lookup tid t of
+            Just v -> let t' = delete tid t
+                      in return ((g,t'),void $ load v $ Just x)
+            Nothing -> return ((g,t), return ())
+    }
+
+-- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a
+-- function for generating unique transaction ids.
+transactionMethods ::
+    TableMethods t tid  -- ^ Table methods to lookup values by /tid/.
+    -> (g -> (tid,g))   -- ^ Generate a new unique /tid/ value and update the generator state /g/.
+    -> TransactionMethods (g,t (Maybe x -> IO ())) tid addr x
+transactionMethods methods generate = transactionMethods' id id methods generate
+
+-- | Handle a single inbound packet and then invoke the given continuation.
+-- The 'forkListener' function is implemented by passing this function to 'fix'
+-- in a forked thread that loops until 'awaitMessage' returns 'Nothing' or
+-- throws an exception.
+handleMessage ::
+    ClientA err meth tid addr x y
+    -> addr
+    -> x
+    -> IO (Maybe (x -> x))
+handleMessage (Client net d err pending whoami responseID) addr plain = do
+    -- Just (Left e)              -> do reportParseError err e
+    --                                  return $! Just id
+    -- Just (Right (plain, addr)) -> do
+        case classifyInbound d plain of
+            IsQuery meth tid -> case lookupHandler d meth of
+                                Nothing -> do reportMissingHandler err meth addr plain
+                                              return $! Just id
+                                Just m  -> do
+                                  self <- whoami (Just addr)
+                                  tid' <- responseID tid
+                                  either (\e -> do reportParseError err e
+                                                   return $! Just id)
+                                         (>>= \m -> do mapM_ (sendMessage net addr) m
+                                                       return $! Nothing)
+                                         (dispatchQuery m tid' self plain addr)
+            IsUnsolicited action -> do
+                self <- whoami (Just addr)
+                action self addr
+                return Nothing
+            IsResponse tid -> do
+                action <- atomically $ do
+                    ts0 <- readTVar pending
+                    (ts, action) <- dispatchResponse (tableMethods d) tid plain ts0
+                    writeTVar pending ts
+                    return action
+                action
+                return $! Nothing
+            IsUnknown e -> do reportUnknown err addr plain e
+                              return $! Just id
+    -- Nothing -> return $! id
+
+-- * UDP Datagrams.
+
+-- | Access the address family of a given 'SockAddr'.  This convenient accessor
+-- is missing from 'Network.Socket', so I implemented it here.
+sockAddrFamily :: SockAddr -> Family
+sockAddrFamily (SockAddrInet  _ _    ) = AF_INET
+sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6
+sockAddrFamily (SockAddrUnix  _      ) = AF_UNIX
+#if !MIN_VERSION_network(3,0,0)
+sockAddrFamily _                       = AF_CAN -- SockAddrCan constructor deprecated
+#endif
+
+-- | Packets with an empty payload may trigger EOF exception.
+-- 'udpTransport' uses this function to avoid throwing in that
+-- case.
+ignoreEOF :: Socket -> MVar () -> Arrival e a x -> IOError -> IO (Arrival e a x)
+ignoreEOF sock isClosed def e = do
+    done <- tryReadMVar isClosed
+    case done of
+        Just () -> do close sock
+                      dput XMisc "Closing UDP socket."
+                      pure Terminated
+        _ -> if isEOFError e then pure def
+                             else throwIO e
+
+-- | Hard-coded maximum packet size for incoming UDP Packets received via
+-- 'udpTransport'.
+udpBufferSize :: Int
+udpBufferSize = 65536
+
+-- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError.
+saferSendTo :: Socket -> ByteString -> SockAddr -> IO ()
+saferSendTo sock bs saddr = void (B.sendTo sock bs saddr)
+    `catch` \e ->
+        -- sendTo: does not exist (Network is unreachable)
+        --       Occurs when IPv6 or IPv4 network is not available.
+        --       Currently, we require -threaded to prevent a forever-hang in this case.
+        if isDoesNotExistError e
+            then return ()
+            else throw e
+
+-- | Like 'udpTransport' except also returns the raw socket (for broadcast use).
+udpTransport' :: Show err => SockAddr -> IO (Transport err SockAddr ByteString, Socket)
+udpTransport' bind_address = do
+  let family = sockAddrFamily bind_address
+  sock <- socket family Datagram defaultProtocol
+  when (family == AF_INET6) $ do
+    setSocketOption sock IPv6Only 0
+  setSocketOption sock Broadcast 1
+  bind sock bind_address
+  isClosed <- newEmptyMVar
+  udpTChan <- atomically newTChan
+  let tr = Transport {
+      awaitMessage = \kont -> do
+        r <- readTChan udpTChan
+        return $ kont $! r
+    , sendMessage = case family of
+        AF_INET6 -> \case
+            (SockAddrInet port addr) -> \bs ->
+                -- Change IPv4 to 4mapped6 address.
+                saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0
+            addr6 -> \bs -> saferSendTo sock bs addr6
+        AF_INET  -> \case
+            (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
+                let host4 = toBE32 raw4
+                -- Change 4mapped6 to ordinary IPv4.
+                -- dput XMisc $ "4mapped6 -> "++show (SockAddrInet port host4)
+                saferSendTo sock bs (SockAddrInet port host4)
+            addr@(SockAddrInet6 {}) -> \bs -> dput XMisc ("Discarding packet to "++show addr)
+            addr4 -> \bs -> saferSendTo sock bs addr4
+        _ -> \addr bs -> saferSendTo sock bs addr
+    , setActive = \case
+      False -> do
+        dput XMisc $ "closeTransport for udpTransport' called. " ++ show bind_address
+        tryPutMVar isClosed () -- signal awaitMessage that the transport is closed.
+#if MIN_VERSION_network (3,1,0)
+#elif MIN_VERSION_network(3,0,0)
+        let withFdSocket sock f = fdSocket sock >>= f >>= seq sock . return
+#else
+        let withFdSocket sock f = f (fdSocket sock) >>= seq sock . return
+#endif
+        withFdSocket sock $ \fd -> do
+            let sorryGHCButIAmNotFuckingClosingTheSocketYet fd = return ()
+            -- This call is necessary to interrupt the blocking recvFrom call in awaitMessage.
+            closeFdWith sorryGHCButIAmNotFuckingClosingTheSocketYet (fromIntegral fd)
+      True -> do
+            udpThread <- forkIO $ fix $ \again -> do
+                r <- handle (ignoreEOF sock isClosed $ Arrival (SockAddrInet 0 0) B.empty) $ do
+                        uncurry (flip Arrival) <$!> B.recvFrom sock udpBufferSize
+                atomically $ writeTChan udpTChan r
+                case r of Terminated -> return ()
+                          _          -> again
+            labelThread udpThread ("udp.io."++show bind_address)
+    }
+  return (tr, sock)
+
+-- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's.  The
+-- argument is the listen-address for incoming packets.  This is a useful
+-- low-level 'Transport' that can be transformed for higher-level protocols
+-- using 'layerTransport'.
+udpTransport :: Show err => SockAddr -> IO (Transport err SockAddr ByteString)
+udpTransport bind_address = fst <$> udpTransport' bind_address
+
+chanTransport :: (addr -> TChan (x, addr)) -> addr -> TChan (x, addr) -> TVar Bool -> Transport err addr x
+chanTransport chanFromAddr self achan aclosed = Transport
+    { awaitMessage = \kont -> do
+        x <- (uncurry (flip Arrival) <$> readTChan achan)
+                            `orElse`
+             (readTVar aclosed >>= check >> return Terminated)
+        return $ kont x
+    , sendMessage = \them bs -> do
+        atomically $ writeTChan (chanFromAddr them) (bs,self)
+    , setActive = \case
+        False -> atomically $ writeTVar aclosed True
+        True  -> return ()
+    }
+
+-- | Returns a pair of transports linked together to simulate two computers talking to each other.
+testPairTransport :: IO (Transport err SockAddr ByteString, Transport err SockAddr ByteString)
+testPairTransport = do
+    achan <- atomically newTChan
+    bchan <- atomically newTChan
+    aclosed <- atomically $ newTVar False
+    bclosed <- atomically $ newTVar False
+    let a = SockAddrInet 1 1
+        b = SockAddrInet 2 2
+    return ( chanTransport (const bchan) a achan aclosed
+           , chanTransport (const achan) b bchan bclosed )
+
+newtype ByAddress err x addr = ByAddress (Transport err addr x)
+
+newtype Tagged x addr = Tagged x
+
+decorateAddr :: tag addr -> Arrival e addr x -> Arrival e (DSum tag Identity) x
+decorateAddr tag Terminated       = Terminated
+decorateAddr tag (ParseError e)   = ParseError e
+decorateAddr tag (Arrival addr x) = Arrival (tag ==> addr) x
+
+mergeTransports :: GCompare tag => DMap tag (ByAddress err x) -> IO (Transport err (DSum tag Identity) x)
+mergeTransports tmap = do
+    -- vmap <- traverseWithKey (\k v -> Tagged <$> newEmptyMVar) tmap
+    -- foldrWithKey (\k v n -> forkMergeBranch k v >> n) (return ()) vmap
+    return Transport
+        { awaitMessage = \kont ->
+            foldrWithKey (\k (ByAddress tr) n -> awaitMessage tr (kont . decorateAddr k) `orElse` n)
+                         retry
+                         tmap
+        , sendMessage = \(tag :=> Identity addr) x -> case DMap.lookup tag tmap of
+            Just (ByAddress tr) -> sendMessage tr addr x
+            Nothing             -> return ()
+        , setActive = \toggle -> foldrWithKey (\_ (ByAddress tr) next -> setActive tr toggle >> next) (return ()) tmap
+        }
diff --git a/server/src/Network/QueryResponse/TCP.hs b/server/src/Network/QueryResponse/TCP.hs
new file mode 100644
index 00000000..8b1b432b
--- /dev/null
+++ b/server/src/Network/QueryResponse/TCP.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE OverloadedStrings          #-}
+module Network.QueryResponse.TCP where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread,forkIO)
+import ForkLabeled
+#endif
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMVar
+import Control.Monad
+import Data.ByteString (ByteString,hPut)
+import Data.Function
+import Data.Hashable
+import Data.Maybe
+import Data.Ord
+import Data.Time.Clock.POSIX
+import Data.Word
+import Data.String (IsString(..))
+import Network.BSD
+import Network.Socket as Socket
+import System.Timeout
+import System.IO
+import System.IO.Error
+
+import DebugTag
+import DebugUtil
+import DPut
+import Connection.Tcp (socketFamily)
+import qualified Data.MinMaxPSQ as MM
+import Network.QueryResponse
+
+data TCPSession st
+    = PendingTCPSession
+    | TCPSession
+        { tcpHandle :: Handle
+        , tcpState  :: st
+        , tcpThread :: ThreadId
+        }
+
+newtype TCPAddress = TCPAddress SockAddr
+ deriving (Eq,Ord,Show)
+
+instance Hashable TCPAddress where
+    hashWithSalt salt (TCPAddress x) = case x of
+        SockAddrInet port addr   -> hashWithSalt salt (fromIntegral port :: Word16,addr)
+        SockAddrInet6 port b c d -> hashWithSalt salt (fromIntegral port :: Word16,b,c,d)
+        _                        -> 0
+
+data TCPCache st = TCPCache
+    { lru    :: TVar (MM.MinMaxPSQ' TCPAddress (Down POSIXTime) (TCPSession st))
+    , tcpMax :: Int
+    }
+
+-- This is a suitable /st/ parameter to 'TCPCache'
+data SessionProtocol x y = SessionProtocol
+    { streamGoodbye :: IO ()        -- ^ "Goodbye" protocol upon termination.
+    , streamDecode  :: IO (Maybe x) -- ^ Parse inbound messages.
+    , streamEncode  :: y -> IO ()   -- ^ Serialize outbound messages.
+    }
+
+data StreamHandshake addr x y = StreamHandshake
+    { streamHello :: addr -> Handle -> IO (SessionProtocol x y) -- ^ "Hello" protocol upon fresh connection.
+    , streamAddr  :: addr -> SockAddr
+    }
+
+killSession :: TCPSession st -> IO ()
+killSession PendingTCPSession       = return ()
+killSession TCPSession{tcpThread=t} = killThread t
+
+showStat :: IsString p => TCPSession st -> p
+showStat r = case r of PendingTCPSession -> "pending."
+                       TCPSession {}     -> "established."
+
+tcp_timeout :: Int
+tcp_timeout = 10000000
+
+acquireConnection :: TMVar (Arrival a addr x)
+                           -> TCPCache (SessionProtocol x y)
+                           -> StreamHandshake addr x y
+                           -> addr
+                           -> Bool
+                           -> IO (Maybe (y -> IO ()))
+acquireConnection mvar tcpcache stream addr bDoCon = do
+    now <- getPOSIXTime
+    -- dput XTCP $ "acquireConnection 0 " ++ show (streamAddr stream addr)
+    entry <- atomically $ do
+        c <- readTVar (lru tcpcache)
+        let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c
+        case v of
+            Nothing | bDoCon -> writeTVar (lru tcpcache)
+                                $ MM.insert' (TCPAddress $ streamAddr stream addr) PendingTCPSession (Down now) c
+                    | otherwise -> return ()
+            Just (tm, v) -> writeTVar (lru tcpcache)
+                                $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down now) c
+        return v
+    -- dput XTCP $ "acquireConnection 1 " ++ show (streamAddr stream addr, fmap (second showStat) entry)
+    case entry of
+        Nothing -> fmap join $ forM (guard bDoCon) $ \() -> do
+            proto <- getProtocolNumber "tcp"
+            sock <- socket (socketFamily $ streamAddr stream addr) Stream proto
+            mh <- catchIOError (do h <- timeout tcp_timeout $ do
+                                       connect sock (streamAddr stream addr) `catchIOError` (\e -> close sock)
+                                       h <- socketToHandle sock ReadWriteMode
+                                       hSetBuffering h NoBuffering
+                                       return h
+                                   return h)
+                               $ \e -> return Nothing
+            when (isNothing mh) $ do
+                atomically $ modifyTVar' (lru tcpcache)
+                           $ MM.delete (TCPAddress $ streamAddr stream addr)
+                Socket.close sock
+            ret <- fmap join $ forM mh $ \h -> do
+             mst <- catchIOError (Just <$> streamHello stream addr h)
+                                 (\e -> return Nothing)
+             case mst of
+               Nothing -> do
+                atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr)
+                return Nothing
+               Just st -> do
+                dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr)
+                signal <- newTVarIO False
+                let showAddr a = show (streamAddr stream a)
+                rthread <- forkLabeled ("tcp:"++showAddr addr) $ do
+                  atomically (readTVar signal >>= check)
+                  fix $ \loop -> do
+                    x <- streamDecode st
+                    dput XTCP $ "TCP streamDecode " ++ show (streamAddr stream addr) ++ " --> " ++ maybe "Nothing" (const "got") x
+                    case x of
+                        Just u -> do
+                            m <- timeout tcp_timeout $ atomically (putTMVar mvar $ Arrival addr u)
+                            when (isNothing m) $ do
+                                dput XTCP $ "TCP "++show (streamAddr stream addr) ++ " dropped packet."
+                                atomically $ tryTakeTMVar mvar
+                                return ()
+                            loop
+                        Nothing -> do
+                            dput XTCP $ "TCP disconnected: " ++ show (streamAddr stream addr)
+                            do atomically $ modifyTVar' (lru tcpcache)
+                                       $ MM.delete (TCPAddress $ streamAddr stream addr)
+                            c <- atomically $ readTVar (lru tcpcache)
+                            now <- getPOSIXTime
+                            forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do
+                                dput XTCP $ unwords [show i ++ ".", "Still connected:",  show addr, show (now - tm), showStat r]
+                            mreport <- timeout tcp_timeout $ threadReport False -- XXX: Paranoid timeout
+                            case mreport of
+                                Just treport -> dput XTCP treport
+                                Nothing      -> dput XTCP "TCP ERROR: threadReport timed out."
+                            hClose h `catchIOError` \e -> return ()
+                let v = TCPSession
+                        { tcpHandle = h
+                        , tcpState  = st
+                        , tcpThread = rthread
+                        }
+                t <- getPOSIXTime
+                retires <- atomically $ do
+                    c <- readTVar (lru tcpcache)
+                    let (rs,c') = MM.takeView (tcpMax tcpcache)
+                                $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down t) c
+                    writeTVar (lru tcpcache) c'
+                    writeTVar signal True
+                    return rs
+                forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkLabeled ("tcp-close:"++show k) $ do
+                    dput XTCP $ "TCP dropped: " ++ show k
+                    killSession r
+                    case r of TCPSession {tcpState=st,tcpHandle=h} -> do
+                                    streamGoodbye st
+                                    hClose h
+                                `catchIOError` \e -> return ()
+                              _ -> return ()
+
+                return $ Just $ streamEncode st
+            when (isNothing ret) $ do
+                atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr)
+            return ret
+        Just (tm, PendingTCPSession)
+            | not bDoCon -> return Nothing
+            | otherwise  -> fmap join $ timeout tcp_timeout $ atomically $ do
+                c <- readTVar (lru tcpcache)
+                let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c
+                case v of
+                    Just (_,TCPSession{tcpState=st}) -> return $ Just $ streamEncode st
+                    Nothing                          -> return Nothing
+                    _                                -> retry
+        Just (tm, v@TCPSession {tcpState=st}) -> return $ Just $ streamEncode st
+
+closeAll :: TCPCache (SessionProtocol x y) -> StreamHandshake addr x y -> IO ()
+closeAll tcpcache stream = do
+    dput XTCP "TCP.closeAll called."
+    cache <- atomically $ swapTVar (lru tcpcache) MM.empty
+    forM_ (MM.toList cache) $ \(MM.Binding (TCPAddress addr) r tm) -> do
+        killSession r
+        case r of TCPSession{tcpState=st,tcpHandle=h} -> catchIOError (streamGoodbye st >> hClose h)
+                                                                      (\e -> return ())
+                  _                                   -> return ()
+
+-- Use a cache of TCP client connections for sending (and receiving) packets.
+-- The boolean value prepended to the message allows the sender to specify
+-- whether or not a new connection will be initiated if neccessary.  If 'False'
+-- is passed, then the packet will be sent only if there already exists a
+-- connection.
+tcpTransport :: Int -- ^ maximum number of TCP links to maintain.
+                -> StreamHandshake addr x y
+                -> IO (TCPCache (SessionProtocol x y), TransportA err addr x (Bool,y))
+tcpTransport maxcon stream = do
+    msgvar <- atomically newEmptyTMVar
+    tcpcache <- atomically $ (`TCPCache` maxcon) <$> newTVar (MM.empty)
+    return $ (,) tcpcache Transport
+        { awaitMessage   = \f -> takeTMVar msgvar >>= \x -> return $ do
+            f x `catchIOError` (\e -> dput XTCP ("TCP transport stopped. " ++ show e) >> f Terminated)
+        , sendMessage    = \addr (bDoCon,y) -> do
+                                void . forkLabeled "tcp-send" $ do
+                                    msock <- acquireConnection msgvar tcpcache stream addr bDoCon
+                                    mapM_ ($ y) msock
+                                  `catchIOError` \e -> dput XTCP $ "TCP-send: " ++ show e
+        , setActive      = \case False -> closeAll tcpcache stream >> atomically (putTMVar msgvar Terminated)
+                                 True  -> return ()
+        }
diff --git a/server/src/Network/SocketLike.hs b/server/src/Network/SocketLike.hs
new file mode 100644
index 00000000..37891cfd
--- /dev/null
+++ b/server/src/Network/SocketLike.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+-- |
+--
+-- A socket could be used indirectly via a 'System.IO.Handle' or a conduit from
+-- Michael Snoyman's conduit package.  But doing so presents an encapsulation
+-- problem.  Do we allow access to the underlying socket and trust that it wont
+-- be used in an unsafe way?  Or do we protect it at the higher level and deny
+-- access to various state information?
+--
+-- The 'SocketLike' class enables the approach that provides a safe wrapper to
+-- the underlying socket and gives access to various state information without
+-- enabling direct reads or writes.
+module Network.SocketLike
+    ( SocketLike(..)
+    , RestrictedSocket
+    , restrictSocket
+    , restrictHandleSocket
+    -- * Re-exports
+    --
+    -- | To make the 'SocketLike' methods less awkward to use, the types
+    -- 'CUInt', 'SockAddr', and 'PortNumber' are re-exported.
+    , CUInt
+    , PortNumber
+    , SockAddr(..)
+    ) where
+
+import Network.Socket
+    ( PortNumber
+    , SockAddr
+    )
+import Foreign.C.Types ( CUInt )
+
+import qualified Network.Socket as NS
+import System.IO (Handle,hClose,hIsOpen)
+import Control.Arrow
+
+-- | A safe (mostly read-only) interface to a 'NS.Socket'.  Note that despite
+-- how this class is named, it provides no access to typical 'NS.Socket' uses
+-- like sending or receiving network packets.
+class SocketLike sock where
+    -- | See 'NS.getSocketName'
+    getSocketName :: sock -> IO SockAddr
+    -- | See 'NS.getPeerName'
+    getPeerName   :: sock -> IO SockAddr
+    -- | See 'NS.getPeerCred'
+--  getPeerCred   :: sock -> IO (CUInt, CUInt, CUInt)
+
+    -- | Is the socket still valid? Connected
+    --
+    --   In order to give the instance writer
+    --   the option to do book-keeping in a pure
+    --   type, a conceptually modified version of
+    --   the 'SocketLike' is returned.
+    --
+    isValidSocket :: sock -> IO (sock,Bool)
+
+
+instance SocketLike NS.Socket where
+    getSocketName = NS.getSocketName
+    getPeerName   = NS.getPeerName
+--  getPeerCred   = NS.getPeerCred
+#if MIN_VERSION_network(3,1,0)
+    isValidSocket s = (s,) <$> NS.withFdSocket s (return . (/= (-1)))
+#else
+#if MIN_VERSION_network(3,0,0)
+    isValidSocket s = (s,) . (/= (-1)) <$> NS.fdSocket s
+#else
+#if MIN_VERSION_network(2,4,0)
+    isValidSocket s = (s,) <$> NS.isConnected s -- warning: this is always False if the socket
+                                                --          was converted to a Handle
+#else
+    isValidSocket s = (s,) <$> NS.sIsConnected s -- warning: this is always False if the socket
+                                                 --          was converted to a Handle
+#endif
+#endif
+#endif
+
+-- | An encapsulated socket.  Data reads and writes are not possible.
+data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show
+
+instance SocketLike RestrictedSocket where
+    getSocketName (Restricted mb sock) = NS.getSocketName sock
+    getPeerName   (Restricted mb sock) = NS.getPeerName sock
+--  getPeerCred   (Restricted mb sock) = NS.getPeerCred sock
+    isValidSocket rs@(Restricted mb sock) = maybe (first (Restricted mb) <$> isValidSocket sock) (((rs,) <$>) .  hIsOpen) mb
+
+-- | Create a 'RestrictedSocket' that explicitly disallows sending or
+-- receiving data.
+restrictSocket :: NS.Socket -> RestrictedSocket
+restrictSocket socket = Restricted Nothing socket
+
+-- | Build a 'RestrictedSocket' for which 'sClose' will close the given
+-- 'Handle'.  It is intended that this 'Handle' was obtained via
+-- 'NS.socketToHandle'.
+restrictHandleSocket :: Handle ->  NS.Socket -> RestrictedSocket
+restrictHandleSocket h socket = Restricted (Just h) socket
diff --git a/server/src/Network/StreamServer.hs b/server/src/Network/StreamServer.hs
new file mode 100644
index 00000000..1da612ce
--- /dev/null
+++ b/server/src/Network/StreamServer.hs
@@ -0,0 +1,167 @@
+-- | This module implements a bare-bones TCP or Unix socket server.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module Network.StreamServer
+    ( streamServer
+    , ServerHandle
+    , getAcceptLoopThreadId
+    , ServerConfig(..)
+    , withSession
+    , quitListening
+  --, dummyServerHandle
+    , listenSocket
+    , Local(..)
+    , Remote(..)
+    ) where
+
+import Data.Monoid
+import Network.Socket as Socket
+import System.Directory (removeFile)
+import System.IO
+    ( IOMode(..)
+    , stderr
+    , hFlush
+    )
+import Control.Monad
+import Control.Monad.Fix (fix)
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+           ( forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId
+           , killThread )
+#else
+import GHC.Conc (labelThread)
+import Control.Concurrent
+           ( forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId
+           , killThread )
+#endif
+import Control.Exception (handle,finally)
+import System.IO.Error (tryIOError)
+import System.Mem.Weak
+import System.IO.Error
+
+-- import Data.Conduit
+import System.IO (Handle)
+import Control.Concurrent.MVar (newMVar)
+
+import Network.SocketLike
+import DPut
+import DebugTag
+
+data ServerHandle = ServerHandle Socket (Weak ThreadId)
+
+-- | Useful for testing.
+getAcceptLoopThreadId :: ServerHandle -> IO (Weak ThreadId)
+getAcceptLoopThreadId (ServerHandle _ t) = return t
+
+listenSocket :: ServerHandle -> RestrictedSocket
+listenSocket (ServerHandle sock _) = restrictSocket sock
+
+{- // Removed, bit-rotted and there are no call sites
+-- | Create a useless do-nothing 'ServerHandle'.
+dummyServerHandle :: IO ServerHandle
+dummyServerHandle = do
+    mvar <- newMVar Closed
+    let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar
+    thread <- mkWeakThreadId <=< forkIO $ return ()
+    return (ServerHandle sock thread)
+-}
+
+removeSocketFile :: SockAddr -> IO ()
+removeSocketFile (SockAddrUnix fname) = removeFile fname
+removeSocketFile _                    = return ()
+
+-- | Terminate the server accept-loop.  Call this to shut down the server.
+quitListening :: ServerHandle -> IO ()
+quitListening (ServerHandle socket acceptThread) =
+    finally (Socket.getSocketName socket >>= removeSocketFile)
+            (do mapM_ killThread =<< deRefWeak acceptThread
+                Socket.close socket)
+
+
+-- | It's 'bshow' instead of 'show' to enable swapping in a 'ByteString'
+-- variation.  (This is not exported.)
+bshow :: Show a => a -> String
+bshow e = show e
+
+-- | Send a string to stderr.  Not exported.  Default 'serverWarn' when
+-- 'withSession' is used to configure the server.
+warnStderr :: String -> IO ()
+warnStderr str = dput XMisc str >> hFlush stderr
+
+newtype Local a = Local a deriving (Eq,Ord,Show)
+newtype Remote a = Remote a deriving (Eq,Ord,Show)
+
+data ServerConfig = ServerConfig
+    { serverWarn    :: String -> IO ()
+    -- ^ Action to report warnings and errors.
+    , serverSession :: ( RestrictedSocket, (Local SockAddr, Remote SockAddr)) -> Int -> Handle -> IO ()
+    -- ^ Action to handle interaction with a client
+    }
+
+-- | Initialize a 'ServerConfig' using the provided session handler.
+withSession :: ((RestrictedSocket,(Local SockAddr,Remote SockAddr)) -> Int -> Handle -> IO ()) -> ServerConfig
+withSession session = ServerConfig warnStderr session
+
+-- | Launch a thread to listen at the given bind address and dispatch
+-- to session handler threads on every incoming connection. Supports
+-- IPv4 and IPv6, TCP and unix sockets.
+--
+-- The returned handle can be used with 'quitListening' to terminate the
+-- thread and prevent any new sessions from starting.  Currently active
+-- session threads will not be terminated or signaled in any way.
+streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle
+streamServer cfg addrs = do
+    let warn   = serverWarn cfg
+        family = case addrs of
+                    SockAddrInet  {}:_ -> AF_INET
+                    SockAddrInet6 {}:_ -> AF_INET6
+                    SockAddrUnix  {}:_ -> AF_UNIX
+                    []                 -> AF_INET6
+    sock <- socket family Stream 0
+    setSocketOption sock ReuseAddr 1
+    let tryBind addr next _ = do
+            tryIOError (removeSocketFile addr)
+            bind sock addr
+          `catchIOError` \e -> next (Just e)
+    fix $ \loop -> let again mbe = do
+                            forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e
+                            threadDelay 5000000
+                            loop
+                    in foldr tryBind again addrs Nothing
+    listen sock maxListenQueue
+    thread <- mkWeakThreadId <=< forkIO $ do
+        bindaddr <- Socket.getSocketName sock
+        myThreadId >>= flip labelThread ("StreamServer.acceptLoop." <> bshow bindaddr)
+        acceptLoop cfg sock 0
+    return (ServerHandle sock thread)
+
+-- | Not exported.  This, combined with 'acceptException' form a mutually
+-- recursive loop that handles incoming connections.  To quit the loop, the
+-- socket must be closed by 'quitListening'.
+acceptLoop :: ServerConfig -> Socket -> Int -> IO ()
+acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do
+    (con,raddr) <- accept sock
+    let conkey = n + 1
+    laddr <- Socket.getSocketName con
+    h <- socketToHandle con ReadWriteMode
+    forkIO $ do
+        myThreadId >>= flip labelThread "StreamServer.session"
+        serverSession cfg (restrictHandleSocket h con, (Local laddr, Remote raddr)) conkey h
+    acceptLoop cfg sock (n + 1)
+
+acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO ()
+acceptException cfg n sock ioerror = do
+    case show (ioeGetErrorType ioerror) of
+      "resource exhausted" -> do -- try again (ioeGetErrorType ioerror == fullErrorType)
+                                 serverWarn cfg $ ("acceptLoop: resource exhasted")
+                                 threadDelay 500000
+                                 acceptLoop cfg sock (n + 1)
+      "invalid argument"   -> do -- quit on closed socket
+                                 Socket.close sock
+      message              -> do -- unexpected exception
+                                 serverWarn cfg $ ("acceptLoop: "<>bshow message)
+                                 Socket.close sock
+
diff --git a/server/src/SockAddr.hs b/server/src/SockAddr.hs
new file mode 100644
index 00000000..b5fbf16e
--- /dev/null
+++ b/server/src/SockAddr.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module SockAddr () where
+
+#if MIN_VERSION_network(2,4,0)
+import Network.Socket ()
+#else
+import Network.Socket ( SockAddr(..) )
+
+deriving instance Ord SockAddr
+#endif
+
+
+