server library.

22 files changed, 97 insertions, 30 deletions

diff --git a/cabal.project b/cabal.project
index 52755c6a..12f0fd90 100644
--- a/cabal.project
+++ b/cabal.project
@@ -11,6 +11,7 @@ packages:
        kad/
        torrent-types/
        dput-hslogger/
+       server/
        bencoding/
        concurrent-supply/
        base32-bytestring/
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index 64d48f53..0da181df 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -75,15 +75,10 @@ library
                      , RecordWildCards
                      , NondecreasingIndentation
   hs-source-dirs:      src, ., Presence
-  exposed-modules:  Control.Concurrent.ThreadUtil
-                    Network.SocketLike
-                    Data.Digest.CRC32C
+  exposed-modules:  Data.Digest.CRC32C
                     Data.Bits.ByteString
-                    Data.TableMethods
                     Network.BitTorrent.DHT.ContactInfo
                     Network.BitTorrent.DHT.Token
-                    Network.QueryResponse
-                    Network.StreamServer
                     Data.BEncode.Pretty
                     Network.BitTorrent.MainlineDHT
                     Network.BitTorrent.MainlineDHT.Symbols
@@ -107,7 +102,6 @@ library
                     Network.Tox.Avahi
                     Network.Tox.RelayPinger
                     Network.UPNP
-                    Network.QueryResponse.TCP
                     Network.Tox.Relay
                     Network.Tox.TCP
                     Data.Tox.Msg
@@ -117,7 +111,6 @@ library
                     Network.Tox.ContactInfo
                     Announcer
                     Announcer.Tox
-                    Control.Concurrent.Delay
                     ByteStringOperators
                     ClientState
                     ConfigFiles
@@ -126,19 +119,14 @@ library
                     Control.Concurrent.STM.StatusCache
                     Control.Concurrent.STM.UpdateStream
                     Control.Concurrent.STM.Util
-                    ControlMaybe
                     Data.BitSyntax
-                    DNSCache
                     EventUtil
                     FGConsole
-                    GetHostByAddr
                     LocalPeerCred
                     LockedChan
                     Logging
                     Nesting
                     Paths
-                    Connection.Tcp
-                    SockAddr
                     UTmp
                     MUC
                     LocalChat
@@ -149,13 +137,10 @@ library
                     XMPPServer
                     Util
                     Presence
-                    Control.Concurrent.PingMachine
-                    Connection
                     ToxChat
                     ToxToXMPP
                     ToxManager
                     XMPPToTox
-                    DebugUtil
                     Data.IntervalSet
                     Data.Tox.Message
                     HandshakeCache
@@ -233,6 +218,7 @@ library
                     , kad
                     , tasks
                     , torrent-types
+                    , server
 
   if impl(ghc < 8)
       Build-depends:  transformers
@@ -319,6 +305,7 @@ executable dhtd
                      , pretty
                      , dependent-sum
                      , dht-client
+                     , server
                      , dput-hslogger
                      , word64-map
                      , tox-crypto
@@ -368,6 +355,7 @@ executable testTox
   default-language:    Haskell2010
   build-depends:       base
                      , dht-client
+                     , server
                      , dput-hslogger
                      , tox-crypto
                      , lifted-concurrent
diff --git a/dht/stack.yaml b/dht/stack.yaml
index 3ae992c7..5c6013a0 100644
--- a/dht/stack.yaml
+++ b/dht/stack.yaml
@@ -18,6 +18,7 @@ extra-deps:
 - "../concurrent-supply/"
 - "../base32-bytestring/"
 - "../dependent-map/"
+- "../server/"
 - cryptonite-0.23
 - reference-0.1
 - avahi-0.2.0@sha256:eb725536d8427548685b531d4bf8271a3104da06f611ed38165a0e08e21c54eb,1799
diff --git a/lifted-concurrent/lifted-concurrent.cabal b/lifted-concurrent/lifted-concurrent.cabal
index bbf254e3..8fe4b6a9 100644
--- a/lifted-concurrent/lifted-concurrent.cabal
+++ b/lifted-concurrent/lifted-concurrent.cabal
@@ -19,6 +19,8 @@ library
   exposed-modules:
           Control.Concurrent.Lifted.Instrument
         , Control.Concurrent.Async.Lifted.Instrument
+        , DebugUtil
+        , Control.Concurrent.ThreadUtil
   other-modules: DebugTag
   other-extensions:    FlexibleContexts
   build-depends:
@@ -32,3 +34,4 @@ library
         , transformers-base
   hs-source-dirs:      src
   default-language:    Haskell2010
+  cpp-options: -DTHREAD_DEBUG
diff --git a/dht/src/Control/Concurrent/ThreadUtil.hs b/lifted-concurrent/src/Control/Concurrent/ThreadUtil.hs
index a258d933..a258d933 100644
--- a/dht/src/Control/Concurrent/ThreadUtil.hs
+++ b/lifted-concurrent/src/Control/Concurrent/ThreadUtil.hs
diff --git a/dht/src/DebugUtil.hs b/lifted-concurrent/src/DebugUtil.hs
index 96ab8cc5..e73f9061 100644
--- a/dht/src/DebugUtil.hs
+++ b/lifted-concurrent/src/DebugUtil.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
 module DebugUtil where
 
 import Control.Monad
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/dht/Connection.hs b/server/src/Connection.hs
index ea86f4bb..ea86f4bb 100644
--- a/dht/Connection.hs
+++ b/server/src/Connection.hs
diff --git a/dht/Connection/Tcp.hs b/server/src/Connection/Tcp.hs
index 4d50d47f..7d93e7de 100644
--- a/dht/Connection/Tcp.hs
+++ b/server/src/Connection/Tcp.hs
@@ -1,12 +1,13 @@
 {-# OPTIONS_HADDOCK prune #-}
-{-# LANGUAGE CPP                #-}
-{-# LANGUAGE DoAndIfThenElse    #-}
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RankNTypes         #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections      #-}
-{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE DoAndIfThenElse          #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE TupleSections            #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Connection.Tcp
diff --git a/dht/src/Control/Concurrent/Delay.hs b/server/src/Control/Concurrent/Delay.hs
index 67dcd451..5cc1f99a 100644
--- a/dht/src/Control/Concurrent/Delay.hs
+++ b/server/src/Control/Concurrent/Delay.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NondecreasingIndentation #-}
 module Control.Concurrent.Delay where
 
 import Control.Concurrent
diff --git a/dht/src/Control/Concurrent/PingMachine.hs b/server/src/Control/Concurrent/PingMachine.hs
index a8f10e83..5de0e2e5 100644
--- a/dht/src/Control/Concurrent/PingMachine.hs
+++ b/server/src/Control/Concurrent/PingMachine.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TupleSections            #-}
 module Control.Concurrent.PingMachine where
 
 import Control.Monad
@@ -7,6 +8,7 @@ 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
diff --git a/dht/Presence/ControlMaybe.hs b/server/src/ControlMaybe.hs
index a101d667..a101d667 100644
--- a/dht/Presence/ControlMaybe.hs
+++ b/server/src/ControlMaybe.hs
diff --git a/dht/Presence/DNSCache.hs b/server/src/DNSCache.hs
index 9bb354e1..f539c71f 100644
--- a/dht/Presence/DNSCache.hs
+++ b/server/src/DNSCache.hs
@@ -8,9 +8,10 @@
 -- 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 TupleSections #-}
-{-# LANGUAGE RankNTypes    #-}
-{-# LANGUAGE CPP           #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE TupleSections            #-}
 module DNSCache
     ( DNSCache
     , reverseResolve
diff --git a/dht/src/Data/TableMethods.hs b/server/src/Data/TableMethods.hs
index e4208a69..e4208a69 100644
--- a/dht/src/Data/TableMethods.hs
+++ b/server/src/Data/TableMethods.hs
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/dht/Presence/GetHostByAddr.hs b/server/src/GetHostByAddr.hs
index 45bca5e9..068fc93d 100644
--- a/dht/Presence/GetHostByAddr.hs
+++ b/server/src/GetHostByAddr.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 module GetHostByAddr where
 
 import Network.BSD
diff --git a/dht/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs
index 20e7ecf0..20e7ecf0 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/server/src/Network/QueryResponse.hs
diff --git a/dht/src/Network/QueryResponse/TCP.hs b/server/src/Network/QueryResponse/TCP.hs
index 0028a5b6..8b1b432b 100644
--- a/dht/src/Network/QueryResponse/TCP.hs
+++ b/server/src/Network/QueryResponse/TCP.hs
@@ -1,13 +1,15 @@
 {-# 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)
+import GHC.Conc                  (labelThread,forkIO)
+import ForkLabeled
 #endif
 
 import Control.Arrow
diff --git a/dht/src/Network/SocketLike.hs b/server/src/Network/SocketLike.hs
index 37891cfd..37891cfd 100644
--- a/dht/src/Network/SocketLike.hs
+++ b/server/src/Network/SocketLike.hs
diff --git a/dht/src/Network/StreamServer.hs b/server/src/Network/StreamServer.hs
index 1da612ce..1da612ce 100644
--- a/dht/src/Network/StreamServer.hs
+++ b/server/src/Network/StreamServer.hs
diff --git a/dht/Presence/SockAddr.hs b/server/src/SockAddr.hs
index b5fbf16e..b5fbf16e 100644
--- a/dht/Presence/SockAddr.hs
+++ b/server/src/SockAddr.hs