Factor out some new libraries

	word64-map:
		Data.Word64Map
	network-addr:
		Network.Address
	tox-crypto:
		Crypto.Tox
	lifted-concurrent:
		Control.Concurrent.Lifted.Instrument
		Control.Concurrent.Async.Lifted.Instrument
	psq-wrap:
		Data.Wrapper.PSQInt
		Data.Wrapper.PSQ
	minmax-psq:
		Data.MinMaxPSQ
        tasks:
                Control.Concurrent.Tasks
	kad:
		Network.Kademlia
		Network.Kademlia.Bootstrap
		Network.Kademlia.Routing
		Network.Kademlia.CommonAPI
		Network.Kademlia.Persistence
		Network.Kademlia.Search

7 files changed, 198 insertions, 0 deletions

diff --git a/lifted-concurrent/CHANGELOG.md b/lifted-concurrent/CHANGELOG.md
new file mode 100644
index 00000000..3915e1ca
--- /dev/null
+++ b/lifted-concurrent/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for lifted-concurrent
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/lifted-concurrent/LICENSE b/lifted-concurrent/LICENSE
new file mode 100644
index 00000000..e8eaef49
--- /dev/null
+++ b/lifted-concurrent/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2019, James Crayne
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of James Crayne nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/lifted-concurrent/Setup.hs b/lifted-concurrent/Setup.hs
new file mode 100644
index 00000000..9a994af6
--- /dev/null
+++ b/lifted-concurrent/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/lifted-concurrent/lifted-concurrent.cabal b/lifted-concurrent/lifted-concurrent.cabal
new file mode 100644
index 00000000..3d8acba7
--- /dev/null
+++ b/lifted-concurrent/lifted-concurrent.cabal
@@ -0,0 +1,34 @@
+-- Initial lifted-concurrent.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                lifted-concurrent
+version:             0.1.0.0
+-- synopsis:
+-- description:
+license:             BSD3
+license-file:        LICENSE
+author:              James Crayne
+maintainer:          jim.crayne@gmail.com
+-- copyright:
+-- category:
+build-type:          Simple
+extra-source-files:  CHANGELOG.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:
+          Control.Concurrent.Lifted.Instrument
+        , Control.Concurrent.Async.Lifted.Instrument
+  other-modules: DebugTag
+  other-extensions:    FlexibleContexts
+  build-depends:
+          base
+        , containers
+        , time
+        , lifted-async
+        , dput-hslogger
+        , lifted-base
+        , monad-control
+        , transformers-base
+  hs-source-dirs:      src
+  default-language:    Haskell2010
diff --git a/lifted-concurrent/src/Control/Concurrent/Async/Lifted/Instrument.hs b/lifted-concurrent/src/Control/Concurrent/Async/Lifted/Instrument.hs
new file mode 100644
index 00000000..eab0fadc
--- /dev/null
+++ b/lifted-concurrent/src/Control/Concurrent/Async/Lifted/Instrument.hs
@@ -0,0 +1,5 @@
+module Control.Concurrent.Async.Lifted.Instrument
+    ( module Control.Concurrent.Async.Lifted
+    ) where
+
+import Control.Concurrent.Async.Lifted
diff --git a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs
new file mode 100644
index 00000000..fc3b6369
--- /dev/null
+++ b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Control.Concurrent.Lifted.Instrument
+    ( module Control.Concurrent.Lifted
+    , forkIO
+    , forkOS
+    , fork
+    , labelThread
+    , threadsInformation
+    , PerThread(..)
+    ) where
+
+import qualified Control.Concurrent.Lifted as Raw
+import Control.Concurrent.Lifted hiding (fork,forkOS)
+import Control.Exception (fromException)
+import Control.Monad.Trans.Control
+import System.IO.Unsafe
+import qualified Data.Map.Strict  as Map
+import Control.Exception.Lifted
+import Control.Monad.Base
+import qualified GHC.Conc as GHC
+import Data.Time()
+import Data.Time.Clock
+import DPut
+import DebugTag
+
+
+data PerThread = PerThread
+ { lbl :: String
+ , startTime :: UTCTime
+ }
+ deriving (Eq,Ord,Show)
+
+data GlobalState = GlobalState
+ { threads :: !(Map.Map ThreadId PerThread)
+ , reportException :: String -> IO ()
+ }
+
+globals :: MVar GlobalState
+globals = unsafePerformIO $ newMVar $ GlobalState
+    { threads = Map.empty
+    , reportException = dput XMisc
+    }
+{-# NOINLINE globals #-}
+
+
+forkIO :: IO () -> IO ThreadId
+forkIO = instrumented GHC.forkIO
+{-# INLINE forkIO #-}
+
+forkOS :: MonadBaseControl IO m => m () -> m ThreadId
+forkOS = instrumented Raw.forkOS
+{-# INLINE forkOS #-}
+
+fork :: MonadBaseControl IO m => m () -> m ThreadId
+fork = instrumented Raw.fork
+{-# INLINE fork #-}
+
+instrumented :: MonadBaseControl IO m =>
+                (m () -> m ThreadId) -> m () -> m ThreadId
+instrumented rawFork action = do
+    t <- rawFork $ do
+        tid <- myThreadId
+        tm <- liftBase getCurrentTime
+        bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm))
+                 (return ())
+            $ do catch action $ \e -> case fromException e of
+                    Just ThreadKilled -> return ()
+                    Nothing           -> liftBase $ do
+                        g <- takeMVar globals
+                        let l = concat [ show e
+                                       , " ("
+                                       , maybe "" lbl $ Map.lookup tid (threads g)
+                                       , ")"
+                                       ]
+                        reportException g l
+                        putMVar globals $! g { threads = Map.insert tid (PerThread l tm) $ threads g }
+                        throwIO e
+                 -- Remove the thread only if it terminated normally or was killed.
+                 modifyThreads $! Map.delete tid
+    return t
+
+labelThread :: ThreadId -> String -> IO ()
+labelThread tid s = do
+    GHC.labelThread tid s
+    modifyThreads $! Map.adjust (\pt -> pt { lbl = s }) tid
+{-# INLINE labelThread #-}
+
+threadsInformation :: IO [(ThreadId,PerThread)]
+threadsInformation = do
+    m <- threads <$> readMVar globals
+    return $ Map.toList m
+
+
+modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m ()
+modifyThreads f = do
+    g <- takeMVar globals
+    let f' st = st { threads = f (threads st) }
+    putMVar globals $! f' g
diff --git a/lifted-concurrent/src/DebugTag.hs b/lifted-concurrent/src/DebugTag.hs
new file mode 100644
index 00000000..9ac04bb0
--- /dev/null
+++ b/lifted-concurrent/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)