162 files changed, 29695 insertions, 0 deletions

diff --git a/.ackrc b/.ackrc
new file mode 100644
index 00000000..dc0f9689
--- /dev/null
+++ b/.ackrc
@@ -0,0 +1,2 @@
+--ignore-dir=res
+--ignore-dir=sub
diff --git a/.gitattributes b/.gitattributes
new file mode 100644
index 00000000..a8a88417
--- /dev/null
+++ b/.gitattributes
@@ -0,0 +1 @@
+res/* binary
diff --git a/.gitignore b/.gitignore
index 6fabf46f..2c40503c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,18 @@
+nohup.out
+
+dist
+cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
+tmp
+data
+upload-docs
+*.torrent
+*.aux
+*.eventlog
+*.hp
+*.pdf
+*.ps
+*.prof
+res/rtorrent-sessiondir
 /.stack-work/
diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/.gitmodules
diff --git a/.mailmap b/.mailmap
new file mode 100644
index 00000000..55e6f926
--- /dev/null
+++ b/.mailmap
@@ -0,0 +1,2 @@
+Sam Truzjan <pxqr.sta@gmail.com>
+Sam Truzjan <sta.cs.vsu@gmail.com>
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 00000000..3130bc52
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,35 @@
+language: haskell
+
+ghc:
+  - 7.6
+
+before_install:
+  - sudo apt-get install rtorrent screen
+  - rtorrent -h | grep version
+  - screen --version || true
+
+install:
+  - cabal sandbox init
+  - ./dev/update-dependencies.sh
+
+script:
+  - cabal configure && cabal build
+  - cabal configure -ftesting --enable-tests --enable-benchmark && cabal build && ./dist/build/spec/spec
+
+notifications:
+  email:
+    on_success: never
+    on_failure: change
+
+  irc:
+    channels:
+      - "chat.freenode.net#haskell-bittorrent"
+    on_success: change
+    on_failure: change
+
+    use_notice: true
+    template:
+      - "%{repository}#%{build_number} : %{message} for about %{duration}"
+      - "Commit:  %{branch}/%{commit} by %{author}"
+      - "Changes: %{compare_url}"
+      - "Build:   %{build_url}"
\ No newline at end of file
diff --git a/Announcer.hs b/Announcer.hs
new file mode 100644
index 00000000..668e00c2
--- /dev/null
+++ b/Announcer.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE NondecreasingIndentation   #-}
+module Announcer
+    ( Announcer
+    , AnnounceKey
+    , packAnnounceKey
+    , unpackAnnounceKey
+    , AnnounceMethod(..)
+    , forkAnnouncer
+    , stopAnnouncer
+    , schedule
+    , cancel
+    ) where
+
+import qualified Data.MinMaxPSQ as MM
+import Data.Wrapper.PSQ         as PSQ
+import InterruptibleDelay
+import Network.Kademlia.Routing as R
+import Network.Kademlia.Search
+
+import Control.Concurrent.Lifted.Instrument
+import Control.Concurrent.STM
+import Control.Monad
+import Data.ByteString                      (ByteString)
+import qualified Data.ByteString.Char8      as Char8
+import Data.Function
+import Data.Hashable
+import Data.Maybe
+import Data.Ord
+import Data.Time.Clock.POSIX
+
+newtype AnnounceKey = AnnounceKey ByteString
+ deriving (Hashable,Ord,Eq)
+
+packAnnounceKey :: Announcer -> String -> STM AnnounceKey
+packAnnounceKey _ = return . AnnounceKey . Char8.pack
+
+unpackAnnounceKey :: AnnounceKey -> AnnounceKey -> STM String
+unpackAnnounceKey _ (AnnounceKey bs) = return $ Char8.unpack bs
+
+data ScheduledItem
+    = StopAnnouncer
+    | NewAnnouncement (STM (IO ())) (IO ()) (IO ()) POSIXTime
+    | SearchFinished (IO ()) (IO ()) POSIXTime
+    | Announce (STM (IO ())) (IO ()) POSIXTime
+    | DeleteAnnouncement
+
+data Announcer = Announcer
+    { scheduled       :: TVar (PSQ' AnnounceKey POSIXTime ScheduledItem)
+    , announcerActive :: TVar Bool
+    , interrutible    :: InterruptibleDelay
+    }
+
+announceK :: Int
+announceK = 8
+
+data AnnounceState = forall nid addr tok ni r. AnnounceState
+    { aState        :: SearchState nid addr tok ni r
+    , aStoringNodes :: TVar (MM.MinMaxPSQ ni (Down POSIXTime))
+    }
+
+scheduleImmediately :: Announcer -> AnnounceKey -> ScheduledItem -> STM ()
+scheduleImmediately announcer k item
+    = modifyTVar' (scheduled announcer) (PSQ.insert' k item 0)
+
+stopAnnouncer :: Announcer -> IO ()
+stopAnnouncer announcer = do
+    atomically $ scheduleImmediately announcer (AnnounceKey "*stop*") StopAnnouncer
+    interruptDelay (interrutible announcer)
+    atomically $ readTVar (announcerActive announcer) >>= check . not
+
+data AnnounceMethod r = forall nid ni sr addr tok a.
+                        ( Show nid
+                        , Hashable nid
+                        , Hashable ni
+                        , Ord addr
+                        , Ord nid
+                        , Ord ni
+                        ) => AnnounceMethod
+    { aSearch  :: Search nid addr tok ni sr
+    , aPublish :: r -> tok -> Maybe ni -> IO (Maybe a)
+    , aBuckets :: TVar (R.BucketList ni)
+    , aTarget  :: nid
+    , aInterval :: POSIXTime
+    }
+
+schedule :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
+schedule announcer k AnnounceMethod{aSearch,aPublish,aBuckets,aTarget,aInterval} r = do
+    st <- atomically $ newSearch aSearch aTarget []
+    ns <- atomically $ newTVar MM.empty
+    let astate = AnnounceState st ns
+        publishToNodes is = do
+            forM_ is $ \(Binding ni mtok _) -> do
+            forM_ mtok $ \tok -> do
+                got <- aPublish r tok (Just ni)
+                now <- getPOSIXTime
+                forM_ got $ \_ -> do
+                    atomically $ modifyTVar ns $ MM.insertTake announceK ni (Down now)
+        announce = do -- publish to current search results
+            is <- atomically $ do
+                bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
+                return $ MM.toList bs
+            publishToNodes is
+        onResult _ = return True -- action for each search-hit (True = keep searching)
+        searchAgain = searchIsFinished st >>= \isfin -> return $ when isfin $ void $ fork search
+        search  = do -- thread to fork
+            atomically $ reset aBuckets aSearch aTarget st
+            searchLoop aSearch aTarget onResult st
+            fork $ do -- Announce to any nodes we haven't already announced to.
+                is <- atomically $ do
+                    bs <- readTVar (searchInformant st {- :: TVar (MinMaxPSQ' ni nid tok -})
+                    nq <- readTVar ns
+                    return $ filter (\(Binding ni _ _) -> not $ isJust $ MM.lookup' ni nq)
+                           $ MM.toList bs
+                publishToNodes is
+            return ()
+            {-
+            atomically $ scheduleImmediately announcer k
+                         $ SearchFinished {- st -} search announce aInterval
+            interruptDelay (interrutible announcer)
+            -}
+    atomically $ scheduleImmediately announcer k $ NewAnnouncement searchAgain search announce aInterval
+    interruptDelay (interrutible announcer)
+
+cancel :: Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
+cancel announcer k _ _ = do
+    atomically $ scheduleImmediately announcer k $ DeleteAnnouncement
+    interruptDelay (interrutible announcer)
+
+forkAnnouncer :: IO Announcer
+forkAnnouncer = do
+    delay <- interruptibleDelay
+    announcer <- atomically $ Announcer <$> newTVar PSQ.empty
+                                        <*> newTVar True
+                                        <*> pure delay
+    fork $ announceThread announcer
+    return announcer
+
+
+announceThread :: Announcer -> IO ()
+announceThread announcer = do
+    myThreadId >>= flip labelThread "announcer"
+    fix $ \loop -> do
+    join $ atomically $ do
+        item <- maybe retry return =<< findMin <$> readTVar (scheduled announcer)
+        return $ do
+        now <- getPOSIXTime
+        -- Is it time to do something?
+        if (prio item < now)
+            then do -- Yes.  Dequeue and handle this event.
+                 action <- atomically $ do
+                     modifyTVar' (scheduled announcer)
+                                 (PSQ.delete (key item))
+                     performScheduledItem announcer now item
+                 -- Are we finished?
+                 mapM_ (>> loop)  -- No? Okay, perform scheduled op and loop.
+                       action
+            else do -- No.  Wait a bit.
+                 startDelay (interrutible announcer) (microseconds $ prio item - now)
+                 loop
+    -- We're done.  Let 'stopAnnouncer' know that it can stop blocking.
+    atomically $ writeTVar (announcerActive announcer) False
+
+performScheduledItem :: Announcer -> POSIXTime -> Binding' AnnounceKey POSIXTime ScheduledItem -> STM (Maybe (IO ()))
+performScheduledItem announcer now = \case
+
+    (Binding _ StopAnnouncer _) ->  return Nothing
+
+    -- announcement started:
+    (Binding k (NewAnnouncement checkFin search announce interval) _) -> do
+        modifyTVar (scheduled announcer)
+                   (PSQ.insert' k (Announce checkFin announce interval) (now + interval))
+        return $ Just $ void $ fork search
+
+    -- announcement removed:
+    (Binding k DeleteAnnouncement _) -> return $ Just $ return ()
+
+    -- time for periodic announce:
+    --   (re-)announce to the current known set of storing-nodes.
+    --   TODO: If the search is finished, restart the search.
+    (Binding k (Announce checkFin announce interval) _) -> do
+        isfin <- checkFin
+        modifyTVar (scheduled announcer)
+                   (PSQ.insert' k (Announce checkFin announce interval) (now + interval))
+        return $ Just $ do
+            isfin
+            announce
+
+    -- search finished:
+    --   if any of the current storing-nodes set have not been
+    --   announced to, announce to them.
+    (Binding _ (SearchFinished {- st -} search announce interval) _) -> return $ Just $ return ()
+
+
+
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 00000000..60a1006c
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,115 @@
+2014-02-19  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc 0.6.0.0
+
+        API changes:
+
+        * Added isActive: this predicate can be used to implement
+        MonadActive instance and useful for resource
+        initialization/finalization sanity check.
+
+2014-01-08  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc 0.6.0.0: Logging + exceptions.
+
+        API changes:
+
+        * MonadLogger is superclass of MonadKRPC;
+        * KError hidden from Network.KRPC;
+        * HandlerFailure added;
+        * QueryFailure and getQueryCount added.
+
+2013-12-25  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc 0.5.0.0: Major API changes.
+
+        * Added transaction handling;
+        * Use the same socket for server and client;
+        * New query function will infer query method from request/response
+        datatypes.
+        * Added MonadKRPC and KRPC classes.
+
+2013-11-26  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.4.1.1: Fixed build failure on GHC == 7.4.*
+
+2013-11-25  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        bittorrent
+
+        * Version 0.0.0.3
+        * use Pretty class from pretty-class package;
+        * Data.Torrent.Client.hs:
+        * /tests/: fixed;
+
+2013-11-21  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        bittorrent
+
+        Version 0.0.0.2
+
+        * InfoHash.hs: added rendering to Text.
+        * Torrent.hs:  added pretty printing and content type.
+        * Magnet.hs:   added constructors from Torrent datatype.
+        * New:         added Data.Torrent.Client, Data.Torrent.Progress,
+        Network.Bittorrent.Core.PeerId, Network.BitTorrent.PeerAddr
+        modules.
+
+2013-11-01  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        bittorrent
+
+        Initial version: 0.0.0.1
+
+2013-10-17  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.4.1.0: Use bencoding-0.4.*
+
+2013-10-03  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.4.0.1: Minor documentation fixes.
+
+2013-10-03  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.4.0.0: IPv6 support.
+
+2013-09-28  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.3.0.0: Use bencoding-0.3.*
+        * Rename Remote.* to Network.* modules.
+
+2013-09-28  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.2.2.0: Use bencoding-0.2.2.*
+
+2013-08-27  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.2.0.0: Async API have been removed, use /async/ package
+        instead.
+        * Expose caller address in handlers.
+
+2013-07-09  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.1.1.0: Allow passing raw argument\/result dictionaries.
+
+2013-07-09  Sam Truzjan  <pxqr.sta@gmail.com>
+
+        krpc
+
+        * 0.1.0.0: Initial version.
diff --git a/InterruptibleDelay.hs b/InterruptibleDelay.hs
new file mode 100644
index 00000000..d59ec8ef
--- /dev/null
+++ b/InterruptibleDelay.hs
@@ -0,0 +1,41 @@
+module InterruptibleDelay where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Exception ({-evaluate,-}handle,ErrorCall(..))
+import Data.Time.Clock (NominalDiffTime)
+
+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
+
+startDelay :: InterruptibleDelay -> Microseconds -> IO Bool
+startDelay d interval = do
+    thread <- myThreadId
+    handle (\(ErrorCall _)-> do
+                debugNoise $ "delay interrupted"
+                return False) $ do 
+        putMVar (delayThread d) thread
+        threadDelay interval
+        void $ takeMVar (delayThread d)
+        return True
+
+  where debugNoise str = return ()
+
+
+interruptDelay :: InterruptibleDelay -> IO ()
+interruptDelay d = do
+    mthread <- do
+        tryTakeMVar (delayThread d)
+    flip (maybe $ return ()) mthread $ \thread -> do
+    throwTo thread (ErrorCall "Interrupted delay")
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 00000000..4c30139e
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Sam Truzjan
+
+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 Sam Truzjan 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/Makefile b/Makefile
new file mode 100644
index 00000000..e2eba85f
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,6 @@
+.PHONY: clean
+
+clean:
+        rm -rf tmp
+        rm *.aux *.eventlog *.ps *.hp *.pdf
+        cabal clean
\ No newline at end of file
diff --git a/OnionRouter.hs b/OnionRouter.hs
new file mode 100644
index 00000000..20279c5d
--- /dev/null
+++ b/OnionRouter.hs
@@ -0,0 +1,451 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE LambdaCase #-}
+module OnionRouter where
+
+import Control.Concurrent.Lifted.Instrument
+import Crypto.Tox
+import Network.Address
+import Network.Kademlia
+import Network.Kademlia.Routing
+import Network.QueryResponse
+import Network.Tox.NodeId
+import Network.Tox.Onion.Transport
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.PubKey.Curve25519
+import Crypto.Random
+import Data.Bits
+import qualified Data.ByteString     as B
+import Data.Hashable
+import qualified Data.HashMap.Strict as HashMap
+         ;import Data.HashMap.Strict (HashMap)
+import qualified Data.IntMap         as IntMap
+         ;import Data.IntMap         (IntMap)
+import Data.Maybe
+import qualified Data.Serialize      as S
+import Data.Typeable
+import Data.Word
+import qualified Data.Word64Map      as W64
+         ;import Data.Word64Map      (Word64Map, fitsInInt)
+import Network.Socket
+import System.Endian
+import System.Timeout
+
+-- Toxcore saves a maximum of 12 paths: 6 paths are reserved for announcing
+-- ourselves and 6 others are used to search for friends.
+--
+-- Note: This is pointless because a man-in-the-middle attack currently makes
+-- it trivial to glean friend relationships: the storing node can swap the
+-- published to-route key with his own giving him access to one layer of
+-- encryption and thus the real public key of the sender. TODO:
+-- Counter-measures.
+--
+-- Unlike toxcore, we don't currently reserve paths for only-searching or
+-- only-announcing.  Instead, we maintain 12 multi-purpose routes.
+data OnionRouter = OnionRouter
+    { -- | For every query, we remember the destination and source keys
+      -- so we can decrypt the response.  Note, the RouteId field is not
+      -- currently stored here.  It is inferred from the destination NodeId.
+      -- Instead, a 'Nothing' is stored.
+      pendingQueries  :: TVar (Word64Map (OnionDestination RouteId))
+      -- | The current 12 routes that may be assigned to outgoing packets.
+    , routeMap        :: TVar (IntMap RouteRecord)
+      -- | A set of nodes used to query for random route nodes. These aren't
+      -- used directly in onion routes, they are queried for route nodes that
+      -- are nearby randomly selected ids.
+      --
+      -- These nodes are chosen from the kademlia buckets and when one of them
+      -- is evicted from a bucket, it is no longer used as a trampoline node.
+      --
+      -- Also, currently our own address is (unnecessarily) stored here at
+      -- index (-1).
+    , trampolineNodes :: TVar (IntMap NodeInfo)
+      -- | This map associates 'NodeId' values with the corresponding
+      -- 'trampolineNodes' index.
+    , trampolineIds   :: TVar (HashMap NodeId Int)
+      -- | Indicates the current size of 'trampolineNodes'.
+    , trampolineCount :: TVar Int
+      -- | The pseudo-random generator used to select onion routes.
+    , onionDRG        :: TVar ChaChaDRG
+      -- | Building onion routes happens in a dedicated thread. See 'forkRouteBuilder'.
+    , routeThread     :: ThreadId
+      -- | Each of the 12 routes has a flag here that is set True when the
+      -- route should be discarded and replaced with a fresh one.
+    , pendingRoutes   :: IntMap (TVar Bool)
+      -- | Debug prints are written to this channel which is then flushed to
+      -- 'routeLogger'.
+    , routeLog        :: TChan String
+      -- | User supplied log function.
+    , routeLogger     :: String -> IO ()
+    }
+
+data RouteRecord = RouteRecord
+    { storedRoute   :: OnionRoute
+    , responseCount :: !Int
+    , timeoutCount  :: !Int
+    }
+
+-- Onion paths have different timeouts depending on whether the path is
+-- confirmed or unconfirmed. Unconfirmed paths (paths that core has never
+-- received any responses from) have a timeout of 4 seconds with 2 tries before
+-- they are deemed non working. This is because, due to network conditions,
+-- there may be a large number of newly created paths that do not work and so
+-- trying them a lot would make finding a working path take much longer. The
+-- timeout for a confirmed path (from which a response was received) is 10
+-- seconds with 4 tries without a response. A confirmed path has a maximum
+-- lifetime of 1200 seconds to make possible deanonimization attacks more
+-- difficult.
+timeoutForRoute :: RouteRecord -> Int
+timeoutForRoute RouteRecord{ responseCount = 0 } = 4000000
+timeoutForRoute RouteRecord{ responseCount = _ } = 10000000
+
+freshRoute :: OnionRoute -> RouteRecord
+freshRoute r = RouteRecord
+    { storedRoute = r
+    , responseCount = 0
+    , timeoutCount = 0
+    }
+
+gotResponse :: RouteRecord -> RouteRecord
+gotResponse rr = rr
+    { responseCount = succ $ responseCount rr
+    , timeoutCount = 0
+    }
+
+gotTimeout :: RouteRecord -> RouteRecord
+gotTimeout rr = rr
+    { timeoutCount = succ $ timeoutCount rr
+    }
+
+data RouteEvent = BuildRoute RouteId
+
+newOnionRouter :: (String -> IO ()) -> IO OnionRouter
+newOnionRouter perror = do
+    drg0 <- drgNew
+    or <- atomically $ do
+        chan <- newTChan
+        drg <- newTVar drg0
+        forM_ [0..11] $ \n -> writeTChan chan $ BuildRoute (RouteId n)
+        pq <- newTVar W64.empty
+        rm <- newTVar IntMap.empty
+        tn <- newTVar IntMap.empty
+        ti <- newTVar HashMap.empty
+        tc <- newTVar 0
+        vs <- sequence $ replicate 12 (newTVar True)
+        rlog <- newTChan
+        return OnionRouter
+            { pendingRoutes = IntMap.fromList $ zip [0..11] vs
+            , onionDRG = drg
+            , pendingQueries = pq
+            , routeMap = rm
+            , trampolineNodes = tn
+            , trampolineIds = ti
+            , trampolineCount = tc
+            , routeLog = rlog
+            , routeThread = error "Failed to invoke forkRouteBuilder"
+            , routeLogger = perror
+            }
+    return or
+
+forkRouteBuilder :: OnionRouter -> (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> IO OnionRouter
+forkRouteBuilder or getnodes = do
+    tid <- forkIO $ do
+        me <- myThreadId
+        labelThread me "OnionRouter"
+        forever $ do
+            let checkRebuild rid want_build stm = flip orElse stm $ do
+                    readTVar want_build >>= check
+                    -- This was moved to handleEvent to allow retry on fail.
+                    -- writeTVar want_build False -- Prevent redundant BuildRoute events.
+                    return $ BuildRoute $ RouteId rid
+            io <- atomically $
+                   (readTChan (routeLog or) >>= return . routeLogger or)
+                `orElse`
+                   (IntMap.foldrWithKey checkRebuild retry (pendingRoutes or)
+                        >>= return . handleEvent getnodes or { routeThread = me })
+            io
+    return or { routeThread = tid }
+
+generateNodeId :: MonadRandom m => m NodeId
+generateNodeId = either (error "unable to make random nodeid")
+                        id
+                 . S.decode <$> getRandomBytes 32
+
+distinct3by :: Eq t => (a -> t) -> a -> a -> a -> Bool
+distinct3by f a b c = f a /= f b && f b /= f c && f c /= f a
+
+-- The two integer functions below take an [inclusive,inclusive] range.
+randomR :: (DRG g, Integral a) => (a, a) -> g -> (a, g)
+randomR (l,h) = randomIvalInteger (toInteger l, toInteger h)
+
+next :: DRG g => g -> (Int,g)
+next g = withDRG g $ do bs <- getRandomBytes $ if fitsInInt (Proxy :: Proxy Word64)
+                                                then 8
+                                                else 4
+                        either (return . error) return $ S.decode bs
+
+randomIvalInteger :: (DRG g, Num a) => (Integer, Integer) -> g -> (a, g)
+randomIvalInteger (l,h) rng
+ | l > h     = randomIvalInteger (h,l) rng
+ | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
+     where
+       (genlo, genhi) = (minBound :: Int, maxBound :: Int) -- genRange :: RandomGen g => g -> (Int, Int)
+       b = fromIntegral genhi - fromIntegral genlo + 1
+
+       -- Probabilities of the most likely and least likely result
+       -- will differ at most by a factor of (1 +- 1/q).  Assuming the RandomGen
+       -- is uniform, of course
+
+       -- On average, log q / log b more random values will be generated
+       -- than the minimum
+       q = 1000
+       k = h - l + 1
+       magtgt = k * q
+
+       -- generate random values until we exceed the target magnitude
+       f mag v g | mag >= magtgt = (v, g)
+                 | otherwise = v' `seq`f (mag*b) v' g' where
+                        (x,g') = next g -- next :: RandomGen g => g -> (Int, g)
+                        v' = (v * b + (fromIntegral x - fromIntegral genlo))
+
+selectTrampolines :: OnionRouter -> IO [NodeInfo]
+selectTrampolines or = do
+    myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+    atomically (selectTrampolines' or) >>= \case
+        Left ns -> do
+            -- atomically $ writeTChan (routeLog or)
+            routeLogger or $ unwords
+                ( "ONION Discarding insecure trampolines:" : (map (show . nodeAddr) ns) )
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines.sleep")
+            threadDelay 1000000
+            myThreadId >>= flip labelThread ("OnionRouter.selectTrampolines")
+            selectTrampolines or
+        Right ns -> do
+            myThreadId >>= flip labelThread ("OnionRouter")
+            return ns
+
+selectTrampolines' :: OnionRouter -> STM (Either [NodeInfo] [NodeInfo])
+selectTrampolines' or = do
+    cnt <- readTVar (trampolineCount or)
+    ts <- readTVar (trampolineNodes or)
+    drg0 <- readTVar (onionDRG or)
+    let (a, drg1) = randomR (0,cnt - 1) drg0
+        (b0, drg2) = randomR (0,cnt - 2) drg1
+        (c0, drg ) = randomR (0,cnt - 3) drg2
+        b | b0 < a    = b0
+          | otherwise = b0 + 1
+        c1 | c0 < a     = c0
+           | otherwise  = c0 + 1
+        c | c1 < b    = c1
+          | otherwise = c1 + 1
+        ns = mapMaybe (\n -> IntMap.lookup n ts) [a,b,c]
+    ns' <- case ns of
+            [an,bn,cn] | distinct3by nodeClass an bn cn
+                       -> return $ Right ns
+            _          -> return $ Left ns
+    writeTVar (onionDRG or) drg
+    return ns'
+
+handleEvent :: (NodeId -> NodeInfo -> IO (Maybe [NodeInfo])) -> OnionRouter -> RouteEvent -> IO ()
+handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
+    routeLogger or $ "ONION Rebuilding RouteId " ++ show rid
+    mb <- do
+        ts <- selectTrampolines or
+        join . atomically $ do
+        drg <- readTVar (onionDRG or)
+        [av,bv,cv] <- sequence $ replicate 3 (newTVar Nothing)
+        let (getr, drg') = withDRG drg $ do
+                asec <- generateSecretKey -- Three aliases
+                bsec <- generateSecretKey
+                csec <- generateSecretKey
+                aq <- generateNodeId -- Three queries
+                bq <- generateNodeId
+                cq <- generateNodeId
+                sel <- B.head <$> getRandomBytes 1 -- Three two-bit result selectors (6 bits)
+                let asel = sel .&. 0x3
+                    bsel = shiftR sel 2 .&. 0x3
+                    csel = shiftR sel 4 .&. 0x3
+                    sendq s q ni = fmap (listToMaybe . drop (fromIntegral s)) <$> getnodes q ni
+                    sendqs = do
+                        forkIO $ sendq asel aq (ts !! 0) >>= atomically . writeTVar av . Just
+                        forkIO $ sendq bsel bq (ts !! 1) >>= atomically . writeTVar bv . Just
+                        forkIO $ sendq csel cq (ts !! 2) >>= atomically . writeTVar cv . Just
+                        -- This timeout should be unnecessary... But I'm paranoid.
+                        -- Note: 10 seconds should be sufficient for typical get-nodes queries.
+                        tm <- timeout 20000000 $ atomically $ do -- Wait for all 3 results.
+                            rs <- catMaybes <$> sequence [readTVar av,readTVar bv,readTVar cv]
+                            case rs of [_,_,_] -> do
+                                                    return $ catMaybes $ catMaybes rs
+                                                    -- self <- IntMap.lookup (-1) <$> readTVar (trampolineNodes or)
+                                                    -- return $ maybe (catMaybes rs) (\x -> [x,x,x]) self
+                                       _       -> retry
+                        maybe (routeLogger or "ONION: Unexpected sendq timeout!" >> return [])
+                              return
+                              tm
+                return $ do
+                    myThreadId >>= flip labelThread ("OnionRouter.sendqs")
+                    nodes <- case ts of
+                        [_,_,_] -> sendqs
+                        _       -> return []
+                    myThreadId >>= flip labelThread ("OnionRouter")
+                    routeLogger or $ unlines
+                        [ "ONION trampolines:   " ++ show ts
+                        , "ONION query results: " ++ show nodes ]
+                    case nodes of
+                        [a,b,c] | distinct3by nodeClass a b c -> do
+                            atomically $ do
+                              writeTChan (routeLog or) $ unwords [ "ONION using route:"
+                                                                 , show $ nodeAddr a
+                                                                 , show $ nodeAddr b
+                                                                 , show $ nodeAddr c ]
+                            return $ Just OnionRoute
+                                { routeAliasA = asec
+                                , routeAliasB = bsec
+                                , routeAliasC = csec
+                                , routeNodeA = a
+                                , routeNodeB = b
+                                , routeNodeC = c
+                                }
+                        [a,b,c] -> do
+                            atomically $ writeTChan (routeLog or) $ unwords [ "ONION Discarding insecure route:", show $ nodeAddr a, show $ nodeAddr b, show $ nodeAddr c]
+                            return Nothing
+                        _ -> return Nothing
+        writeTVar (onionDRG or) drg'
+        return $ getr
+    atomically $ maybe (writeTVar (pendingRoutes or IntMap.! rid) True)
+                       (\r -> do modifyTVar' (routeMap or)
+                                             (IntMap.insert rid $ freshRoute r)
+                                 writeTVar (pendingRoutes or IntMap.! rid) False
+                                 )
+                       mb
+    case mb of
+        Just _  -> routeLogger or $ "ONION Finished RouteId " ++ show rid
+        Nothing -> routeLogger or $ "ONION Failed RouteId " ++ show rid
+
+lookupSender :: OnionRouter -> SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))
+lookupSender or saddr (Nonce8 w8) = do
+    result <- atomically $ do
+        ks <- readTVar (pendingQueries or)
+        let r = W64.lookup w8 ks
+        writeTChan (routeLog or) $ "ONION lookupSender " ++ unwords [show w8, "->", show r]
+        return r
+    return $ do
+        od <- result
+        let nid = nodeId $ onionNodeInfo od
+        ni <- either (const Nothing) Just $ nodeInfo nid saddr
+        Just (OnionDestination (onionAliasSelector od)
+                               ni
+                               (Just $ routeId nid))
+
+lookupRoute :: OnionRouter -> NodeInfo -> RouteId -> IO (Maybe OnionRoute)
+lookupRoute or ni (RouteId rid) = do
+    mb <- atomically $ IntMap.lookup rid <$> readTVar (routeMap or)
+    return $ storedRoute <$> mb
+
+lookupTimeout :: OnionRouter -> Nonce8 -> OnionDestination r -> STM (OnionDestination RouteId, Int)
+lookupTimeout or n8 (OnionDestination asel ni Nothing) = do
+    let RouteId rid = routeId (nodeId ni)
+    mrr <- IntMap.lookup rid <$> readTVar (routeMap or)
+    readTVar (routeMap or) >>= \rm -> writeTChan (routeLog or) $ "ONION lookupTimeout " ++ unwords [show rid,show (IntMap.keys rm)]
+    case mrr of
+        Just rr -> return ( OnionDestination asel ni (Just $ RouteId rid), timeoutForRoute rr)
+        Nothing -> return ( OnionDestination asel ni Nothing             , 0 )
+
+hookQueries :: OnionRouter -> (tid -> Nonce8)
+                           -> TransactionMethods d tid (OnionDestination r) x
+                           -> TransactionMethods d tid (OnionDestination r) x
+hookQueries or t8 tmethods = TransactionMethods
+    { dispatchRegister = \mvar od d -> do --  :: MVar x -> d -> STM (tid, d)
+        (tid,d') <- dispatchRegister tmethods mvar od d
+        let Nonce8 w8 = t8 tid
+            od' = case od of OnionDestination {} -> od { onionRouteSpec = Nothing }
+                             OnionToOwner a b    -> OnionToOwner a b -- Type cast.
+            ni = onionNodeInfo od
+        modifyTVar' (pendingQueries or) (W64.insert w8 od')
+        writeTChan (routeLog or) $ "ONION query add " ++ unwords [ show w8, ":=", show ni ]
+        return (tid,d')
+    , dispatchResponse = \tid x d -> do -- :: tid -> x -> d -> STM (d, IO ())
+        let Nonce8 w8 = t8 tid
+        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        forM_ mb $ \od -> do
+            let RouteId rid = routeId (nodeId (onionNodeInfo od))
+            modifyTVar' (routeMap or) (IntMap.adjust gotResponse rid)
+        writeTChan (routeLog or) $ "ONION query del " ++ show w8
+        dispatchResponse tmethods tid x d
+    , dispatchCancel = \tid d -> do -- :: tid -> d -> STM d
+        let Nonce8 w8 = t8 tid
+        mb <- W64.lookup w8 <$> readTVar (pendingQueries or)
+        modifyTVar' (pendingQueries or) (W64.delete w8)
+        forM_ mb $ \od -> do
+            let RouteId rid = routeId (nodeId (onionNodeInfo od))
+            modifyTVar' (routeMap or) (IntMap.adjust gotTimeout rid)
+            let expireRoute = writeTVar (pendingRoutes or IntMap.! rid) True
+            rr <- IntMap.lookup rid <$> readTVar (routeMap or)
+            case rr of
+                Just RouteRecord{ responseCount=0
+                                , timeoutCount = c } | c >= 2 -> expireRoute
+                Just RouteRecord{ timeoutCount = c } | c >= 4 -> expireRoute
+                _ -> return ()
+        writeTChan (routeLog or) $ "ONION query can " ++ show w8
+        dispatchCancel tmethods tid d
+    }
+
+
+hookBucketList :: KademliaSpace NodeId NodeInfo -> TVar (BucketList NodeInfo) ->  OnionRouter -> RoutingTransition NodeInfo -> STM ()
+hookBucketList kademlia bkts0 or (RoutingTransition ni Accepted) = do
+    s <- do
+        drg0 <- readTVar (onionDRG or)
+        bkts <- readTVar bkts0
+        let antibias = 2 ^ bucketNumber kademlia (nodeId ni) bkts
+            (s,drg)  = randomR (0,antibias - 1) drg0
+        writeTVar (onionDRG or) drg
+        do -- Store localhost as trampoline node (-1).
+           -- This is not used, but harmless.  I'm leaving it in for
+           -- testing purposes.
+           let self = (thisNode bkts) { nodeIP = read "127.0.0.1" }
+           modifyTVar' (trampolineNodes or) (IntMap.insert (-1) self)
+        return s
+    -- debias via stochastic filter
+    when (s == 0) $ do
+    ns <- readTVar (trampolineIds or)
+    case HashMap.lookup (nodeId ni) ns of
+        Just _ -> return ()
+        Nothing -> do
+            cnt <- readTVar (trampolineCount or)
+            writeTChan (routeLog or) $ "ONION trampoline Accepted " ++ unwords [show cnt, show ni]
+            modifyTVar' (trampolineIds or) (HashMap.insert (nodeId ni) cnt)
+            modifyTVar' (trampolineNodes or) (IntMap.insert cnt ni)
+            writeTVar (trampolineCount or) (succ cnt)
+hookBucketList _ _ or (RoutingTransition ni Stranger) = do
+    ns <- readTVar (trampolineIds or)
+    case HashMap.lookup (nodeId ni) ns of
+        Just n -> do writeTVar (trampolineIds or) (HashMap.delete (nodeId ni) ns)
+                     cnt <- pred <$> readTVar (trampolineCount or)
+                     writeTVar (trampolineCount or) cnt
+                     if n == cnt
+                        then modifyTVar' (trampolineNodes or) (IntMap.delete n)
+                        else do lastnode <- (IntMap.! cnt) <$> readTVar (trampolineNodes or)
+                                modifyTVar' (trampolineNodes or) (IntMap.insert n lastnode . IntMap.delete cnt)
+                     writeTChan (routeLog or) $ "ONION trampoline Stranger " ++ unwords [show n,show ni]
+        Nothing -> return ()
+hookBucketList _ _ _ _ = return () -- ignore Applicant event.
+
+newtype IPClass = IPClass Word32
+ deriving Eq
+
+ipkey :: IPClass -> Int
+ipkey (IPClass k) = fromIntegral k
+
+nodeClass :: NodeInfo -> IPClass
+nodeClass = ipClass. nodeAddr
+
+ipClass :: SockAddr -> IPClass
+ipClass= either ipClass' ipClass' . either4or6
+
+ipClass' :: SockAddr -> IPClass
+ipClass' (SockAddrInet _ addr)                = IPClass (fromBE32 addr .&. 0xFF000000)
+ipClass' (SockAddrInet6 _ _ (hiword,_,_,_) _) = IPClass hiword
+ipClass' _                                    = IPClass 0 -- unreachable.
diff --git a/Roster.hs b/Roster.hs
new file mode 100644
index 00000000..7c40e371
--- /dev/null
+++ b/Roster.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Roster where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.PubKey.Curve25519
+import qualified Data.HashMap.Strict as HashMap
+         ;import Data.HashMap.Strict (HashMap)
+import Data.Maybe
+import Network.Tox.DHT.Transport     as DHT
+import Network.Tox.NodeId
+import Network.Tox.Onion.Transport   as Onion
+import System.IO
+
+newtype Roster = Roster { accounts :: TVar (HashMap NodeId Account) }
+
+data Account = Account
+    { userSecret :: SecretKey                   -- local secret key
+    , contacts :: TVar (HashMap NodeId Contact) -- received contact info
+    }
+
+data Contact = Contact
+    { contactKeyPacket     :: Maybe (DHT.DHTPublicKey)
+    , contactFriendRequest :: Maybe (DHT.FriendRequest)
+    }
+
+mergeContact :: Contact -> Maybe Contact -> Maybe Contact
+mergeContact (Contact newk newf) (Just (Contact oldk oldf)) =
+    Just (Contact mergek mergef)
+ where
+    mergek = mplus oldk $ do
+        n <- newk
+        stamp <- fmap DHT.dhtpkNonce oldk `mplus` return minBound
+        guard (stamp <= DHT.dhtpkNonce n)
+        return n
+    mergef = mplus oldf newf
+mergeContact new Nothing = Just new
+
+newRoster :: IO Roster
+newRoster = atomically $ Roster <$> newTVar HashMap.empty
+
+newAccount :: SecretKey -> STM Account
+newAccount sk = Account sk <$> newTVar HashMap.empty
+
+addRoster :: Roster -> SecretKey -> STM ()
+addRoster (Roster as) sk = do
+    a <- newAccount sk
+    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
+
+delRoster :: Roster -> PublicKey -> STM ()
+delRoster (Roster as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
+
+updateRoster :: Roster -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
+updateRoster roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
+    hPutStrLn stderr "updateRoster!!!"
+    atomically $ do
+        as <- readTVar (accounts roster)
+        maybe (return ())
+              (updateAccount remoteUserKey omsg)
+              $ HashMap.lookup (key2id localUserKey) as
+
+
+updateAccount :: PublicKey -> Onion.OnionData -> Account -> STM ()
+updateAccount remoteUserKey (Onion.OnionDHTPublicKey dhtpk) acc = do
+    modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact (Just dhtpk) Nothing)
+                                               (key2id remoteUserKey)
+
+updateAccount remoteUserKey (Onion.OnionFriendRequest fr) acc = do
+    modifyTVar' (contacts acc) $ HashMap.alter (mergeContact $ Contact Nothing (Just fr))
+                                               (key2id remoteUserKey)
+
+dnsPresentation :: Roster -> STM String
+dnsPresentation (Roster accsvar) = do
+    accs <- readTVar accsvar
+    ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
+        cs <- readTVar cvar
+        return $
+            "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
+             ++ concatMap dnsPresentation1
+                          (mapMaybe (\(nid,m) -> ((,) nid) <$> contactKeyPacket m)
+                                    $ HashMap.toList cs)
+    return $ concat ms
+
+dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
+dnsPresentation1 (nid,dk) = unlines
+    [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ]
+    ]
+
+type LocalKey = NodeId
+type RemoteKey = NodeId
+
+friendRequests :: Roster -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
+friendRequests (Roster roster) = do
+    accs <- readTVar roster
+    forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
+        cs <- readTVar cvar
+        let remotes = mapMaybe (\(nid,m) -> ((,) nid) <$> contactFriendRequest m)
+                               $ HashMap.toList cs
+        return remotes
+
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 00000000..dbba5c8c
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,17 @@
+* configure travis
+* liftKRPC ::
+* add withRetries
+* bump version to 0.7.0.0
+
+* add issue: getQueryCount --> getRpcStats
+data Stats = Stats
+  { queryFailed    :: {-# UNPACK #-} !Int
+  , querySucceed   :: {-# UNPACK #-} !Int
+  , handlerFailed  :: {-# UNPACK #-} !Int
+  , handlerSucceed :: {-# UNPACK #-} !Int
+  , sentBytes      :: {-# UNPACK #-} !Int
+  , receivedBytes  :: {-# UNPACK #-} !Int
+  }
+
+* add asyncQuery :: SockAddr -> a -> m (Async a)
+* add queries :: [(SockAddr, a)] -> m [Either  a]
\ No newline at end of file
diff --git a/bittorrent/README.md b/bittorrent/README.md
new file mode 100644
index 00000000..32948896
--- /dev/null
+++ b/bittorrent/README.md
@@ -0,0 +1,78 @@
+### BitTorrent [![Build Status][1]][2]
+
+A [BitTorrent][0] library implementation. It allows to read/write
+torrent files, transfer data files, query trackers and DHT. The
+library is still in active development and have some subsystems
+partially implemented.
+
+For lastest released version and reference documentation see [hackage][3] page.
+
+[0]: http://bittorrent.org/beps/bep_0000.html
+[1]: https://travis-ci.org/cobit/bittorrent.png
+[2]: https://travis-ci.org/cobit/bittorrent
+[3]: http://hackage.haskell.org/package/bittorrent
+
+### Status
+
+The protocol has [many enchancements][bep-list]. This table keep track
+if a particular BEP is "todo", "in progress" or "complete":
+
+| BEP # | Title                                              | Status
+|:-----:|:--------------------------------------------------:|:-----------
+| 3     | [The BitTorrent Protocol Specification][bep3]      | [In progress][bep3-impl]
+| 4     | [Known Number Allocations][bep4]                   | [In progress][bep4-impl]
+| 5     | [DHT][bep5]                                        | [In progress][bep5-impl]
+| 6     | [Fast Extension][bep6]                             | [In progress][bep6-impl]
+| 7     | [IPv6 Tracker Extension][bep7]                     | [In progress][bep7-impl]
+| 9     | [Extension for Peers to Send Metadata Files][bep9] | [In progress][bep9-impl]
+| 10    | [Extension protocol][bep10]                        | [In progress][bep10-impl]
+| 12    | [Multitracker Metadata Extension][bep10]           | [In progress][bep12-impl]
+| 15    | [UDP Tracker Protocol for BitTorrent][bep15]       | [In progress][bep15-impl]
+| 20    | [Peer ID Conventions][bep20]                       | [Implemented][bep20-impl]
+| 23    | [Tracker Return Compact Peer Lists][bep23]         | [Implemented][bep23-impl]
+
+[bep-list]: http://www.bittorrent.org/beps/bep_0000.html
+[bep3]:  http://www.bittorrent.org/beps/bep_0003.html
+[bep4]:  http://www.bittorrent.org/beps/bep_0004.html
+[bep5]:  http://www.bittorrent.org/beps/bep_0005.html
+[bep6]:  http://www.bittorrent.org/beps/bep_0006.html
+[bep7]:  http://www.bittorrent.org/beps/bep_0007.html
+[bep9]:  http://www.bittorrent.org/beps/bep_0009.html
+[bep10]: http://www.bittorrent.org/beps/bep_0010.html
+[bep12]: http://www.bittorrent.org/beps/bep_0012.html
+[bep15]: http://www.bittorrent.org/beps/bep_0015.html
+[bep20]: http://www.bittorrent.org/beps/bep_0020.html
+[bep23]: http://www.bittorrent.org/beps/bep_0023.html
+
+[bep3-impl]:  src
+[bep4-impl]:  src/Network/BitTorrent/Exchange/Message.hs
+[bep5-impl]:  src/Network/BitTorrent/DHT/Protocol.hs
+[bep6-impl]:  src/Network/BitTorrent/Exchange/Message.hs
+[bep7-impl]:  src/Network/BitTorrent/Tracker/Message.hs
+[bep9-impl]:  src/Network/BitTorrent/Exchange/Wire.hs
+[bep10-impl]: src/Network/BitTorrent/Exchange/Message.hs
+[bep12-impl]: src/Data/Torrent.hs
+[bep15-impl]: src/Network/BitTorrent/Tracker/RPC/UDP.hs
+[bep20-impl]: src/Network/BitTorrent/Core/Fingerprint.hs
+[bep23-impl]: src/Network/BitTorrent/Tracker/Message.hs
+
+### Hacking
+
+The root directory layout is as follows:
+
+* examples -- includes demo utilities to get started;
+* src      -- the library source tree;
+* tests    -- the library test suite;
+* res      -- torrents and data files used in test suite.
+* sub      -- subprojects and submodules used by the library and still in dev.
+
+Some subdirectories includes README with futher explanations to get started.
+
+### Contacts
+
+* Discussions: IRC [#haskell-bittorrent][irc] at irc.freenode.net
+* Bugs & issues: [issue tracker][tracker]
+* Maintainer: <pxqr.sta@gmail.com>
+
+[tracker]: https://github.com/cobit/bittorrent/issues/new
+[irc]: http://webchat.freenode.net/?channels=haskell-bittorrent
diff --git a/bittorrent/Readme.md b/bittorrent/Readme.md
new file mode 100644
index 00000000..e092c3ad
--- /dev/null
+++ b/bittorrent/Readme.md
@@ -0,0 +1,8 @@
+Layout
+======
+
+| module group | can import       | main purpose            |
+|:-------------|:----------------:|:-----------------------:|
+| /Network     | /Data & /System  | peer and data exchange  |
+| /System      | /Data            | filesystem interface    |
+| /Data        |                  | torrent metadata        |
diff --git a/bittorrent/bench/Main.hs b/bittorrent/bench/Main.hs
new file mode 100644
index 00000000..f04485ab
--- /dev/null
+++ b/bittorrent/bench/Main.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS -fno-warn-orphans #-}
+module Main (main) where
+
+import Control.DeepSeq
+import Network
+import Control.Monad
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Criterion.Main
+import Data.ByteString as BS
+import Network.DatagramServer
+
+
+import Network.BitTorrent.Exchange.Protocol as BT
+import Data.Torrent.Block as BT
+import Data.Torrent.Bitfield as BT
+
+instance KRPC ByteString ByteString where
+  method = "echo"
+
+instance MonadLogger IO where
+  monadLoggerLog _ _ _ _ = return ()
+
+
+instance NFData PortNumber where
+  rnf = rnf . (fromIntegral :: PortNumber -> Int)
+
+instance NFData BlockIx where
+  rnf (BlockIx a b c) = a `deepseq` b `deepseq` rnf c
+
+instance NFData Block where
+  rnf (Block a b c) = a `deepseq` b `deepseq` rnf c
+
+instance NFData Bitfield
+
+instance NFData Message where
+  rnf (Have i)     = rnf i
+  rnf (Bitfield b) = rnf b
+  rnf (Request  b) = rnf b
+  rnf (Piece    b) = rnf b
+  rnf (Cancel   b) = rnf b
+  rnf (Port     i) = rnf i
+  rnf _ = ()  -- other fields are forced by pattern matching
+
+{-
+encodeMessages :: [Message] -> ByteString
+encodeMessages xs = runPut (mapM_ put xs)
+
+decodeMessages :: ByteString -> Either String [Message]
+decodeMessages = runGet (many get)
+-}
+
+echo :: Handler IO
+echo = handler $ \ _ bs -> return (bs :: ByteString)
+
+addr :: SockAddr
+addr = SockAddrInet 6000 (256 * 256 * 256 + 127)
+
+-- main :: IO ()
+-- main = defaultMain []
+main :: IO ()
+main = withManager def addr [echo] $ \ m -> (`runReaderT` m) $ do
+    listen
+    liftIO $ defaultMain (benchmarks m)
+  where
+    sizes        = [10, 100, 1000, 10000, 16 * 1024]
+    repetitions  = [1, 10, 100, 1000]
+    benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes]
+      where
+        mkbench action r n =
+          bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $
+            replicateM r $
+              runReaderT (query addr (BS.replicate n 0)) action
diff --git a/bittorrent/bench/Throughtput.hs b/bittorrent/bench/Throughtput.hs
new file mode 100644
index 00000000..d0404405
--- /dev/null
+++ b/bittorrent/bench/Throughtput.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE ViewPatterns  #-}
+{-# LANGUAGE PatternGuards #-}
+module Main (main) where
+
+import Control.Concurrent
+import Data.Bitfield
+import Network.BitTorrent
+import System.Environment
+import Control.Monad.Reader
+import Data.IORef
+
+
+main :: IO ()
+main = do
+  [path]  <- getArgs
+  torrent <- fromFile path
+
+  print (contentLayout "./" (tInfo torrent))
+
+  client  <- newClient 100 []
+  swarm   <- newLeecher  client torrent
+
+  ref <- liftIO $ newIORef 0
+  discover swarm $ do
+    forever $ do
+      e <- awaitEvent
+      case e of
+        Available bf
+          | Just m <- findMin bf -> yieldEvent (Want (BlockIx m 0 10))
+          |     otherwise        -> return ()
+        Want     bix -> liftIO $ print bix
+        Fragment blk -> do
+
+          sc <- liftIO $ getSessionCount swarm
+          addr <- asks connectedPeerAddr
+
+          liftIO $ do
+            x <- atomicModifyIORef ref (\x -> (succ x, x))
+            if x `mod` 100 == 0
+              then print (x, sc, addr)
+              else return ()
+
+          yieldEvent (Want (BlockIx 0 0 (16 * 1024)))
+
+
+  print "Bye-bye! =_="
\ No newline at end of file
diff --git a/bittorrent/bench/TorrentFile.hs b/bittorrent/bench/TorrentFile.hs
new file mode 100644
index 00000000..e91a9c10
--- /dev/null
+++ b/bittorrent/bench/TorrentFile.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE BangPatterns #-}
+module Main (main) where
+
+import Data.BEncode
+import Data.ByteString as BS
+import Data.Torrent
+import Criterion.Main
+
+
+tinyPath :: FilePath
+tinyPath = "res/dapper-dvd-amd64.iso.torrent"
+
+largePath :: FilePath
+largePath = "res/pkg.torrent"
+
+decoder :: ByteString -> Torrent
+decoder bs = let Right r = decode bs in r
+
+main :: IO ()
+main = do
+  !tinyBin  <- BS.readFile tinyPath
+  !largeBin <- BS.readFile largePath
+
+  defaultMain
+    [ bench "read/tiny"  $ nf decoder tinyBin
+    , bench "read/large" $ nf decoder largeBin
+    ]
\ No newline at end of file
diff --git a/bittorrent/bittorrent.cabal b/bittorrent/bittorrent.cabal
new file mode 100644
index 00000000..8ec314e7
--- /dev/null
+++ b/bittorrent/bittorrent.cabal
@@ -0,0 +1,412 @@
+name:                  bittorrent
+version:               0.0.0.3
+license:               BSD3
+license-file:          LICENSE
+author:                Sam Truzjan
+maintainer:            Sam Truzjan <pxqr.sta@gmail.com>
+copyright:             (c) 2013, Sam Truzjan
+category:              Network
+build-type:            Custom
+cabal-version:         >= 1.10
+tested-with:           GHC == 7.6.3
+homepage:              https://github.com/cobit/bittorrent
+bug-reports:           https://github.com/cobit/bittorrent/issues
+synopsis:              BitTorrent protocol implementation.
+description:
+
+  A library for making Haskell bittorrent applications easy.
+  .
+  For more information see:
+  <https://github.com/cobit/bittorrent/blob/master/README.md>
+
+extra-source-files:    res/dapper-dvd-amd64.iso.torrent
+                       res/pkg.torrent
+                       README.md
+                       ChangeLog
+                       cbits/*.h
+
+
+source-repository head
+  type:                git
+  location:            git://github.com/cobit/bittorrent.git
+
+source-repository this
+  type:                git
+  location:            git://github.com/cobit/bittorrent.git
+  branch:              master
+  tag:                 v0.0.0.3
+
+flag testing
+  description:         Whether to build tests.
+  default:             False
+
+flag examples
+  description:         Whether to build examples.
+  default:             False
+
+flag network-uri
+  description:         Use network-uri package.
+  default:             True
+
+flag bits-extras
+  description:         Use more-effecient bits-extras bitwise operations.
+  default:             False
+
+flag dht-only
+  description:         Build only DHT related modules.
+  default:             True
+
+flag builder
+  description: Use older bytestring package and bytestring-builder.
+  default: False
+
+flag aeson
+  description: Use aeson for pretty-printing bencoded data.
+  default: True
+
+flag thread-debug
+  description: Add instrumentation to threads.
+  default: True
+
+library
+  default-language:    Haskell2010
+  default-extensions:  PatternGuards
+                     , OverloadedStrings
+                     , RecordWildCards
+  hs-source-dirs:      src, cryptonite-backport, .
+  exposed-modules:  Network.SocketLike
+                    Data.Digest.CRC32C
+                    Data.Bits.ByteString
+                    Data.Wrapper.PSQ
+                    Data.Wrapper.PSQInt
+                    Data.MinMaxPSQ
+                    Network.Address
+                    Network.Kademlia.Routing
+                    Data.Torrent
+                    Network.BitTorrent.DHT.ContactInfo
+                    Network.BitTorrent.DHT.Token
+                    Network.Kademlia.Search
+                    Network.QueryResponse
+                    Network.StreamServer
+                    Data.BEncode.Pretty
+                    Control.Concurrent.Tasks
+                    Network.Kademlia
+                    Network.BitTorrent.MainlineDHT
+                    System.Global6
+                    Network.Tox
+                    Network.Tox.Transport
+                    Network.Tox.Crypto.Transport
+                    Network.Tox.Onion.Handlers
+                    Network.Tox.Onion.Transport
+                    Network.Tox.DHT.Handlers
+                    Network.Tox.DHT.Transport
+                    Network.Tox.NodeId
+                    Control.TriadCommittee
+                    Crypto.Tox
+                    Text.XXD
+
+  build-depends:      base
+                    , containers
+                    , array
+                    , hashable
+                    , iproute
+                    , stm
+                    , base16-bytestring
+                    , base32-bytestring
+                    , base64-bytestring
+                    , psqueues
+                    , reflection
+                    , deepseq
+                    , text
+                    , filepath
+                    , directory
+                    , bencoding
+                    , contravariant
+
+                    , cryptonite
+                    , memory
+                    , time
+                    , random
+                    , entropy
+                    , cpu
+
+                    , cereal
+                    , http-types
+
+                    , process
+                    , split
+                    , pretty
+                    , convertible
+                    , data-default
+
+                    , bifunctors
+                    , lens
+                    , lifted-async
+                    , lifted-base
+                    , monad-control
+                    , transformers-base
+                    , mtl
+
+  if flag(network-uri)
+      Build-depends:  network      >= 2.6
+                    , network-uri  >= 2.6
+  else
+      Build-depends:  network      >= 2.4 && < 2.6
+
+
+  other-modules:       Paths_bittorrent
+                       Crypto.Cipher.Salsa
+                       Crypto.Cipher.XSalsa
+                       Crypto.ECC.Class
+                       Crypto.ECC.Simple.Prim
+                       Crypto.ECC.Simple.Types
+                       Crypto.Error.Types
+                       Crypto.Internal.ByteArray
+                       Crypto.Internal.Compat
+                       Crypto.Internal.DeepSeq
+                       Crypto.Internal.Imports
+                       Crypto.PubKey.Curve25519
+
+  C-sources:           cbits/cryptonite_xsalsa.c, cbits/cryptonite_salsa.c
+
+  if !flag(dht-only)
+     exposed-modules:  Network.BitTorrent
+                       Network.BitTorrent.Client
+                       Network.BitTorrent.Client.Types
+                       Network.BitTorrent.Client.Handle
+                       Network.BitTorrent.Exchange
+                       Network.BitTorrent.Exchange.Bitfield
+                       Network.BitTorrent.Exchange.Block
+                       Network.BitTorrent.Exchange.Connection
+                       Network.BitTorrent.Exchange.Download
+                       Network.BitTorrent.Exchange.Manager
+                       Network.BitTorrent.Exchange.Message
+                       Network.BitTorrent.Exchange.Session
+                       Network.BitTorrent.Tracker
+                       Network.BitTorrent.Tracker.List
+                       Network.BitTorrent.Tracker.Message
+                       Network.BitTorrent.Tracker.RPC
+                       Network.BitTorrent.Tracker.RPC.HTTP
+                       Network.BitTorrent.Tracker.RPC.UDP
+                       Network.BitTorrent.Tracker.Session
+                       System.Torrent.Storage
+  if !flag(dht-only)
+    if flag(testing)
+      exposed-modules:
+                       Network.BitTorrent.Internal.Cache
+                       Network.BitTorrent.Internal.Progress
+                       Network.BitTorrent.Internal.Types
+                       System.Torrent.FileMap
+                       System.Torrent.Tree
+    else
+      other-modules:
+                       Network.BitTorrent.Internal.Cache
+                       Network.BitTorrent.Internal.Progress
+                       Network.BitTorrent.Internal.Types
+                       System.Torrent.FileMap
+                       System.Torrent.Tree
+  if flag(aeson)
+    build-depends: aeson, aeson-pretty, unordered-containers, vector
+    cpp-options:   -DBENCODE_AESON
+  if flag(thread-debug)
+    exposed-modules: Control.Concurrent.Lifted.Instrument
+                     Control.Concurrent.Async.Lifted.Instrument
+    cpp-options:   -DTHREAD_DEBUG
+
+  if flag(builder)
+    build-depends: bytestring >= 0.9, bytestring-builder
+  else
+    build-depends: bytestring >= 0.10
+  if impl(ghc < 7.6)
+    build-depends:     ghc-prim
+  ghc-options:         -Wall -fdefer-typed-holes
+  ghc-prof-options:
+
+
+test-suite spec
+  if !flag(testing)
+    buildable:         False
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      tests
+  main-is:             Main.hs
+  other-modules:       Spec
+                       Config
+                       Network.KRPCSpec
+                       Network.KRPC.MethodSpec
+                       Network.DatagramServer.MainlineSpec
+                       Data.TorrentSpec
+                       Network.BitTorrent.Client.HandleSpec
+                       Network.BitTorrent.CoreSpec
+                       Network.BitTorrent.DHTSpec
+                       Network.BitTorrent.DHT.TestData
+                       Network.BitTorrent.DHT.MessageSpec
+                       Network.BitTorrent.DHT.QuerySpec
+                       Network.Kademlia.RoutingSpec
+                       Network.BitTorrent.DHT.SessionSpec
+                       Network.BitTorrent.DHT.TokenSpec
+                       Network.BitTorrent.Internal.CacheSpec
+                       Network.BitTorrent.Internal.ProgressSpec
+                       Network.BitTorrent.Tracker.TestData
+                       Network.BitTorrent.Tracker.ListSpec
+                       Network.BitTorrent.Tracker.MessageSpec
+                       Network.BitTorrent.Tracker.RPCSpec
+                       Network.BitTorrent.Tracker.RPC.HTTPSpec
+                       Network.BitTorrent.Tracker.RPC.UDPSpec
+                       Network.BitTorrent.Tracker.SessionSpec
+                       Network.BitTorrent.Exchange.BitfieldSpec
+                       Network.BitTorrent.Exchange.ConnectionSpec
+                       Network.BitTorrent.Exchange.DownloadSpec
+                       Network.BitTorrent.Exchange.MessageSpec
+                       Network.BitTorrent.Exchange.SessionSpec
+                       System.Torrent.StorageSpec
+                       System.Torrent.FileMapSpec
+  build-depends:       base == 4.*
+
+                       -- * Concurrency
+                     , async
+
+                       -- * Data
+                     , bytestring
+                     , bytestring-arbitrary
+                     , containers
+                     , convertible
+                     , data-default
+                     , text
+                     , time
+
+                       -- * Serialization
+                     , cereal
+
+                       -- * Monads
+                     , mtl
+                     , resourcet
+                     , conduit
+                     , conduit-extra
+                     , monad-loops
+                     , monad-logger
+
+                       -- * Network
+                     , http-types
+                     , iproute
+
+                       -- * System
+                     , optparse-applicative >= 0.8
+                     , process
+                     , directory
+                     , filepath
+
+                       -- * Testing
+                     , hspec >= 1.8.2
+                     , QuickCheck
+                     , quickcheck-instances
+
+                       -- * Bittorrent
+                     , bittorrent
+                     , temporary
+                     , bencoding         >= 0.4.3
+  if flag(network-uri)
+    Build-depends:     network      >= 2.6
+                     , network-uri  >= 2.6
+  else
+    Build-depends:     network      >= 2.4 && < 2.6
+  ghc-options:         -Wall -fno-warn-orphans
+
+
+--benchmark bench
+--  default-language:    Haskell2010
+--  default-extensions:
+--  type:                exitcode-stdio-1.0
+--  hs-source-dirs:      bench
+--  main-is:             Main.hs
+--  build-depends:       base
+--                     , bytestring
+--                     , cereal
+--                     , network
+--
+--                     , criterion
+--                     , deepseq
+--
+--                     , bittorrent
+--  ghc-options:         -O2 -Wall -fno-warn-orphans
+benchmark bench
+  type:                exitcode-stdio-1.0
+  default-language:    Haskell2010
+  hs-source-dirs:      bench
+  main-is:             Main.hs
+  build-depends:       base == 4.*
+                     , bytestring
+                     , mtl
+                     , monad-logger
+                     , criterion
+  ghc-options:         -O2 -fforce-recomp
+
+executable dht
+  hs-source-dirs:      examples
+  main-is:             dht.hs
+  default-language:    Haskell2010
+  build-depends:       base, haskeline, network, bytestring, transformers
+
+executable dhtd
+  hs-source-dirs:      examples
+  main-is:             dhtd.hs
+  default-language:    Haskell2010
+  build-depends:       base, network, bytestring, hashable, deepseq
+                     , aeson
+                     , pretty
+                     , bittorrent
+                     , unix
+                     , containers
+                     , stm
+                     , cereal
+                     , bencoding
+  if flag(thread-debug)
+    build-depends: time
+    cpp-options:   -DTHREAD_DEBUG
+
+-- Utility to work with torrent files.
+executable mktorrent
+  if !flag(examples)
+    buildable:         False
+  default-language:    Haskell2010
+  hs-source-dirs:      examples
+  main-is:             MkTorrent.hs
+  other-modules:       Paths_bittorrent
+  build-depends:       base == 4.*
+                     , bytestring
+                     , text
+                     , pretty
+
+                     , mtl
+                     , conduit
+                     , lens
+                     , lifted-async
+                     , parallel-io
+
+                     , bittorrent
+
+                     , filepath
+                     , optparse-applicative
+                     , hslogger
+--  if flag(network-uri)
+--    Build-depends:
+                     , network      >= 2.6
+                     , network-uri  >= 2.6
+--  else
+--    Build-depends:     network      >= 2.4 && < 2.6
+  ghc-options:         -Wall -O2 -threaded
+
+-- nonfunctioning example of very basic bittorrent client
+executable client
+  if !flag(examples)
+    buildable:         False
+  default-language:    Haskell2010
+  hs-source-dirs:      examples
+  main-is:             Client.hs
+  build-depends:       base        == 4.*
+                     , bittorrent
+                     , mtl
+                     , pretty
+                     , data-default
+                     , optparse-applicative
diff --git a/bittorrent/dev/README.md b/bittorrent/dev/README.md
new file mode 100644
index 00000000..e2cc51a6
--- /dev/null
+++ b/bittorrent/dev/README.md
@@ -0,0 +1,4 @@
+This directory is for some dev scripts and other dev only stuff which
+we don't want to keep in the resulting `cabal sdist` generated
+tarball. Do _not_ include any of these files to .cabal file, neither
+to `extra-source-files` nor to `data-files` sections.
diff --git a/bittorrent/dev/add-sources.sh b/bittorrent/dev/add-sources.sh
new file mode 100755
index 00000000..e125cade
--- /dev/null
+++ b/bittorrent/dev/add-sources.sh
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+for s in $(ls $(dirname $0)/../sub); do
+    (cd $(dirname $0)/.. && cabal sandbox add-source sub/$s)
+done
diff --git a/bittorrent/dev/bench b/bittorrent/dev/bench
new file mode 100755
index 00000000..5d03db3f
--- /dev/null
+++ b/bittorrent/dev/bench
@@ -0,0 +1,4 @@
+#!/bin/sh
+cabal-dev build &&
+    ./dist/build/benchmarks/benchmarks -o dist/build/benchmarks/result.html &&
+    xdg-open dist/build/benchmarks/result.html
\ No newline at end of file
diff --git a/bittorrent/dev/test b/bittorrent/dev/test
new file mode 100755
index 00000000..2eb85df2
--- /dev/null
+++ b/bittorrent/dev/test
@@ -0,0 +1,2 @@
+#!/bin/sh
+cabal-dev build && cabal-dev test || echo "ERROR: Some tests failed."
diff --git a/bittorrent/dev/update-dependencies.sh b/bittorrent/dev/update-dependencies.sh
new file mode 100755
index 00000000..c83694c3
--- /dev/null
+++ b/bittorrent/dev/update-dependencies.sh
@@ -0,0 +1,11 @@
+#!/bin/sh
+
+cd $(dirname $0)/..
+
+git submodule init
+git submodule foreach git fetch
+git submodule update --recursive --checkout --force
+
+$(dirname $0)/add-sources.sh
+
+cabal install --enable-tests --only-dependencies --reinstall
diff --git a/bittorrent/examples/Client.hs b/bittorrent/examples/Client.hs
new file mode 100644
index 00000000..26711676
--- /dev/null
+++ b/bittorrent/examples/Client.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RecordWildCards           #-}
+module Main (main) where
+import Control.Concurrent
+import Control.Monad.Trans
+import Data.Maybe
+import Options.Applicative
+import System.Environment
+import System.Exit
+import System.IO
+import Text.Read
+
+import Network.BitTorrent
+
+#if MIN_VERSION_optparse_applicative(0,13,0)
+-- maybeReader imported from Options.Applicative.Builder
+#elif MIN_VERSION_optparse_applicative(0,11,0)
+maybeReader f = eitherReader (maybe (Left ":(") Right . f)
+#else
+maybeReader f = f
+#endif
+
+{-----------------------------------------------------------------------
+--  Command line arguments
+-----------------------------------------------------------------------}
+
+data TorrentBox = forall s. TorrentSource s => TorrentBox { unTorrentBox :: s }
+
+data Args = Args
+  { topic       :: TorrentBox
+  , contentDir  :: FilePath
+  }
+
+argsParser :: Parser Args
+argsParser = Args <$> (TorrentBox <$> infohashP <|> TorrentBox <$> torrentP)
+                  <*> destDirP
+  where
+    infohashP :: Parser InfoHash
+    infohashP = argument (maybeReader readMaybe)
+                (metavar "SHA1"     <> help "infohash of torrent file")
+
+    torrentP :: Parser FilePath
+    torrentP  = argument (maybeReader Just)
+                ( metavar "FILE"
+               <> help    "A .torrent file"
+                )
+
+    destDirP :: Parser FilePath
+    destDirP  = argument (maybeReader Just)
+                ( metavar "DIR"
+               <> help    "Directory to put content"
+                )
+
+argsInfo :: ParserInfo Args
+argsInfo = info (helper <*> argsParser)
+   ( fullDesc
+  <> progDesc "A simple CLI bittorrent client"
+  <> header   "foo"
+   )
+
+{-----------------------------------------------------------------------
+--  Client
+-----------------------------------------------------------------------}
+
+run :: Args -> BitTorrent ()
+run (Args (TorrentBox t) dir)  = do
+  h <- openHandle dir t
+  start h
+  liftIO $ threadDelay 10000000000
+
+main :: IO ()
+main = execParser argsInfo >>= simpleClient . run
diff --git a/bittorrent/examples/FS.hs b/bittorrent/examples/FS.hs
new file mode 100644
index 00000000..550d85a7
--- /dev/null
+++ b/bittorrent/examples/FS.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RecordWildCards #-}
+module Main (main) where
+
+import Control.Arrow
+import Data.ByteString.Char8 as BC
+import Data.List as L
+import Data.Map as M
+import Data.Torrent as T
+import Data.Torrent.Tree as T
+import System.Environment
+import System.Fuse
+import System.FilePath
+import System.Posix.Files
+
+
+defStat :: FileStat
+defStat = FileStat
+  { statEntryType        = Unknown
+  , statFileMode         = ownerReadMode
+  , statLinkCount        = 2
+
+  , statFileOwner        = 0
+  , statFileGroup        = 0
+
+  , statSpecialDeviceID  = 0
+
+  , statFileSize         = 0
+  , statBlocks           = 0
+
+  , statAccessTime       = 0
+  , statModificationTime = 0
+  , statStatusChangeTime = 0
+  }
+
+dirStat :: FileStat
+dirStat = defStat {
+    statEntryType = Directory
+  }
+
+type Result a = IO (Either Errno a)
+type Result'  = IO Errno
+
+fsGetFileStat :: Torrent -> FilePath -> Result FileStat
+fsGetFileStat _ path = return $ Right dirStat
+
+fsOpenDirectory :: Torrent -> FilePath -> Result'
+fsOpenDirectory _ _ = return eOK
+
+fsReadDirectory :: Torrent -> FilePath -> Result [(FilePath, FileStat)]
+fsReadDirectory Torrent {tInfoDict = InfoDict {..}} path
+    | Just cs <- T.lookupDir (L.tail (splitDirectories path)) tree =
+      return $ Right $ L.map (BC.unpack *** const defStat) cs
+    | otherwise = return $ Left eNOENT
+  where
+    tree = build $ idLayoutInfo
+
+fsReleaseDirectory :: Torrent -> FilePath -> Result'
+fsReleaseDirectory _ _ = return eOK
+
+exfsOps :: Torrent -> FuseOperations ()
+exfsOps t = defaultFuseOps
+  { fuseGetFileStat        = fsGetFileStat t
+
+  , fuseOpenDirectory      = fsOpenDirectory t
+  , fuseReadDirectory      = fsReadDirectory t
+  , fuseReleaseDirectory   = fsReleaseDirectory t
+  }
+
+main :: IO ()
+main = do
+  x : xs <- getArgs
+  t <- fromFile x
+  withArgs xs $ do
+    fuseMain (exfsOps t) defaultExceptionHandler
\ No newline at end of file
diff --git a/bittorrent/examples/MkTorrent.hs b/bittorrent/examples/MkTorrent.hs
new file mode 100644
index 00000000..88a84893
--- /dev/null
+++ b/bittorrent/examples/MkTorrent.hs
@@ -0,0 +1,500 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS -fno-warn-orphans   #-}
+module Main (main) where
+
+import Prelude as P
+import Control.Concurrent
+import Control.Concurrent.Async.Lifted
+import Control.Concurrent.ParallelIO
+import Control.Exception
+import Control.Lens hiding (argument, (<.>))
+import Control.Monad as M
+import Control.Monad.Trans
+import Data.Conduit as C
+import Data.Conduit.List as C
+import Data.List as L
+import Data.Maybe as L
+import Data.Monoid
+import Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Text.Read as T
+import Data.Version
+import Network
+import Network.URI
+import Options.Applicative
+import System.Exit
+import System.FilePath
+import System.Log
+import System.Log.Logger
+import Text.Read
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+
+import Paths_bittorrent (version)
+import Data.Torrent hiding (Magnet (Magnet))
+import Network.Address
+import Network.BitTorrent.DHT.Session hiding (Options, options)
+import Network.BitTorrent.DHT as DHT  hiding (Options)
+import Network.BitTorrent.Exchange.Bitfield as BF
+import Network.BitTorrent.Exchange.Connection hiding (Options)
+import Network.BitTorrent.Exchange.Message
+import Network.BitTorrent.Exchange.Session
+import System.Torrent.Storage
+
+#if MIN_VERSION_optparse_applicative(0,13,0)
+-- maybeReader imported from Options.Applicative.Builder
+#elif MIN_VERSION_optparse_applicative(0,11,0)
+maybeReader f = eitherReader (maybe (Left ":(") Right . f)
+#else
+maybeReader f = f
+#endif
+
+
+{-----------------------------------------------------------------------
+--  Dialogs
+-----------------------------------------------------------------------}
+
+instance Read URI where
+  readsPrec _ = f . parseURI
+    where
+      f Nothing  = []
+      f (Just u) = [(u, "")]
+
+question :: Show a => Text -> Maybe a -> IO ()
+question q defVal = do
+  T.putStrLn q
+  case defVal of
+    Nothing -> return ()
+    Just v  -> T.putStrLn $ "[default: " <> T.pack (show v) <> "]"
+
+ask :: Read a => Text -> IO a
+ask q = question q (Just True) >> getReply
+  where
+    getReply = do
+      resp <- P.getLine
+      maybe getReply return $ readMaybe resp
+
+askMaybe :: Read a => Text -> IO (Maybe a)
+askMaybe q = question q (Just False) >> getReply
+  where
+    getReply = do
+      resp <- P.getLine
+      if resp == []
+        then return Nothing
+        else maybe getReply return $ readMaybe resp
+
+askURI :: IO URI
+askURI = do
+  s <- P.getLine
+  case parseURI s of
+    Nothing -> T.putStrLn "incorrect URI" >> askURI
+    Just u  -> return u
+
+askFreeform :: IO Text
+askFreeform = do
+  s <- T.getLine
+  if T.null s
+    then askFreeform
+    else return s
+
+askInRange :: Int -> Int -> IO Int
+askInRange a b = do
+  s <- T.getLine
+  case T.decimal s of
+    Left msg -> do
+      P.putStrLn msg
+      askInRange a b
+    Right (i, _)
+      | a <= i && i < b -> return i
+      |     otherwise   -> do
+        T.putStrLn "not in range "
+        askInRange a b
+
+askChoice :: [(Text, a)] -> IO a
+askChoice kvs = do
+  forM_ (L.zip [1 :: Int ..] $ L.map fst kvs) $ \(i, lbl) -> do
+    T.putStrLn $ "  " <> T.pack (show i) <> ") " <> lbl
+  T.putStrLn "Your choice?"
+  n <- askInRange 1 (succ (L.length kvs))
+  return $ snd (kvs !! pred n)
+
+{-----------------------------------------------------------------------
+--  Helpers
+-----------------------------------------------------------------------}
+
+torrentFile :: Parser FilePath
+torrentFile = argument (maybeReader Just)
+    ( metavar "TORRENT_FILE_PATH"
+   <> help    "A .torrent file"
+    )
+
+{-----------------------------------------------------------------------
+--  Amend command - edit a field of torrent file
+-----------------------------------------------------------------------}
+
+data AmendOpts = AmendOpts FilePath
+  deriving Show
+
+amendInfo :: ParserInfo AmendOpts
+amendInfo = info (helper <*> parser) modifier
+  where
+    modifier = progDesc "Edit info fields of existing torrent"
+    parser   = AmendOpts <$> torrentFile
+
+type Amend = Torrent -> Torrent
+
+fields :: [(Text, IO Amend)]
+fields = [ ("announce",      set announce     . Just <$> askURI)
+         , ("comment",       set comment      . Just <$> askFreeform)
+         , ("created by",    set createdBy    . Just <$> askFreeform)
+         , ("publisher url", set publisherURL . Just <$> askURI)
+         ]
+
+askAmend :: IO Amend
+askAmend = join $ T.putStrLn "Choose a field:" >> askChoice fields
+
+amend :: AmendOpts -> IO ()
+amend (AmendOpts tpath) = do
+  t <- fromFile tpath
+  a <- askAmend
+  toFile tpath $ a t
+
+{-----------------------------------------------------------------------
+--  Check command -- validate content files using torrent file
+-----------------------------------------------------------------------}
+-- TODO progress bar
+
+data CheckOpts = CheckOpts
+  { checkTorrentPath :: FilePath -- ^ validation torrent file
+  , checkContentPath :: FilePath -- ^ root dir for content files
+  } deriving Show
+
+checkInfo :: ParserInfo CheckOpts
+checkInfo = info (helper <*> parser) modifier
+  where
+    modifier = progDesc "Validate integrity of torrent data"
+        <> header   "append +RTS -N$NUMBER_OF_CORES -RTS for parallel execution"
+    parser   = CheckOpts
+      <$> torrentFile
+      <*> argument (maybeReader Just)
+          ( metavar "CONTENT_DIR_PATH"
+         <> value   "."
+         <> help    "Content directory or a single file"
+          )
+
+validatePiece :: Storage -> PieceInfo -> PieceIx -> IO (Maybe PieceIx)
+validatePiece s pinfo pix = do
+  valid <- verifyPiece s pinfo pix
+  if valid
+    then do infoM "check" $ "valid piece "   ++ show pix
+            return (Just pix)
+    else do infoM "check" $ "invalid piece " ++ show pix
+            return Nothing
+
+validateStorage :: Storage -> PieceInfo -> IO Bitfield
+validateStorage s pinfo = do
+  infoM "check" "start storage validation"
+  let total = totalPieces s
+  pixs <- parallel $ L.map (validatePiece s pinfo) [0 .. total - 1]
+  infoM "check" "storage validation finished"
+  return $ fromList total $ L.catMaybes pixs
+
+-- TODO use local thread pool
+checkContent :: Storage -> PieceInfo -> IO ()
+checkContent s pinfo = do
+  invalids <- BF.complement <$> validateStorage s pinfo
+  if BF.null invalids
+    then noticeM "check" "all files are complete and valid"
+    else do
+      emergencyM "check" $ "there are some invalid pieces" ++ show invalids
+      exitFailure
+
+checkTorrent :: CheckOpts -> IO ()
+checkTorrent CheckOpts {..} = do
+  infoM "check" "openning torrent file..."
+  InfoDict {..} <- tInfoDict <$> fromFile checkTorrentPath
+  let layout = flatLayout checkContentPath idLayoutInfo
+  infoM "check" "mapping content files..."
+  withStorage ReadOnly (piPieceLength idPieceInfo) layout $ \ s -> do
+    infoM "check" "files mapped"
+    checkContent s idPieceInfo
+    infoM "check" "unmapping files"
+
+{-----------------------------------------------------------------------
+--  Create command
+-----------------------------------------------------------------------}
+-- TODO progress bar
+-- TODO multifile torrents
+-- TODO interactive mode
+-- TODO non interactive mode
+-- TODO --ignore-dot-files
+-- TODO --md5
+-- TODO --piece-size
+
+{-
+createFlags :: Parser CreateFlags
+createFlags = CreateFlags
+    <$> optional (option
+      ( long    "piece-size"
+     <> short   's'
+     <> metavar "SIZE"
+     <> help    "Set size of torrent pieces"
+      ))
+    <*> switch
+      ( long    "md5"
+     <> short   '5'
+     <> help    "Include md5 hash of each file"
+      )
+    <*> switch
+      ( long    "ignore-dot-files"
+     <> short   'd'
+     <> help    "Do not include .* files"
+      )
+
+
+createOpts :: Parser CreateOpts
+createOpts = CreateOpts
+    <$> argument (maybeReader Just)
+        ( metavar "PATH"
+       <> help    "Content directory or a single file"
+        )
+    <*> optional (argument (maybeReader Just)
+        ( metavar "FILE"
+       <> help    "Place for the output .torrent file"
+        ))
+    <*> createFlags
+
+createInfo :: ParserInfo CreateOpts
+createInfo = info (helper <*> createOpts) modifier
+  where
+    modifier = progDesc "Make a new .torrent file"
+-}
+
+{-----------------------------------------------------------------------
+--  Magnet command -- print magnet link for given torrent file
+-----------------------------------------------------------------------}
+
+data MagnetOpts = MagnetOpts
+  { magnetFile :: FilePath -- ^ path to torrent file
+  , detailed   :: Bool     -- ^ whether to append additional uri params
+  } deriving Show
+
+magnetInfo :: ParserInfo MagnetOpts
+magnetInfo = info (helper <*> parser) modifier
+  where
+    modifier = progDesc "Print magnet link"
+    parser   = MagnetOpts
+      <$> torrentFile
+      <*> switch ( long "detailed" )
+
+magnet :: MagnetOpts -> IO ()
+magnet MagnetOpts {..} = print . magnetLink =<< fromFile magnetFile
+  where
+    magnetLink = if detailed then detailedMagnet else simpleMagnet
+
+{-----------------------------------------------------------------------
+--  Show command - print torrent file information
+-----------------------------------------------------------------------}
+
+data ShowOpts = ShowOpts
+  { showPath     :: FilePath -- ^ torrent file to inspect;
+  , infoHashOnly :: Bool     -- ^ omit everything except infohash.
+  } deriving Show
+
+showInfo :: ParserInfo ShowOpts
+showInfo = info (helper <*> parser) modifier
+  where
+    modifier = progDesc "Print .torrent file metadata"
+    parser   = ShowOpts
+      <$> torrentFile
+      <*> switch
+          ( long "infohash"
+         <> help "Show only hash of the torrent info part"
+          )
+
+showTorrent :: ShowOpts -> Torrent -> ShowS
+showTorrent ShowOpts {..} torrent
+  | infoHashOnly = shows $ idInfoHash (tInfoDict torrent)
+  |   otherwise  = shows $ pPrint torrent
+
+putTorrent :: ShowOpts -> IO ()
+putTorrent opts @ ShowOpts {..} = do
+    torrent <- fromFile showPath `onException` putStrLn msg
+    putStrLn $ showTorrent opts torrent []
+  where
+    msg = "Torrent file is either invalid or do not exist"
+
+{-----------------------------------------------------------------------
+--  Get command - fetch torrent by infohash
+-----------------------------------------------------------------------}
+
+data GetOpts = GetOpts
+  { topic    :: InfoHash
+  , servPort :: PortNumber
+  , bootNode :: NodeAddr IPv4
+  , buckets  :: Int
+  } deriving Show
+
+#if !MIN_VERSION_network(2,6,3)
+instance Read PortNumber where
+  readsPrec i s = [ (toEnum a, t) | (a, t) <- readsPrec i s]
+#endif
+
+paramsParser :: Parser GetOpts
+paramsParser = GetOpts
+  <$> argument (maybeReader readMaybe)
+             (metavar "SHA1"       <> help "infohash of torrent file")
+  <*> option auto (long    "port"  <> short 'p'
+                  <> value   7000  <> showDefault
+                  <> metavar "NUM" <> help "port number to bind"
+                  )
+  <*> option auto (long    "boot" <> short 'b'
+                <> metavar "NODE" <> help "bootstrap node address"
+                   )
+  <*> option auto (long    "bucket" <> short 'n'
+                  <> value 2        <> showDefault
+                  <> metavar "NUM"  <> help "number of buckets to maintain"
+                   )
+
+getInfo :: ParserInfo GetOpts
+getInfo = info (helper <*> paramsParser)
+   ( fullDesc
+  <> progDesc "Get torrent file by infohash"
+  <> header   "get torrent file by infohash"
+   )
+
+ -- TODO add tNodes, tCreated, etc?
+getTorrent :: GetOpts -> IO ()
+getTorrent GetOpts {..} = do
+  infoM "get" "searching for peers..."
+  s <- newSession (\ _ _ _ _ -> return ()) (PeerAddr Nothing Nothing 7000) "/tmp" (Left topic)
+  dht (def { optBucketCount = buckets }) (NodeAddr "0.0.0.0" servPort) $ do
+    bootstrap [bootNode]
+    infodict <- withAsync (DHT.lookup topic $$ connectSink s)
+                          (const (liftIO $ waitMetadata s))
+    liftIO $ toFile (show topic <.> torrentExt) $ nullTorrent infodict
+  infoM "get" "saved torrent file"
+
+{-----------------------------------------------------------------------
+--  Command
+-----------------------------------------------------------------------}
+
+data Command
+  = Amend  AmendOpts
+  | Check  CheckOpts
+--  | Create CreateOpts
+  | Get    GetOpts
+  | Magnet MagnetOpts
+  | Show   ShowOpts
+    deriving Show
+
+commandOpts :: Parser Command
+commandOpts = subparser $ mconcat
+    [ command "amend"  (Amend  <$> amendInfo)
+    , command "check"  (Check  <$> checkInfo)
+--    , command "create" (Create <$> createInfo)
+    , command "get"    (Get    <$> getInfo)
+    , command "magnet" (Magnet <$> magnetInfo)
+    , command "show"   (Show   <$> showInfo)
+    ]
+
+{-----------------------------------------------------------------------
+--  Global Options
+-----------------------------------------------------------------------}
+
+data GlobalOpts = GlobalOpts
+  { verbosity   :: Priority
+  } deriving Show
+
+#if !MIN_VERSION_hslogger(1,2,9)
+deriving instance Enum    Priority
+deriving instance Bounded Priority
+#endif
+
+priorities :: [Priority]
+priorities = [minBound..maxBound]
+
+defaultPriority :: Priority
+defaultPriority = WARNING
+
+verbosityOpts :: Parser Priority
+verbosityOpts = verbosityP <|> verboseP <|> quietP
+  where
+    verbosityP = option auto
+      ( long    "verbosity"
+     <> metavar "LEVEL"
+     <> help   ("Set verbosity level\n"
+             ++ "Possible values are " ++ show priorities)
+      )
+
+    verboseP = flag defaultPriority INFO
+      ( long    "verbose"
+     <> short   'v'
+     <> help    "Verbose mode"
+      )
+
+    quietP = flag defaultPriority CRITICAL
+      ( long    "quiet"
+     <> short   'q'
+     <> help    "Silent mode"
+      )
+
+
+globalOpts :: Parser GlobalOpts
+globalOpts = GlobalOpts <$> verbosityOpts
+
+data Options = Options
+  { cmdOpts  :: Command
+  , globOpts :: GlobalOpts
+  } deriving Show
+
+options :: Parser Options
+options = Options <$> commandOpts <*> globalOpts
+
+versioner :: String -> Version -> Parser (a -> a)
+#if MIN_VERSION_optparse_applicative(0,10,0)
+versioner prog ver = nullOption disabled $ mconcat
+#else
+versioner prog ver = nullOption $ mconcat
+#endif
+    [ long  "version"
+    , help  "Show program version and exit"
+    , value id
+    , metavar ""
+    , hidden
+    , mempty -- reader $ const $ undefined -- Left $ ErrorMsg versionStr
+    ]
+  where
+    versionStr = prog ++ " version " ++ showVersion ver
+
+parserInfo :: ParserInfo Options
+parserInfo = info parser modifier
+  where
+    parser   = helper <*> versioner "mktorrent" version <*> options
+    modifier = header synopsis <> progDesc description <> fullDesc
+    synopsis    = "Torrent management utility"
+    description = "" -- TODO
+
+{-----------------------------------------------------------------------
+--  Dispatch
+-----------------------------------------------------------------------}
+
+run :: Command -> IO ()
+run (Amend  opts) = amend opts
+run (Check  opts) = checkTorrent opts
+--run (Create opts) = createTorrent opts
+run (Get    opts) = getTorrent opts
+run (Magnet opts) = magnet opts
+run (Show   opts) = putTorrent opts
+
+prepare :: GlobalOpts -> IO ()
+prepare GlobalOpts {..} = do
+  updateGlobalLogger rootLoggerName (setLevel verbosity)
+
+main :: IO ()
+main = do
+  Options {..} <- execParser parserInfo
+  prepare globOpts
+  run cmdOpts
diff --git a/bittorrent/res/dapper-dvd-amd64.iso.torrent b/bittorrent/res/dapper-dvd-amd64.iso.torrent
new file mode 100644
index 00000000..5713344b
--- /dev/null
+++ b/bittorrent/res/dapper-dvd-amd64.iso.torrent
diff --git a/bittorrent/res/pkg.torrent b/bittorrent/res/pkg.torrent
new file mode 100644
index 00000000..be89e9e0
--- /dev/null
+++ b/bittorrent/res/pkg.torrent
diff --git a/bittorrent/res/testfile b/bittorrent/res/testfile
new file mode 100644
index 00000000..8e984818
--- /dev/null
+++ b/bittorrent/res/testfile
diff --git a/bittorrent/res/testfile.torrent b/bittorrent/res/testfile.torrent
new file mode 100644
index 00000000..297f56a2
--- /dev/null
+++ b/bittorrent/res/testfile.torrent
@@ -0,0 +1 @@
+d8:announce44:udp://tracker.openbittorrent.com:80/announce10:created by26:Enhanced-CTorrent/dnh3.3.213:creation datei1387753787e4:infod6:lengthi8192e4:name8:testfile12:piece lengthi262144e6:pieces20:
œd•Dú—uÈÔtÝ®aÿöK³2e5:nodesll21:router.bittorrent.comi6881eeee
\ No newline at end of file
diff --git a/bittorrent/src/Network/BitTorrent.hs b/bittorrent/src/Network/BitTorrent.hs
new file mode 100644
index 00000000..91a58887
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent.hs
@@ -0,0 +1,61 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent
+       ( -- * Client
+         Options (..)
+
+         -- ** Session
+       , Client
+       , clientPeerId
+       , clientListenerPort
+       , allowedExtensions
+
+         -- ** Initialization
+       , LogFun
+       , newClient
+       , closeClient
+       , withClient
+
+         -- ** Monadic
+       , MonadBitTorrent (..)
+       , BitTorrent
+       , runBitTorrent
+       , getClient
+       , simpleClient
+
+         -- * Torrent
+         -- ** Source
+       , InfoHash
+       , Magnet
+       , InfoDict
+       , Torrent
+
+         -- ** Handle
+       , Handle
+       , handleTopic
+       , handleTrackers
+       , handleExchange
+
+       , TorrentSource(openHandle)
+       , closeHandle
+       , getHandle
+       , getIndex
+
+         -- ** Control
+       , start
+       , pause
+       , stop
+
+         -- * Events
+       , EventSource (..)
+       ) where
+
+import Data.Torrent
+import Network.BitTorrent.Client
+import Network.BitTorrent.Internal.Types
\ No newline at end of file
diff --git a/bittorrent/src/Network/BitTorrent/Client.hs b/bittorrent/src/Network/BitTorrent/Client.hs
new file mode 100644
index 00000000..c84290dd
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Client.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+module Network.BitTorrent.Client
+       ( -- * Options
+         Options (..)
+
+         -- * Client session
+       , Client
+
+         -- ** Session data
+       , clientPeerId
+       , clientListenerPort
+       , allowedExtensions
+
+         -- ** Session initialization
+       , LogFun
+       , newClient
+       , closeClient
+       , withClient
+       , simpleClient
+
+         -- * BitTorrent monad
+       , MonadBitTorrent (..)
+       , BitTorrent
+       , runBitTorrent
+       , getClient
+
+         -- * Handle
+       , Handle
+       , handleTopic
+       , handleTrackers
+       , handleExchange
+
+         -- ** Construction
+       , TorrentSource (..)
+       , closeHandle
+
+         -- ** Query
+       , getHandle
+       , getIndex
+
+         -- ** Management
+       , start
+       , pause
+       , stop
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.Chan.Split as CS
+import Control.Monad.Logger
+import Control.Monad.Trans
+import Control.Monad.Trans.Resource
+
+import Data.Default
+import Data.HashMap.Strict as HM
+import Data.Text
+import Network
+
+import           Data.Torrent
+import           Network.Address
+import           Network.BitTorrent.Client.Types
+import           Network.BitTorrent.Client.Handle
+import           Network.BitTorrent.DHT      as DHT      hiding (Options)
+import           Network.BitTorrent.Tracker  as Tracker  hiding (Options)
+import           Network.BitTorrent.Exchange as Exchange hiding (Options)
+import qualified Network.BitTorrent.Exchange as Exchange (Options(..))
+
+
+data Options = Options
+  { optFingerprint :: Fingerprint
+  , optName        :: Text
+  , optPort        :: PortNumber
+  , optExtensions  :: [Extension]
+  , optNodeAddr    :: NodeAddr IPv4
+  , optBootNode    :: Maybe (NodeAddr IPv4)
+  }
+
+instance Default Options where
+  def = Options
+    { optFingerprint = def
+    , optName        = "hs-bittorrent"
+    , optPort        = 6882
+    , optExtensions  = []
+    , optNodeAddr    = "0.0.0.0:6882"
+    , optBootNode    = Nothing
+    }
+
+exchangeOptions :: PeerId -> Options -> Exchange.Options
+exchangeOptions pid Options {..} = Exchange.Options
+  { optPeerAddr = PeerAddr (Just pid) (peerHost def) optPort
+  , optBacklog  = optBacklog def
+  }
+
+connHandler :: MVar (HashMap InfoHash Handle) -> Exchange.Handler
+connHandler tmap ih = do
+  m <- readMVar tmap
+  case HM.lookup ih m of
+    Nothing            -> error "torrent not found"
+    Just (Handle {..}) -> return handleExchange
+
+initClient :: Options -> LogFun -> ResIO Client
+initClient opts @ Options {..} logFun = do
+  pid  <- liftIO genPeerId
+  tmap <- liftIO $ newMVar HM.empty
+
+  let peerInfo = PeerInfo pid Nothing optPort
+  let mkTracker = Tracker.newManager def peerInfo
+  (_, tmgr) <- allocate mkTracker Tracker.closeManager
+
+  let mkEx = Exchange.newManager (exchangeOptions pid opts) (connHandler tmap)
+  (_, emgr) <- allocate mkEx Exchange.closeManager
+
+  let mkNode = DHT.newNode defaultHandlers def optNodeAddr logFun Nothing
+  (_, node) <- allocate mkNode DHT.closeNode
+
+  resourceMap <- getInternalState
+  eventStream <- liftIO newSendPort
+
+  return Client
+    { clientPeerId       = pid
+    , clientListenerPort = optPort
+    , allowedExtensions  = toCaps optExtensions
+    , clientResources    = resourceMap
+    , trackerManager     = tmgr
+    , exchangeManager    = emgr
+    , clientNode         = node
+    , clientTorrents     = tmap
+    , clientLogger       = logFun
+    , clientEvents       = eventStream
+    }
+
+newClient :: Options -> LogFun -> IO Client
+newClient opts logFun = do
+  s <- createInternalState
+  runInternalState (initClient opts logFun) s
+    `onException` closeInternalState s
+
+closeClient :: Client -> IO ()
+closeClient Client {..} = closeInternalState clientResources
+
+withClient :: Options -> LogFun -> (Client -> IO a) -> IO a
+withClient opts lf action = bracket (newClient opts lf) closeClient action
+
+-- do not perform IO in 'initClient', do it in the 'boot'
+--boot :: BitTorrent ()
+--boot = do
+--  Options {..} <- asks options
+--  liftDHT $ bootstrap (maybeToList optBootNode)
+
+-- | Run bittorrent client with default options and log to @stderr@.
+--
+--   For testing purposes only.
+--
+simpleClient :: BitTorrent () -> IO ()
+simpleClient m = do
+  runStderrLoggingT $ LoggingT $ \ logger -> do
+    withClient def logger (`runBitTorrent` m)
+
+{-----------------------------------------------------------------------
+--  Torrent identifiers
+-----------------------------------------------------------------------}
+
+class TorrentSource s where
+  openHandle :: FilePath -> s -> BitTorrent Handle
+
+instance TorrentSource InfoHash where
+  openHandle path ih = openMagnet path (nullMagnet ih)
+  {-# INLINE openHandle #-}
+
+instance TorrentSource Magnet where
+  openHandle = openMagnet
+  {-# INLINE openHandle #-}
+
+instance TorrentSource InfoDict where
+  openHandle path dict = openTorrent path (nullTorrent dict)
+  {-# INLINE openHandle #-}
+
+instance TorrentSource Torrent where
+  openHandle = openTorrent
+  {-# INLINE openHandle #-}
+
+instance TorrentSource FilePath where
+  openHandle contentDir torrentPath = do
+    t <- liftIO $ fromFile torrentPath
+    openTorrent contentDir t
+  {-# INLINE openHandle #-}
+
+getIndex :: BitTorrent [Handle]
+getIndex = do
+  Client {..} <- getClient
+  elems <$> liftIO (readMVar clientTorrents)
diff --git a/bittorrent/src/Network/BitTorrent/Client/Handle.hs b/bittorrent/src/Network/BitTorrent/Client/Handle.hs
new file mode 100644
index 00000000..66baac48
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Client/Handle.hs
@@ -0,0 +1,188 @@
+module Network.BitTorrent.Client.Handle
+       ( -- * Handle
+         Handle
+
+         -- * Initialization
+       , openTorrent
+       , openMagnet
+       , closeHandle
+
+         -- * Control
+       , start
+       , pause
+       , stop
+
+         -- * Query
+       , getHandle
+       , getStatus
+       ) where
+
+import Control.Concurrent.Chan.Split
+import Control.Concurrent.Lifted as L
+import Control.Monad
+import Control.Monad.Trans
+import Data.Default
+import Data.List as L
+import Data.HashMap.Strict as HM
+
+import Data.Torrent
+import Network.BitTorrent.Client.Types as Types
+import Network.BitTorrent.DHT      as DHT
+import Network.BitTorrent.Exchange as Exchange
+import Network.BitTorrent.Tracker  as Tracker
+
+{-----------------------------------------------------------------------
+--  Safe handle set manupulation
+-----------------------------------------------------------------------}
+
+allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle
+allocHandle ih m = do
+  Client {..} <- getClient
+
+  (h, added) <- modifyMVar clientTorrents $ \ handles -> do
+    case HM.lookup ih handles of
+      Just h  -> return (handles, (h, False))
+      Nothing -> do
+        h <- m
+        return (HM.insert ih h handles, (h, True))
+
+  when added $ do
+    liftIO $ send clientEvents (TorrentAdded ih)
+
+  return h
+
+freeHandle :: InfoHash -> BitTorrent () -> BitTorrent ()
+freeHandle ih finalizer = do
+  Client {..} <- getClient
+
+  modifyMVar_ clientTorrents $ \ handles -> do
+    case HM.lookup ih handles of
+      Nothing -> return handles
+      Just _  -> do
+        finalizer
+        return (HM.delete ih handles)
+
+lookupHandle :: InfoHash -> BitTorrent (Maybe Handle)
+lookupHandle ih = do
+  Client {..} <- getClient
+  handles     <- readMVar clientTorrents
+  return (HM.lookup ih handles)
+
+{-----------------------------------------------------------------------
+--  Initialization
+-----------------------------------------------------------------------}
+
+newExchangeSession :: FilePath -> Either InfoHash InfoDict -> BitTorrent Exchange.Session
+newExchangeSession rootPath source = do
+  c @ Client {..} <- getClient
+  liftIO $ Exchange.newSession clientLogger (externalAddr c) rootPath source
+
+-- | Open a torrent in 'stop'ed state. Use 'nullTorrent' to open
+-- handle from 'InfoDict'. This operation do not block.
+openTorrent :: FilePath -> Torrent -> BitTorrent Handle
+openTorrent rootPath t @ Torrent {..} = do
+  let ih = idInfoHash tInfoDict
+  allocHandle ih $ do
+    statusVar <- newMVar Types.Stopped
+    tses <- liftIO $ Tracker.newSession ih (trackerList t)
+    eses <- newExchangeSession rootPath (Right tInfoDict)
+    eventStream <- liftIO newSendPort
+    return $ Handle
+      { handleTopic    = ih
+      , handlePrivate  = idPrivate tInfoDict
+      , handleStatus   = statusVar
+      , handleTrackers = tses
+      , handleExchange = eses
+      , handleEvents   = eventStream
+      }
+
+-- | Use 'nullMagnet' to open handle from 'InfoHash'.
+openMagnet :: FilePath -> Magnet -> BitTorrent Handle
+openMagnet rootPath Magnet {..} = do
+  allocHandle exactTopic $ do
+    statusVar <- newMVar Types.Stopped
+    tses <- liftIO $ Tracker.newSession exactTopic def
+    eses <- newExchangeSession rootPath (Left exactTopic)
+    eventStream <- liftIO newSendPort
+    return $ Handle
+      { handleTopic    = exactTopic
+      , handlePrivate  = False
+      , handleStatus   = statusVar
+      , handleTrackers = tses
+      , handleExchange = eses
+      , handleEvents   = eventStream
+      }
+
+-- | Stop torrent and destroy all sessions. You don't need to close
+-- handles at application exit, all handles will be automatically
+-- closed at 'Network.BitTorrent.Client.closeClient'. This operation
+-- may block.
+closeHandle :: Handle -> BitTorrent ()
+closeHandle h @ Handle {..} = do
+  freeHandle handleTopic $ do
+    Client {..} <- getClient
+    stop h
+    liftIO $ Exchange.closeSession handleExchange
+    liftIO $ Tracker.closeSession trackerManager handleTrackers
+
+{-----------------------------------------------------------------------
+--  Control
+-----------------------------------------------------------------------}
+
+modifyStatus :: HandleStatus -> Handle -> (HandleStatus -> BitTorrent ()) -> BitTorrent ()
+modifyStatus targetStatus Handle {..} targetAction = do
+  modifyMVar_ handleStatus $ \ actualStatus -> do
+    unless (actualStatus == targetStatus) $ do
+      targetAction actualStatus
+    return targetStatus
+  liftIO $ send handleEvents (StatusChanged targetStatus)
+
+-- | Start downloading, uploading and announcing this torrent.
+--
+-- This operation is blocking, use
+-- 'Control.Concurrent.Async.Lifted.async' if needed.
+start :: Handle -> BitTorrent ()
+start h @ Handle {..} = do
+  modifyStatus Types.Running h $ \ status -> do
+    case status of
+      Types.Running -> return ()
+      Types.Stopped -> do
+        Client {..} <- getClient
+        liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Started
+        unless handlePrivate $ do
+          liftDHT $ DHT.insert handleTopic (error "start")
+        liftIO $ do
+          peers <- askPeers trackerManager handleTrackers
+          print $ "got: " ++ show (L.length peers) ++ " peers"
+          forM_ peers $ \ peer -> do
+            Exchange.connect peer handleExchange
+
+-- | Stop downloading this torrent.
+pause :: Handle -> BitTorrent ()
+pause _ = return ()
+
+-- | Stop downloading, uploading and announcing this torrent.
+stop :: Handle -> BitTorrent ()
+stop h @ Handle {..} = do
+  modifyStatus Types.Stopped h $ \ status -> do
+    case status of
+      Types.Stopped -> return ()
+      Types.Running -> do
+        Client {..} <- getClient
+        unless handlePrivate $ do
+          liftDHT $ DHT.delete handleTopic (error "stop")
+        liftIO  $ Tracker.notify trackerManager handleTrackers Tracker.Stopped
+
+{-----------------------------------------------------------------------
+--  Query
+-----------------------------------------------------------------------}
+
+getHandle :: InfoHash -> BitTorrent Handle
+getHandle ih = do
+  mhandle <- lookupHandle ih
+  case mhandle of
+    Nothing -> error "should we throw some exception?"
+    Just h  -> return h
+
+getStatus :: Handle -> IO HandleStatus
+getStatus Handle {..} = readMVar handleStatus
diff --git a/bittorrent/src/Network/BitTorrent/Client/Types.hs b/bittorrent/src/Network/BitTorrent/Client/Types.hs
new file mode 100644
index 00000000..e2ad858f
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Client/Types.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Network.BitTorrent.Client.Types
+       ( -- * Core types
+         HandleStatus (..)
+       , Handle (..)
+       , Client (..)
+       , externalAddr
+
+         -- * Monad BitTorrent
+       , BitTorrent (..)
+       , runBitTorrent
+       , getClient
+
+       , MonadBitTorrent (..)
+
+         -- * Events
+       , Types.Event (..)
+       ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.Chan.Split as CS
+import Control.Monad.Base
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Resource
+import Data.Function
+import Data.HashMap.Strict as HM
+import Data.Ord
+import Network
+import System.Log.FastLogger
+
+import Data.Torrent
+import Network.Address
+import Network.BitTorrent.Internal.Types as Types
+import Network.BitTorrent.DHT      as DHT
+import Network.BitTorrent.Exchange as Exchange
+import Network.BitTorrent.Tracker  as Tracker hiding (Event)
+
+data HandleStatus
+  = Running
+  | Stopped
+    deriving (Show, Eq)
+
+data Handle = Handle
+  { handleTopic    :: !InfoHash
+  , handlePrivate  :: !Bool
+
+  , handleStatus   :: !(MVar HandleStatus)
+  , handleTrackers :: !Tracker.Session
+  , handleExchange :: !Exchange.Session
+  , handleEvents   :: !(SendPort (Event Handle))
+  }
+
+instance EventSource Handle where
+  data Event Handle  = StatusChanged HandleStatus
+  listen Handle {..} = CS.listen undefined
+
+data Client = Client
+  { clientPeerId       :: !PeerId
+  , clientListenerPort :: !PortNumber
+  , allowedExtensions  :: !Caps
+  , clientResources    :: !InternalState
+  , trackerManager     :: !Tracker.Manager
+  , exchangeManager    :: !Exchange.Manager
+  , clientNode         :: !(Node IPv4)
+  , clientTorrents     :: !(MVar (HashMap InfoHash Handle))
+  , clientLogger       :: !LogFun
+  , clientEvents       :: !(SendPort (Event Client))
+  }
+
+instance Eq Client where
+  (==) = (==) `on` clientPeerId
+
+instance Ord Client where
+  compare = comparing clientPeerId
+
+instance EventSource Client where
+  data Event Client = TorrentAdded InfoHash
+  listen Client {..} = CS.listen clientEvents
+
+-- | External IP address of a host running a bittorrent client
+-- software may be used to acknowledge remote peer the host connected
+-- to. See 'Network.BitTorrent.Exchange.Message.ExtendedHandshake'.
+externalAddr :: Client -> PeerAddr (Maybe IP)
+externalAddr Client {..} = PeerAddr
+  { peerId   = Just clientPeerId
+  , peerHost = Nothing -- TODO return external IP address, if known
+  , peerPort = clientListenerPort
+  }
+
+{-----------------------------------------------------------------------
+--  BitTorrent monad
+-----------------------------------------------------------------------}
+
+newtype BitTorrent a = BitTorrent
+  { unBitTorrent :: ReaderT Client IO a
+  } deriving ( Functor, Applicative, Monad
+             , MonadIO, MonadThrow, MonadBase IO
+             )
+
+class MonadBitTorrent m where
+  liftBT :: BitTorrent a -> m a
+
+#if MIN_VERSION_monad_control(1,0,0)
+newtype BTStM a = BTStM { unBTSt :: StM (ReaderT Client IO) a }
+
+instance MonadBaseControl IO BitTorrent where
+  type StM BitTorrent a = BTStM a
+  liftBaseWith cc = BitTorrent $ liftBaseWith $ \ cc' ->
+      cc $ \ (BitTorrent m) -> BTStM <$> cc' m
+  {-# INLINE liftBaseWith #-}
+
+  restoreM = BitTorrent . restoreM . unBTSt
+  {-# INLINE restoreM #-}
+#else
+instance MonadBaseControl IO BitTorrent where
+  newtype StM BitTorrent a = StM { unSt :: StM (ReaderT Client IO) a }
+  liftBaseWith cc = BitTorrent $ liftBaseWith $ \ cc' ->
+      cc $ \ (BitTorrent m) -> StM <$> cc' m
+  {-# INLINE liftBaseWith #-}
+
+  restoreM = BitTorrent . restoreM . unSt
+  {-# INLINE restoreM #-}
+#endif
+
+-- | NOP.
+instance MonadBitTorrent BitTorrent where
+  liftBT = id
+
+instance MonadTrans t => MonadBitTorrent (t BitTorrent) where
+  liftBT = lift
+
+-- | Registered but not closed manually resources will be
+-- automatically closed at 'Network.BitTorrent.Client.closeClient'
+instance MonadResource BitTorrent where
+  liftResourceT m = BitTorrent $ do
+    s <- asks clientResources
+    liftIO $ runInternalState m s
+
+-- | Run DHT operation, only if the client node is running.
+instance MonadDHT BitTorrent where
+  liftDHT action = BitTorrent $ do
+    node <- asks clientNode
+    liftIO $ runDHT node action
+
+instance MonadLogger BitTorrent where
+  monadLoggerLog loc src lvl msg = BitTorrent $ do
+    logger <- asks clientLogger
+    liftIO $ logger loc src lvl (toLogStr msg)
+
+runBitTorrent :: Client -> BitTorrent a -> IO a
+runBitTorrent client action = runReaderT (unBitTorrent action) client
+{-# INLINE runBitTorrent #-}
+
+getClient :: BitTorrent Client
+getClient = BitTorrent ask
+{-# INLINE getClient #-}
diff --git a/bittorrent/src/Network/BitTorrent/Exchange.hs b/bittorrent/src/Network/BitTorrent/Exchange.hs
new file mode 100644
index 00000000..143bf090
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange.hs
@@ -0,0 +1,35 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+module Network.BitTorrent.Exchange
+       ( -- * Manager
+         Options (..)
+       , Manager
+       , Handler
+       , newManager
+       , closeManager
+
+         -- * Session
+       , Caps
+       , Extension
+       , toCaps
+       , Session
+       , newSession
+       , closeSession
+
+         -- * Query
+       , waitMetadata
+       , takeMetadata
+
+         -- * Connections
+       , connect
+       , connectSink
+       ) where
+
+import Network.BitTorrent.Exchange.Manager
+import Network.BitTorrent.Exchange.Message
+import Network.BitTorrent.Exchange.Session
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs b/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs
new file mode 100644
index 00000000..7bae3475
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs
@@ -0,0 +1,399 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This modules provides all necessary machinery to work with
+--   bitfields. Bitfields are used to keep track indices of complete
+--   pieces either this peer have or remote peer have.
+--
+--   There are also commonly used piece seletion algorithms
+--   which used to find out which one next piece to download.
+--   Selectors considered to be used in the following order:
+--
+--     * 'randomFirst' - at the start of download.
+--
+--     * 'rarestFirst' - performed to avoid situation when
+--     rarest piece is unaccessible.
+--
+--     * 'endGame' - performed after a peer has requested all
+--     the subpieces of the content.
+--
+--   Note that BitTorrent protocol recommend (TODO link?) the
+--   'strictFirst' priority policy for /subpiece/ or /blocks/
+--   selection.
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Exchange.Bitfield
+       ( -- * Bitfield
+         PieceIx
+       , PieceCount
+       , Bitfield
+
+         -- * Construction
+       , haveAll
+       , haveNone
+       , have
+       , singleton
+       , interval
+       , adjustSize
+
+         -- * Query
+         -- ** Cardinality
+       , Network.BitTorrent.Exchange.Bitfield.null
+       , Network.BitTorrent.Exchange.Bitfield.full
+       , haveCount
+       , totalCount
+       , completeness
+
+         -- ** Membership
+       , member
+       , notMember
+       , findMin
+       , findMax
+       , isSubsetOf
+
+         -- ** Availability
+       , complement
+       , Frequency
+       , frequencies
+       , rarest
+
+         -- * Combine
+       , insert
+       , union
+       , intersection
+       , difference
+
+         -- * Conversion
+       , toList
+       , fromList
+
+         -- * Serialization
+       , fromBitmap
+       , toBitmap
+
+         -- * Piece selection
+       , Selector
+       , selector
+       , strategyClass
+
+       , strictFirst
+       , strictLast
+       , rarestFirst
+       , randomFirst
+       , endGame
+       ) where
+
+import Control.Monad
+import Control.Monad.ST
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lazy
+import           Data.Vector.Unboxed (Vector)
+import qualified Data.Vector.Unboxed as V
+import qualified Data.Vector.Unboxed.Mutable as VM
+import           Data.IntervalSet (IntSet)
+import qualified Data.IntervalSet as S
+import qualified Data.IntervalSet.ByteString as S
+import           Data.List (foldl')
+import           Data.Monoid
+import           Data.Ratio
+
+import Data.Torrent
+
+-- TODO cache some operations
+
+-- | Bitfields are represented just as integer sets but with
+-- restriction: the each set should be within given interval (or
+-- subset of the specified interval). Size is used to specify
+-- interval, so bitfield of size 10 might contain only indices in
+-- interval [0..9].
+--
+data Bitfield = Bitfield {
+    bfSize :: !PieceCount
+  , bfSet  :: !IntSet
+  } deriving (Show, Read, Eq)
+
+-- Invariants: all elements of bfSet lie in [0..bfSize - 1];
+
+instance Monoid Bitfield where
+  {-# SPECIALIZE instance Monoid Bitfield #-}
+  mempty  = haveNone 0
+  mappend = union
+  mconcat = unions
+
+{-----------------------------------------------------------------------
+    Construction
+-----------------------------------------------------------------------}
+
+-- | The empty bitfield of the given size.
+haveNone :: PieceCount -> Bitfield
+haveNone s = Bitfield s S.empty
+
+-- | The full bitfield containing all piece indices for the given size.
+haveAll :: PieceCount -> Bitfield
+haveAll s = Bitfield s (S.interval 0 (s - 1))
+
+-- | Insert the index in the set ignoring out of range indices.
+have :: PieceIx -> Bitfield -> Bitfield
+have ix Bitfield {..}
+  | 0 <= ix && ix < bfSize = Bitfield bfSize (S.insert ix bfSet)
+  |      otherwise         = Bitfield bfSize bfSet
+
+singleton :: PieceIx -> PieceCount -> Bitfield
+singleton ix pc = have ix (haveNone pc)
+
+-- | Assign new size to bitfield. FIXME Normally, size should be only
+-- decreased, otherwise exception raised.
+adjustSize :: PieceCount -> Bitfield -> Bitfield
+adjustSize s Bitfield {..} = Bitfield s bfSet
+
+-- | NOTE: for internal use only
+interval :: PieceCount -> PieceIx -> PieceIx -> Bitfield
+interval pc a b = Bitfield pc (S.interval a b)
+
+{-----------------------------------------------------------------------
+    Query
+-----------------------------------------------------------------------}
+
+-- | Test if bitifield have no one index: peer do not have anything.
+null :: Bitfield -> Bool
+null Bitfield {..} = S.null bfSet
+
+-- | Test if bitfield have all pieces.
+full :: Bitfield -> Bool
+full Bitfield {..} = S.size bfSet == bfSize
+
+-- | Count of peer have pieces.
+haveCount :: Bitfield -> PieceCount
+haveCount = S.size . bfSet
+
+-- | Total count of pieces and its indices.
+totalCount :: Bitfield -> PieceCount
+totalCount = bfSize
+
+-- | Ratio of /have/ piece count to the /total/ piece count.
+--
+--   > forall bf. 0 <= completeness bf <= 1
+--
+completeness :: Bitfield -> Ratio PieceCount
+completeness b = haveCount b % totalCount b
+
+inRange :: PieceIx -> Bitfield -> Bool
+inRange ix Bitfield {..} = 0 <= ix && ix < bfSize
+
+member :: PieceIx -> Bitfield -> Bool
+member ix bf @ Bitfield {..}
+  | ix `inRange` bf = ix `S.member` bfSet
+  |     otherwise   = False
+
+notMember :: PieceIx -> Bitfield -> Bool
+notMember ix bf @ Bitfield {..}
+  | ix `inRange` bf = ix `S.notMember` bfSet
+  |     otherwise   = True
+
+-- | Find first available piece index.
+findMin :: Bitfield -> PieceIx
+findMin = S.findMin . bfSet
+{-# INLINE findMin #-}
+
+-- | Find last available piece index.
+findMax :: Bitfield -> PieceIx
+findMax = S.findMax . bfSet
+{-# INLINE findMax #-}
+
+-- | Check if all pieces from first bitfield present if the second bitfield
+isSubsetOf :: Bitfield -> Bitfield -> Bool
+isSubsetOf a b = bfSet a `S.isSubsetOf` bfSet b
+{-# INLINE isSubsetOf #-}
+
+-- | Resulting bitfield includes only missing pieces.
+complement :: Bitfield -> Bitfield
+complement Bitfield {..} = Bitfield
+  { bfSet  = uni `S.difference` bfSet
+  , bfSize = bfSize
+  }
+  where
+    Bitfield _ uni = haveAll bfSize
+{-# INLINE complement #-}
+
+{-----------------------------------------------------------------------
+-- Availability
+-----------------------------------------------------------------------}
+
+-- | Frequencies are needed in piece selection startegies which use
+-- availability quantity to find out the optimal next piece index to
+-- download.
+type Frequency = Int
+
+-- TODO rename to availability
+-- | How many times each piece index occur in the given bitfield set.
+frequencies :: [Bitfield] -> Vector Frequency
+frequencies [] = V.fromList []
+frequencies xs = runST $ do
+    v <- VM.new size
+    VM.set v 0
+    forM_ xs $ \ Bitfield {..} -> do
+      forM_ (S.toList bfSet) $ \ x -> do
+        fr <- VM.read v x
+        VM.write v x (succ fr)
+    V.unsafeFreeze v
+  where
+    size = maximum (map bfSize xs)
+
+-- TODO it seems like this operation is veeery slow
+
+-- | Find least available piece index. If no piece available return
+-- 'Nothing'.
+rarest :: [Bitfield] -> Maybe PieceIx
+rarest xs
+    | V.null freqMap = Nothing
+    |     otherwise
+    = Just $ fst $ V.ifoldr' minIx (0, freqMap V.! 0) freqMap
+  where
+    freqMap = frequencies xs
+
+    minIx ::  PieceIx -> Frequency
+          -> (PieceIx,   Frequency)
+          -> (PieceIx,   Frequency)
+    minIx ix fr acc@(_, fra)
+      | fr < fra && fr > 0 = (ix, fr)
+      |     otherwise      = acc
+
+
+{-----------------------------------------------------------------------
+    Combine
+-----------------------------------------------------------------------}
+
+insert :: PieceIx -> Bitfield -> Bitfield
+insert pix bf @ Bitfield {..}
+  | 0 <= pix && pix < bfSize = Bitfield
+    { bfSet  = S.insert pix bfSet
+    , bfSize = bfSize
+    }
+  | otherwise = bf
+
+-- | Find indices at least one peer have.
+union :: Bitfield -> Bitfield -> Bitfield
+union a b = {-# SCC union #-} Bitfield {
+    bfSize = bfSize a `max` bfSize b
+  , bfSet  = bfSet a `S.union` bfSet b
+  }
+
+-- | Find indices both peers have.
+intersection :: Bitfield -> Bitfield -> Bitfield
+intersection a b = {-# SCC intersection #-} Bitfield {
+    bfSize = bfSize a `min` bfSize b
+  , bfSet  = bfSet a `S.intersection` bfSet b
+  }
+
+-- | Find indices which have first peer but do not have the second peer.
+difference :: Bitfield -> Bitfield -> Bitfield
+difference a b = {-# SCC difference #-} Bitfield {
+    bfSize = bfSize a -- FIXME is it reasonable?
+  , bfSet  = bfSet a `S.difference` bfSet b
+  }
+
+-- | Find indices the any of the peers have.
+unions :: [Bitfield] -> Bitfield
+unions = {-# SCC unions #-} foldl' union (haveNone 0)
+
+{-----------------------------------------------------------------------
+    Serialization
+-----------------------------------------------------------------------}
+
+-- | List all /have/ indexes.
+toList :: Bitfield -> [PieceIx]
+toList Bitfield {..} = S.toList bfSet
+
+-- | Make bitfield from list of /have/ indexes.
+fromList :: PieceCount -> [PieceIx] -> Bitfield
+fromList s ixs = Bitfield {
+    bfSize = s
+  , bfSet  = S.splitGT (-1) $ S.splitLT s $ S.fromList ixs
+  }
+
+-- | Unpack 'Bitfield' from tightly packed bit array. Note resulting
+-- size might be more than real bitfield size, use 'adjustSize'.
+fromBitmap :: ByteString -> Bitfield
+fromBitmap bs = {-# SCC fromBitmap #-} Bitfield {
+    bfSize = B.length bs * 8
+  , bfSet  = S.fromByteString bs
+  }
+{-# INLINE fromBitmap #-}
+
+-- | Pack a 'Bitfield' to tightly packed bit array.
+toBitmap :: Bitfield -> Lazy.ByteString
+toBitmap Bitfield {..} = {-# SCC toBitmap #-} Lazy.fromChunks [intsetBM, alignment]
+  where
+    byteSize  = bfSize `div` 8 + if bfSize `mod` 8 == 0 then 0 else 1
+    alignment = B.replicate (byteSize - B.length intsetBM) 0
+    intsetBM  = S.toByteString bfSet
+
+{-----------------------------------------------------------------------
+--  Piece selection
+-----------------------------------------------------------------------}
+
+type Selector =  Bitfield      -- ^ Indices of client /have/ pieces.
+             ->  Bitfield      -- ^ Indices of peer /have/ pieces.
+             -> [Bitfield]     -- ^ Indices of other peers /have/ pieces.
+             -> Maybe PieceIx  -- ^ Zero-based index of piece to request
+                               --   to, if any.
+
+selector :: Selector       -- ^ Selector to use at the start.
+         -> Ratio PieceCount
+         -> Selector       -- ^ Selector to use after the client have
+                           -- the C pieces.
+         -> Selector       -- ^ Selector that changes behaviour based
+                           -- on completeness.
+selector start pt ready   h a xs =
+  case strategyClass pt h of
+    SCBeginning -> start h a xs
+    SCReady     -> ready h a xs
+    SCEnd       -> endGame h a xs
+
+data StartegyClass
+  = SCBeginning
+  | SCReady
+  | SCEnd
+    deriving (Show, Eq, Ord, Enum, Bounded)
+
+
+strategyClass :: Ratio PieceCount -> Bitfield -> StartegyClass
+strategyClass threshold = classify . completeness
+  where
+    classify c
+      |        c < threshold       = SCBeginning
+      | c + 1 % numerator c < 1    = SCReady
+    -- FIXME numerator have is not total count
+      |          otherwise         = SCEnd
+
+
+-- | Select the first available piece.
+strictFirst :: Selector
+strictFirst h a _ = Just $ findMin (difference a h)
+
+-- | Select the last available piece.
+strictLast :: Selector
+strictLast h a _ = Just $ findMax (difference a h)
+
+-- |
+rarestFirst :: Selector
+rarestFirst h a xs = rarest (map (intersection want) xs)
+  where
+    want = difference h a
+
+-- | In average random first is faster than rarest first strategy but
+--    only if all pieces are available.
+randomFirst :: Selector
+randomFirst = do
+--  randomIO
+  error "randomFirst"
+
+endGame :: Selector
+endGame = strictLast
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Block.hs b/bittorrent/src/Network/BitTorrent/Exchange/Block.hs
new file mode 100644
index 00000000..bc9a3d24
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Block.hs
@@ -0,0 +1,369 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Blocks are used to transfer pieces.
+--
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Network.BitTorrent.Exchange.Block
+       ( -- * Block attributes
+         BlockOffset
+       , BlockCount
+       , BlockSize
+       , defaultTransferSize
+
+         -- * Block index
+       , BlockIx(..)
+       , blockIxRange
+
+         -- * Block data
+       , Block(..)
+       , blockIx
+       , blockSize
+       , blockRange
+       , isPiece
+       , leadingBlock
+
+         -- * Block bucket
+       , Bucket
+
+         -- ** Query
+       , Network.BitTorrent.Exchange.Block.null
+       , Network.BitTorrent.Exchange.Block.full
+       , Network.BitTorrent.Exchange.Block.size
+       , Network.BitTorrent.Exchange.Block.spans
+
+         -- ** Construction
+       , Network.BitTorrent.Exchange.Block.empty
+       , Network.BitTorrent.Exchange.Block.insert
+       , Network.BitTorrent.Exchange.Block.insertLazy
+       , Network.BitTorrent.Exchange.Block.merge
+       , Network.BitTorrent.Exchange.Block.fromList
+
+         -- ** Rendering
+       , Network.BitTorrent.Exchange.Block.toPiece
+
+         -- ** Debug
+       , Network.BitTorrent.Exchange.Block.valid
+       ) where
+
+import Prelude hiding (span)
+import Control.Applicative
+import Data.ByteString as BS hiding (span)
+import Data.ByteString.Lazy as BL hiding (span)
+import Data.ByteString.Lazy.Builder as BS
+import Data.Default
+import Data.Monoid
+import Data.List as L hiding (span)
+import Data.Serialize as S
+import Data.Typeable
+import Numeric
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+
+import Data.Torrent
+
+{-----------------------------------------------------------------------
+--  Block attributes
+-----------------------------------------------------------------------}
+
+-- | Offset of a block in a piece in bytes. Should be multiple of
+-- the choosen block size.
+type BlockOffset = Int
+
+-- | Size of a block in bytes. Should be power of 2.
+--
+--   Normally block size is equal to 'defaultTransferSize'.
+--
+type BlockSize   = Int
+
+-- | Number of block in a piece of a torrent. Used to distinguish
+-- block count from piece count.
+type BlockCount  = Int
+
+-- | Widely used semi-official block size. Some clients can ignore if
+-- block size of BlockIx in Request message is not equal to this
+-- value.
+--
+defaultTransferSize :: BlockSize
+defaultTransferSize = 16 * 1024
+
+{-----------------------------------------------------------------------
+    Block Index
+-----------------------------------------------------------------------}
+
+-- | BlockIx correspond.
+data BlockIx = BlockIx {
+    -- | Zero-based piece index.
+    ixPiece  :: {-# UNPACK #-} !PieceIx
+
+    -- | Zero-based byte offset within the piece.
+  , ixOffset :: {-# UNPACK #-} !BlockOffset
+
+    -- | Block size starting from offset.
+  , ixLength :: {-# UNPACK #-} !BlockSize
+  } deriving (Show, Eq, Typeable)
+
+-- | First block in torrent. Useful for debugging.
+instance Default BlockIx where
+  def = BlockIx 0 0 defaultTransferSize
+
+getInt :: S.Get Int
+getInt = fromIntegral <$> S.getWord32be
+{-# INLINE getInt #-}
+
+putInt :: S.Putter Int
+putInt = S.putWord32be . fromIntegral
+{-# INLINE putInt #-}
+
+instance Serialize BlockIx where
+  {-# SPECIALIZE instance Serialize BlockIx #-}
+  get = BlockIx <$> getInt
+                <*> getInt
+                <*> getInt
+  {-# INLINE get #-}
+
+  put BlockIx {..} = do
+    putInt ixPiece
+    putInt ixOffset
+    putInt ixLength
+  {-# INLINE put #-}
+
+instance Pretty BlockIx where
+  pPrint BlockIx {..} =
+    ("piece  = " <> int ixPiece  <> ",") <+>
+    ("offset = " <> int ixOffset <> ",") <+>
+    ("length = " <> int ixLength)
+
+-- | Get location of payload bytes in the torrent content.
+blockIxRange :: (Num a, Integral a) => PieceSize -> BlockIx -> (a, a)
+blockIxRange piSize BlockIx {..} = (offset, offset + len)
+  where
+    offset = fromIntegral piSize * fromIntegral ixPiece
+           + fromIntegral ixOffset
+    len    = fromIntegral ixLength
+{-# INLINE blockIxRange #-}
+
+{-----------------------------------------------------------------------
+    Block
+-----------------------------------------------------------------------}
+
+data Block payload = Block {
+    -- | Zero-based piece index.
+    blkPiece  :: {-# UNPACK #-} !PieceIx
+
+    -- | Zero-based byte offset within the piece.
+  , blkOffset :: {-# UNPACK #-} !BlockOffset
+
+    -- | Payload bytes.
+  , blkData   :: !payload
+  } deriving (Show, Eq, Functor, Typeable)
+
+-- | Payload is ommitted.
+instance Pretty (Block BL.ByteString) where
+  pPrint = pPrint . blockIx
+  {-# INLINE pPrint #-}
+
+-- | Get size of block /payload/ in bytes.
+blockSize :: Block BL.ByteString -> BlockSize
+blockSize = fromIntegral . BL.length . blkData
+{-# INLINE blockSize #-}
+
+-- | Get block index of a block.
+blockIx :: Block BL.ByteString -> BlockIx
+blockIx = BlockIx <$> blkPiece <*> blkOffset <*> blockSize
+
+-- | Get location of payload bytes in the torrent content.
+blockRange :: (Num a, Integral a)
+           => PieceSize -> Block BL.ByteString -> (a, a)
+blockRange piSize = blockIxRange piSize . blockIx
+{-# INLINE blockRange #-}
+
+-- | Test if a block can be safely turned into a piece.
+isPiece :: PieceSize -> Block BL.ByteString -> Bool
+isPiece pieceLen blk @ (Block i offset _) =
+     offset == 0 && blockSize blk == pieceLen && i >= 0
+{-# INLINE isPiece #-}
+
+-- | First block in the piece.
+leadingBlock :: PieceIx -> BlockSize -> BlockIx
+leadingBlock pix blockSize = BlockIx
+  { ixPiece  = pix
+  , ixOffset = 0
+  , ixLength = blockSize
+  }
+{-# INLINE leadingBlock #-}
+
+{-----------------------------------------------------------------------
+--  Bucket
+-----------------------------------------------------------------------}
+
+type Pos  = Int
+type ChunkSize = Int
+
+-- | A sparse set of blocks used to represent an /in progress/ piece.
+data Bucket
+  = Nil
+  | Span {-# UNPACK #-} !ChunkSize          !Bucket
+  | Fill {-# UNPACK #-} !ChunkSize !Builder !Bucket
+
+instance Show Bucket where
+  showsPrec i  Nil          = showString ""
+  showsPrec i (Span s   xs) = showString "Span " <> showInt s
+                           <> showString " "     <> showsPrec i xs
+  showsPrec i (Fill s _ xs) = showString "Fill " <> showInt s
+                           <> showString " "     <> showsPrec i xs
+
+-- | INVARIANT: 'Nil' should appear only after 'Span' of 'Fill'.
+nilInvFailed :: a
+nilInvFailed = error "Nil: bucket invariant failed"
+
+valid :: Bucket -> Bool
+valid = check Nothing
+  where
+    check Nothing     Nil           = False -- see 'nilInvFailed'
+    check (Just _)    _             = True
+    check prevIsSpan (Span sz   xs) =
+      prevIsSpan /= Just True &&    -- Span n (NotSpan .. ) invariant
+      sz > 0 &&                     -- Span is always non-empty
+      check (Just True) xs
+    check prevIsSpan (Fill sz b xs) =
+      prevIsSpan /= Just True &&    -- Fill n (NotFill .. ) invariant
+      sz > 0 &&                     -- Fill is always non-empty
+      check (Just False) xs
+
+instance Pretty Bucket where
+  pPrint Nil = nilInvFailed
+  pPrint bkt = go bkt
+    where
+      go  Nil           = PP.empty
+      go (Span sz   xs) = "Span" <+> PP.int sz <+> go xs
+      go (Fill sz b xs) = "Fill" <+> PP.int sz <+> go xs
+
+-- | Smart constructor: use it when some block is /deleted/ from
+-- bucket.
+span :: ChunkSize -> Bucket -> Bucket
+span sz (Span sz'   xs) = Span (sz + sz') xs
+span sz  xxs            = Span  sz        xxs
+{-# INLINE span #-}
+
+-- | Smart constructor: use it when some block is /inserted/ to
+-- bucket.
+fill :: ChunkSize -> Builder -> Bucket -> Bucket
+fill sz b (Fill sz' b' xs) = Fill (sz + sz') (b <> b') xs
+fill sz b  xxs             = Fill  sz         b        xxs
+{-# INLINE fill #-}
+
+{-----------------------------------------------------------------------
+--  Bucket queries
+-----------------------------------------------------------------------}
+
+-- | /O(1)/. Test if this bucket is empty.
+null :: Bucket -> Bool
+null  Nil         = nilInvFailed
+null (Span _ Nil) = True
+null  _           = False
+{-# INLINE null #-}
+
+-- | /O(1)/. Test if this bucket is complete.
+full :: Bucket -> Bool
+full  Nil           = nilInvFailed
+full (Fill _ _ Nil) = True
+full  _             = False
+{-# INLINE full #-}
+
+-- | /O(n)/. Total size of the incompleted piece.
+size :: Bucket -> PieceSize
+size Nil = nilInvFailed
+size bkt = go bkt
+  where
+    go  Nil           = 0
+    go (Span sz   xs) = sz + go xs
+    go (Fill sz _ xs) = sz + go xs
+
+-- | /O(n)/. List incomplete blocks to download. If some block have
+-- size more than the specified 'BlockSize' then block is split into
+-- smaller blocks to satisfy given 'BlockSize'. Small (for
+-- e.g. trailing) blocks is not ignored, but returned in-order.
+spans :: BlockSize -> Bucket -> [(BlockOffset, BlockSize)]
+spans expectedSize = go 0
+  where
+    go _    Nil           = []
+    go off (Span sz   xs) = listChunks off sz ++ go (off + sz) xs
+    go off (Fill sz _ xs) = go (off + sz) xs
+
+    listChunks off restSize
+      | restSize <= 0 = []
+      |   otherwise   = (off, blkSize)
+                      : listChunks (off + blkSize) (restSize - blkSize)
+      where
+        blkSize = min expectedSize restSize
+
+{-----------------------------------------------------------------------
+--  Bucket contstruction
+-----------------------------------------------------------------------}
+
+-- | /O(1)/. A new empty bucket capable to alloof specified size.
+empty :: PieceSize -> Bucket
+empty sz
+  |   sz < 0  = error "empty: Bucket size must be a non-negative value"
+  | otherwise = Span sz Nil
+{-# INLINE empty #-}
+
+insertSpan :: Pos -> BS.ByteString -> ChunkSize -> Bucket -> Bucket
+insertSpan !pos !bs !span_sz !xs =
+  let pref_len = pos
+      fill_len = span_sz - pos `min` BS.length bs
+      suff_len = (span_sz - pos) - fill_len
+  in mkSpan pref_len $
+     fill   fill_len (byteString (BS.take fill_len bs)) $
+     mkSpan suff_len $
+     xs
+  where
+    mkSpan 0  xs = xs
+    mkSpan sz xs = Span sz xs
+
+-- | /O(n)/. Insert a strict bytestring at specified position.
+--
+--   Best case: if blocks are inserted in sequential order, then this
+--   operation should take /O(1)/.
+--
+insert :: Pos -> BS.ByteString -> Bucket -> Bucket
+insert _      _  Nil    = nilInvFailed
+insert dstPos bs bucket = go 0 bucket
+  where
+    intersects curPos sz = dstPos >= curPos && dstPos <= curPos + sz
+
+    go _             Nil     = Nil
+    go curPos       (Span sz xs)
+      | intersects curPos sz = insertSpan (dstPos - curPos) bs sz xs
+      |       otherwise      = span sz    (go (curPos + sz) xs)
+    go curPos bkt @ (Fill sz br xs)
+      | intersects curPos sz = bkt
+      |       otherwise      = fill sz br (go (curPos + sz) xs)
+
+fromList :: PieceSize -> [(Pos, BS.ByteString)] -> Bucket
+fromList s = L.foldr (uncurry Network.BitTorrent.Exchange.Block.insert)
+                     (Network.BitTorrent.Exchange.Block.empty s)
+
+-- TODO zero-copy
+insertLazy :: Pos -> BL.ByteString -> Bucket -> Bucket
+insertLazy pos bl = Network.BitTorrent.Exchange.Block.insert pos (BL.toStrict bl)
+
+-- | /O(n)/.
+merge :: Bucket -> Bucket -> Bucket
+merge = error "Bucket.merge: not implemented"
+
+-- | /O(1)/.
+toPiece :: Bucket -> Maybe BL.ByteString
+toPiece  Nil           = nilInvFailed
+toPiece (Fill _ b Nil) = Just (toLazyByteString b)
+toPiece  _             = Nothing
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs b/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs
new file mode 100644
index 00000000..6804d0a2
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs
@@ -0,0 +1,1012 @@
+-- |
+--   Module      :  Network.BitTorrent.Exchange.Wire
+--   Copyright   :  (c) Sam Truzjan 2013
+--                  (c) Daniel Gröber 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Each peer wire connection is identified by triple @(topic,
+--   remote_addr, this_addr)@. This means that connections are the
+--   same if and only if their 'ConnectionId' are the same. Of course,
+--   you /must/ avoid duplicated connections.
+--
+--   This module control /integrity/ of data send and received.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Network.BitTorrent.Exchange.Connection
+       ( -- * Wire
+         Connected
+       , Wire
+       , ChannelSide   (..)
+
+         -- * Connection
+       , Connection
+       , connInitiatedBy
+
+         -- ** Identity
+       , connRemoteAddr
+       , connTopic
+       , connRemotePeerId
+       , connThisPeerId
+
+         -- ** Capabilities
+       , connProtocol
+       , connCaps
+       , connExtCaps
+       , connRemoteEhs
+
+         -- ** State
+       , connStatus
+       , connBitfield
+
+         -- ** Env
+       , connOptions
+       , connSession
+       , connStats
+
+         -- ** Status
+       , PeerStatus (..)
+       , ConnectionStatus (..)
+       , updateStatus
+       , statusUpdates
+       , clientStatus
+       , remoteStatus
+       , canUpload
+       , canDownload
+       , defaultUnchokeSlots
+       , defaultRechokeInterval
+
+
+         -- * Setup
+       , ConnectionPrefs  (..)
+       , SessionLink      (..)
+       , ConnectionConfig (..)
+
+         -- ** Initiate
+       , connectWire
+
+         -- ** Accept
+       , PendingConnection
+       , newPendingConnection
+       , pendingPeer
+       , pendingCaps
+       , pendingTopic
+       , closePending
+       , acceptWire
+
+         -- ** Post setup actions
+       , resizeBitfield
+
+         -- * Messaging
+       , recvMessage
+       , sendMessage
+       , filterQueue
+       , getMaxQueueLength
+
+         -- * Exceptions
+       , ProtocolError (..)
+       , WireFailure   (..)
+       , peerPenalty
+       , isWireFailure
+       , disconnectPeer
+
+         -- * Stats
+       , ByteStats       (..)
+       , FlowStats       (..)
+       , ConnectionStats (..)
+
+         -- * Flood detection
+       , FloodDetector   (..)
+
+         -- * Options
+       , Options         (..)
+       ) where
+
+import Control.Applicative
+import Control.Concurrent hiding (yield)
+import Control.Exception
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans.Resource
+import Control.Lens
+import Data.ByteString as BS
+import Data.ByteString.Lazy as BSL
+import Data.Conduit as C
+import Data.Conduit.Cereal
+import Data.Conduit.List
+import Data.Conduit.Network
+import Data.Default
+import Data.IORef
+import Data.List as L
+import Data.Maybe as M
+import Data.Monoid
+import Data.Serialize as S
+import Data.Typeable
+import Network
+import Network.Socket hiding (Connected)
+import Network.Socket.ByteString as BS
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+import Text.Show.Functions ()
+import System.Log.FastLogger (ToLogStr(..))
+import System.Timeout
+
+import Data.Torrent
+import Network.Address
+import Network.BitTorrent.Exchange.Bitfield as BF
+import Network.BitTorrent.Exchange.Message  as Msg
+
+-- TODO handle port message?
+-- TODO handle limits?
+-- TODO filter not requested PIECE messages
+-- TODO metadata piece request flood protection
+-- TODO piece request flood protection
+-- TODO protect against flood attacks
+{-----------------------------------------------------------------------
+--  Exceptions
+-----------------------------------------------------------------------}
+
+-- | Used to specify initiator of 'ProtocolError'.
+data ChannelSide
+  = ThisPeer
+  | RemotePeer
+    deriving (Show, Eq, Enum, Bounded)
+
+instance Default ChannelSide where
+  def = ThisPeer
+
+instance Pretty ChannelSide where
+  pPrint = PP.text . show
+
+-- | A protocol errors occur when a peer violates protocol
+-- specification.
+data ProtocolError
+    -- | Protocol string should be 'BitTorrent Protocol' but remote
+    -- peer have sent a different string.
+  = InvalidProtocol   ProtocolName
+
+    -- | Sent and received protocol strings do not match. Can occur
+    -- in 'connectWire' only.
+  | UnexpectedProtocol ProtocolName
+
+    -- | /Remote/ peer replied with invalid 'hsInfoHash' which do not
+    -- match with 'hsInfoHash' /this/ peer have sent. Can occur in
+    -- 'connectWire' or 'acceptWire' only.
+  | UnexpectedTopic   InfoHash
+
+    -- | Some trackers or DHT can return 'PeerId' of a peer. If a
+    -- remote peer handshaked with different 'hsPeerId' then this
+    -- exception is raised. Can occur in 'connectWire' only.
+  | UnexpectedPeerId  PeerId
+
+    -- | Accepted peer have sent unknown torrent infohash in
+    -- 'hsInfoHash' field. This situation usually happen when /this/
+    -- peer have deleted the requested torrent. The error can occur in
+    -- 'acceptWire' function only.
+  | UnknownTopic      InfoHash
+
+    -- | A remote peer have 'ExtExtended' enabled but did not send an
+    -- 'ExtendedHandshake' back.
+  | HandshakeRefused
+
+    -- | 'Network.BitTorrent.Exchange.Message.Bitfield' message MUST
+    -- be send either once or zero times, but either this peer or
+    -- remote peer send a bitfield message the second time.
+  | BitfieldAlreadySent ChannelSide
+
+    -- | Capabilities violation. For example this exception can occur
+    -- when a peer have sent 'Port' message but 'ExtDHT' is not
+    -- allowed in 'connCaps'.
+  | DisallowedMessage
+    { -- | Who sent invalid message.
+      violentSender     :: ChannelSide
+
+      -- | If the 'violentSender' reconnect with this extension
+      -- enabled then he can try to send this message.
+    , extensionRequired :: Extension
+    }
+    deriving Show
+
+instance Pretty ProtocolError where
+  pPrint = PP.text . show
+
+errorPenalty :: ProtocolError -> Int
+errorPenalty (InvalidProtocol      _) = 1
+errorPenalty (UnexpectedProtocol   _) = 1
+errorPenalty (UnexpectedTopic      _) = 1
+errorPenalty (UnexpectedPeerId     _) = 1
+errorPenalty (UnknownTopic         _) = 0
+errorPenalty (HandshakeRefused      ) = 1
+errorPenalty (BitfieldAlreadySent  _) = 1
+errorPenalty (DisallowedMessage  _ _) = 1
+
+-- | Exceptions used to interrupt the current P2P session.
+data WireFailure
+  = ConnectionRefused IOError
+
+    -- | Force termination of wire connection.
+    --
+    --   Normally you should throw only this exception from event loop
+    --   using 'disconnectPeer', other exceptions are thrown
+    --   automatically by functions from this module.
+    --
+  | DisconnectPeer
+
+     -- | A peer not responding and did not send a 'KeepAlive' message
+     -- for a specified period of time.
+  | PeerDisconnected
+
+    -- | A remote peer have sent some unknown message we unable to
+    -- parse.
+  | DecodingError GetException
+
+    -- | See 'ProtocolError' for more details.
+  | ProtocolError ProtocolError
+
+    -- | A possible malicious peer have sent too many control messages
+    -- without making any progress.
+  | FloodDetected ConnectionStats
+    deriving (Show, Typeable)
+
+instance Exception WireFailure
+
+instance Pretty WireFailure where
+  pPrint = PP.text . show
+
+-- TODO
+-- data Penalty = Ban | Penalty Int
+
+peerPenalty :: WireFailure -> Int
+peerPenalty  DisconnectPeer   = 0
+peerPenalty  PeerDisconnected = 0
+peerPenalty (DecodingError _) = 1
+peerPenalty (ProtocolError e) = errorPenalty e
+peerPenalty (FloodDetected _) = 1
+
+-- | Do nothing with exception, used with 'handle' or 'try'.
+isWireFailure :: Monad m => WireFailure -> m ()
+isWireFailure _ = return ()
+
+protocolError :: MonadThrow m => ProtocolError -> m a
+protocolError = monadThrow . ProtocolError
+
+{-----------------------------------------------------------------------
+--  Stats
+-----------------------------------------------------------------------}
+
+-- | Message stats in one direction.
+data FlowStats = FlowStats
+  { -- | Number of the messages sent or received.
+    messageCount :: {-# UNPACK #-} !Int
+    -- | Sum of byte sequences of all messages.
+  , messageBytes :: {-# UNPACK #-} !ByteStats
+  } deriving Show
+
+instance Pretty FlowStats where
+  pPrint FlowStats {..} =
+    PP.int messageCount <+> "messages" $+$
+    pPrint messageBytes
+
+-- | Zeroed stats.
+instance Default FlowStats where
+  def = FlowStats 0 def
+
+-- | Monoid under addition.
+instance Monoid FlowStats where
+  mempty = def
+  mappend a b = FlowStats
+    { messageBytes = messageBytes a <> messageBytes b
+    , messageCount = messageCount a +  messageCount b
+    }
+
+-- | Find average length of byte sequences per message.
+avgByteStats :: FlowStats -> ByteStats
+avgByteStats (FlowStats n ByteStats {..}) = ByteStats
+  { overhead = overhead `quot` n
+  , control  = control  `quot` n
+  , payload  = payload  `quot` n
+  }
+
+-- | Message stats in both directions. This data can be retrieved
+-- using 'getStats' function.
+--
+--   Note that this stats is completely different from
+--   'Data.Torrent.Progress.Progress': payload bytes not necessary
+--   equal to downloaded\/uploaded bytes since a peer can send a
+--   broken block.
+--
+data ConnectionStats = ConnectionStats
+  { -- | Received messages stats.
+    incomingFlow  :: !FlowStats
+    -- | Sent messages stats.
+  , outcomingFlow :: !FlowStats
+  } deriving Show
+
+instance Pretty ConnectionStats where
+  pPrint ConnectionStats {..} = vcat
+    [ "Recv:" <+> pPrint incomingFlow
+    , "Sent:" <+> pPrint outcomingFlow
+    , "Both:" <+> pPrint (incomingFlow <> outcomingFlow)
+    ]
+
+-- | Zeroed stats.
+instance Default ConnectionStats where
+  def = ConnectionStats def def
+
+-- | Monoid under addition.
+instance Monoid ConnectionStats where
+  mempty = def
+  mappend a b = ConnectionStats
+    { incomingFlow  = incomingFlow  a <> incomingFlow  b
+    , outcomingFlow = outcomingFlow a <> outcomingFlow b
+    }
+
+-- | Aggregate one more message stats in the /specified/ direction.
+addStats :: ChannelSide -> ByteStats -> ConnectionStats -> ConnectionStats
+addStats ThisPeer   x s = s { outcomingFlow = (FlowStats 1 x) <> (outcomingFlow s) }
+addStats RemotePeer x s = s { incomingFlow  = (FlowStats 1 x) <> (incomingFlow  s) }
+
+-- | Sum of overhead and control bytes in both directions.
+wastedBytes :: ConnectionStats -> Int
+wastedBytes ConnectionStats {..} = overhead + control
+  where
+    FlowStats _ ByteStats {..} = incomingFlow <> outcomingFlow
+
+-- | Sum of payload bytes in both directions.
+payloadBytes :: ConnectionStats -> Int
+payloadBytes ConnectionStats {..} =
+  payload (messageBytes (incomingFlow <> outcomingFlow))
+
+-- | Sum of any bytes in both directions.
+transmittedBytes :: ConnectionStats -> Int
+transmittedBytes ConnectionStats {..} =
+  byteLength (messageBytes (incomingFlow <> outcomingFlow))
+
+{-----------------------------------------------------------------------
+--  Flood protection
+-----------------------------------------------------------------------}
+
+defaultFloodFactor :: Int
+defaultFloodFactor = 1
+
+-- | This is a very permissive value, connection setup usually takes
+-- around 10-100KB, including both directions.
+defaultFloodThreshold :: Int
+defaultFloodThreshold = 2 * 1024 * 1024
+
+-- | A flood detection function.
+type Detector stats = Int   -- ^ Factor;
+                   -> Int   -- ^ Threshold;
+                   -> stats -- ^ Stats to analyse;
+                   -> Bool  -- ^ Is this a flooded connection?
+
+defaultDetector :: Detector ConnectionStats
+defaultDetector factor threshold s =
+  transmittedBytes s     > threshold &&
+  factor * wastedBytes s > payloadBytes s
+
+-- | Flood detection is used to protect /this/ peer against a /remote/
+-- malicious peer sending meaningless control messages.
+data FloodDetector = FloodDetector
+  { -- | Max ratio of payload bytes to control bytes.
+    floodFactor    :: {-# UNPACK #-} !Int
+
+    -- | Max count of bytes connection /setup/ can take including
+    -- 'Handshake', 'ExtendedHandshake', 'Bitfield', 'Have' and 'Port'
+    -- messages. This value is used to avoid false positives at the
+    -- connection initialization.
+  , floodThreshold :: {-# UNPACK #-} !Int
+
+    -- | Flood predicate on the /current/ 'ConnectionStats'.
+  , floodPredicate :: Detector ConnectionStats
+  } deriving Show
+
+instance Eq FloodDetector where
+  a == b = floodFactor    a == floodFactor    b
+        && floodThreshold a == floodThreshold b
+
+-- | Flood detector with very permissive options.
+instance Default FloodDetector where
+  def = FloodDetector
+    { floodFactor    = defaultFloodFactor
+    , floodThreshold = defaultFloodThreshold
+    , floodPredicate = defaultDetector
+    }
+
+-- | This peer might drop connection if the detector gives positive answer.
+runDetector :: FloodDetector -> ConnectionStats -> Bool
+runDetector FloodDetector {..} = floodPredicate floodFactor floodThreshold
+
+{-----------------------------------------------------------------------
+--  Options
+-----------------------------------------------------------------------}
+
+-- | Various connection settings and limits.
+data Options = Options
+  { -- | How often /this/ peer should send 'KeepAlive' messages.
+    keepaliveInterval   :: {-# UNPACK #-} !Int
+
+    -- | /This/ peer will drop connection if a /remote/ peer did not
+    -- send any message for this period of time.
+  , keepaliveTimeout    :: {-# UNPACK #-} !Int
+
+  , requestQueueLength  :: {-# UNPACK #-} !Int
+
+    -- | Used to protect against flood attacks.
+  , floodDetector       :: FloodDetector
+
+    -- | Used to protect against flood attacks in /metadata
+    -- exchange/. Normally, a requesting peer should request each
+    -- 'InfoDict' piece only one time, but a malicious peer can
+    -- saturate wire with 'MetadataRequest' messages thus flooding
+    -- responding peer.
+    --
+    --   This value set upper bound for number of 'MetadataRequests'
+    --   for each piece.
+    --
+  , metadataFactor      :: {-# UNPACK #-} !Int
+
+    -- | Used to protect against out-of-memory attacks: malicious peer
+    -- can claim that 'totalSize' is, say, 100TB and send some random
+    -- data instead of infodict pieces. Since requesting peer unable
+    -- to check not completed infodict via the infohash, the
+    -- accumulated pieces will allocate the all available memory.
+    --
+    --   This limit set upper bound for 'InfoDict' size. See
+    --   'ExtendedMetadata' for more info.
+    --
+  , maxInfoDictSize     :: {-# UNPACK #-} !Int
+  } deriving (Show, Eq)
+
+-- | Permissive default parameters, most likely you don't need to
+-- change them.
+instance Default Options where
+  def = Options
+    { keepaliveInterval  = defaultKeepAliveInterval
+    , keepaliveTimeout   = defaultKeepAliveTimeout
+    , requestQueueLength = defaultRequestQueueLength
+    , floodDetector      = def
+    , metadataFactor     = defaultMetadataFactor
+    , maxInfoDictSize    = defaultMaxInfoDictSize
+    }
+
+{-----------------------------------------------------------------------
+--  Peer status
+-----------------------------------------------------------------------}
+
+-- | Connections contain two bits of state on either end: choked or
+-- not, and interested or not.
+data PeerStatus = PeerStatus
+  { -- | Choking is a notification that no data will be sent until
+    -- unchoking happens.
+    _choking    :: !Bool
+
+    -- |
+  , _interested :: !Bool
+  } deriving (Show, Eq, Ord)
+
+$(makeLenses ''PeerStatus)
+
+instance Pretty PeerStatus where
+  pPrint PeerStatus {..} =
+    pPrint (Choking _choking) <+> "and" <+> pPrint (Interested _interested)
+
+-- | Connections start out choked and not interested.
+instance Default PeerStatus where
+  def = PeerStatus True False
+
+instance Monoid PeerStatus where
+  mempty      = def
+  mappend a b = PeerStatus
+    { _choking    = _choking    a && _choking    b
+    , _interested = _interested a || _interested b
+    }
+
+-- | Can be used to update remote peer status using incoming 'Status'
+-- message.
+updateStatus :: StatusUpdate -> PeerStatus -> PeerStatus
+updateStatus (Choking    b) = choking    .~ b
+updateStatus (Interested b) = interested .~ b
+
+-- | Can be used to generate outcoming messages.
+statusUpdates :: PeerStatus -> PeerStatus -> [StatusUpdate]
+statusUpdates a b = M.catMaybes $
+  [ if _choking    a == _choking    b then Nothing
+    else Just $ Choking    $ _choking    b
+  , if _interested a == _interested b then Nothing
+    else Just $ Interested $ _interested b
+  ]
+
+{-----------------------------------------------------------------------
+--  Connection status
+-----------------------------------------------------------------------}
+
+-- | Status of the both endpoints.
+data ConnectionStatus = ConnectionStatus
+  { _clientStatus :: !PeerStatus
+  , _remoteStatus :: !PeerStatus
+  } deriving (Show, Eq)
+
+$(makeLenses ''ConnectionStatus)
+
+instance Pretty ConnectionStatus where
+  pPrint ConnectionStatus {..} =
+    "this  " PP.<+> pPrint _clientStatus PP.$$
+    "remote" PP.<+> pPrint _remoteStatus
+
+-- | Connections start out choked and not interested.
+instance Default ConnectionStatus where
+  def = ConnectionStatus def def
+
+-- | Can the client transfer to the remote peer?
+canUpload :: ConnectionStatus -> Bool
+canUpload ConnectionStatus {..}
+  = _interested _remoteStatus && not (_choking _clientStatus)
+
+-- | Can the client transfer from the remote peer?
+canDownload :: ConnectionStatus -> Bool
+canDownload ConnectionStatus {..}
+  = _interested _clientStatus && not (_choking _remoteStatus)
+
+-- | Indicates how many peers are allowed to download from the client
+-- by default.
+defaultUnchokeSlots :: Int
+defaultUnchokeSlots = 4
+
+-- |
+defaultRechokeInterval :: Int
+defaultRechokeInterval = 10 * 1000 * 1000
+
+{-----------------------------------------------------------------------
+--  Connection
+-----------------------------------------------------------------------}
+
+data ConnectionState = ConnectionState {
+    -- | If @not (allowed ExtExtended connCaps)@ then this set is always
+    -- empty. Otherwise it has the BEP10 extension protocol mandated mapping of
+    -- 'MessageId' to the message type for the remote peer.
+    --
+    --  Note that this value can change in current session if either
+    --  this or remote peer will initiate rehandshaking.
+    --
+    _connExtCaps      :: !ExtendedCaps
+
+    -- | Current extended handshake information from the remote peer
+  , _connRemoteEhs    :: !ExtendedHandshake
+
+    -- | Various stats about messages sent and received. Stats can be
+    -- used to protect /this/ peer against flood attacks.
+    --
+    -- Note that this value will change with the next sent or received
+    -- message.
+  , _connStats        :: !ConnectionStats
+
+  , _connStatus       :: !ConnectionStatus
+
+    -- | Bitfield of remote endpoint.
+  , _connBitfield     :: !Bitfield
+  }
+
+makeLenses ''ConnectionState
+
+instance Default ConnectionState where
+   def = ConnectionState
+     { _connExtCaps      = def
+     , _connRemoteEhs    = def
+     , _connStats        = def
+     , _connStatus       = def
+     , _connBitfield     = BF.haveNone 0
+     }
+
+-- | Connection keep various info about both peers.
+data Connection s = Connection
+  { connInitiatedBy  :: !ChannelSide
+
+  , connRemoteAddr   :: !(PeerAddr IP)
+
+    -- | /Both/ peers handshaked with this protocol string. The only
+    -- value is \"Bittorrent Protocol\" but this can be changed in
+    -- future.
+  , connProtocol     :: !ProtocolName
+
+    -- | Set of enabled core extensions, i.e. the pre BEP10 extension
+    -- mechanism. This value is used to check if a message is allowed
+    -- to be sent or received.
+  , connCaps         :: !Caps
+
+    -- | /Both/ peers handshaked with this infohash. A connection can
+    -- handle only one topic, use 'reconnect' to change the current
+    -- topic.
+  , connTopic        :: !InfoHash
+
+    -- | Typically extracted from handshake.
+  , connRemotePeerId :: !PeerId
+
+    -- | Typically extracted from handshake.
+  , connThisPeerId   :: !PeerId
+
+    -- |
+  , connOptions      :: !Options
+
+    -- | Mutable connection state, see 'ConnectionState'
+  , connState        :: !(IORef ConnectionState)
+
+--    -- | Max request queue length.
+--  , connMaxQueueLen  :: !Int
+
+    -- | Environment data.
+  , connSession      :: !s
+
+  , connChan         :: !(Chan Message)
+  }
+
+instance Pretty (Connection s) where
+  pPrint Connection {..} = "Connection"
+
+instance ToLogStr (Connection s) where
+  toLogStr Connection {..} = mconcat
+    [ toLogStr (show connRemoteAddr)
+    , toLogStr (show connProtocol)
+    , toLogStr (show connCaps)
+    , toLogStr (show connTopic)
+    , toLogStr (show connRemotePeerId)
+    , toLogStr (show connThisPeerId)
+    , toLogStr (show connOptions)
+    ]
+
+-- TODO check extended messages too
+isAllowed :: Connection s -> Message -> Bool
+isAllowed Connection {..} msg
+  | Just ext <- requires msg = ext `allowed` connCaps
+  |          otherwise       = True
+
+{-----------------------------------------------------------------------
+--  Hanshaking
+-----------------------------------------------------------------------}
+
+sendHandshake :: Socket -> Handshake -> IO ()
+sendHandshake sock hs = sendAll sock (S.encode hs)
+
+recvHandshake :: Socket -> IO Handshake
+recvHandshake sock = do
+    header <- BS.recv sock 1
+    unless (BS.length header == 1) $
+      throw $ userError "Unable to receive handshake header."
+
+    let protocolLen = BS.head header
+    let restLen     = handshakeSize protocolLen - 1
+
+    body <- BS.recv sock restLen
+    let resp = BS.cons protocolLen body
+    either (throwIO . userError) return $ S.decode resp
+
+-- | Handshaking with a peer specified by the second argument.
+--
+--   It's important to send handshake first because /accepting/ peer
+--   do not know handshake topic and will wait until /connecting/ peer
+--   will send handshake.
+--
+initiateHandshake :: Socket -> Handshake -> IO Handshake
+initiateHandshake sock hs = do
+  sendHandshake sock hs
+  recvHandshake sock
+
+data HandshakePair = HandshakePair
+  { handshakeSent :: !Handshake
+  , handshakeRecv :: !Handshake
+  } deriving (Show, Eq)
+
+validatePair :: HandshakePair -> PeerAddr IP -> IO ()
+validatePair (HandshakePair hs hs') addr = Prelude.mapM_ checkProp
+  [ (def            == hsProtocol hs', InvalidProtocol    $ hsProtocol hs')
+  , (hsProtocol hs  == hsProtocol hs', UnexpectedProtocol $ hsProtocol hs')
+  , (hsInfoHash hs  == hsInfoHash hs', UnexpectedTopic    $ hsInfoHash hs')
+  , (hsPeerId   hs' == fromMaybe (hsPeerId hs') (peerId addr)
+    , UnexpectedPeerId $ hsPeerId hs')
+  ]
+  where
+    checkProp (t, e) = unless t $ throwIO $ ProtocolError e
+
+-- | Connection state /right/ after handshaking.
+establishedStats :: HandshakePair -> ConnectionStats
+establishedStats HandshakePair {..} = ConnectionStats
+  { outcomingFlow = FlowStats 1 $ handshakeStats handshakeSent
+  , incomingFlow  = FlowStats 1 $ handshakeStats handshakeRecv
+  }
+
+{-----------------------------------------------------------------------
+--  Wire
+-----------------------------------------------------------------------}
+
+-- | do not expose this so we can change it without breaking api
+newtype Connected s a = Connected { runConnected :: (ReaderT (Connection s) IO a) }
+    deriving (Functor, Applicative, Monad
+             , MonadIO, MonadReader (Connection s), MonadThrow
+             )
+
+instance MonadState ConnectionState (Connected s) where
+    get   = Connected (asks connState) >>= liftIO . readIORef
+    put x = Connected (asks connState) >>= liftIO . flip writeIORef x
+
+-- | A duplex channel connected to a remote peer which keep tracks
+-- connection parameters.
+type Wire s a = ConduitM Message Message (Connected s) a
+
+{-----------------------------------------------------------------------
+--  Wrapper
+-----------------------------------------------------------------------}
+
+putStats :: ChannelSide -> Message -> Connected s ()
+putStats side msg = connStats %= addStats side (stats msg)
+
+validate :: ChannelSide -> Message -> Connected s ()
+validate side msg = do
+  caps <- asks connCaps
+  case requires msg of
+    Nothing  -> return ()
+    Just ext
+      | ext `allowed` caps -> return ()
+      |     otherwise      -> protocolError $ DisallowedMessage side ext
+
+trackFlow :: ChannelSide -> Wire s ()
+trackFlow side = iterM $ do
+  validate side
+  putStats side
+
+{-----------------------------------------------------------------------
+--  Setup
+-----------------------------------------------------------------------}
+
+-- System.Timeout.timeout multiplier
+seconds :: Int
+seconds = 1000000
+
+sinkChan :: MonadIO m => Chan Message -> Sink Message m ()
+sinkChan chan = await >>= maybe (return ()) (liftIO . writeChan chan)
+
+sourceChan :: MonadIO m => Int -> Chan Message -> Source m Message
+sourceChan interval chan = do
+  mmsg <- liftIO $ timeout (interval * seconds) $ readChan chan
+  yield $ fromMaybe Msg.KeepAlive mmsg
+
+-- | Normally you should use 'connectWire' or 'acceptWire'.
+runWire :: Wire s () -> Socket -> Chan Message -> Connection s -> IO ()
+runWire action sock chan conn = flip runReaderT conn $ runConnected $
+  sourceSocket sock        $=
+    conduitGet S.get       $=
+      trackFlow RemotePeer $=
+         action            $=
+      trackFlow ThisPeer   C.$$
+    sinkChan chan
+
+-- | This function will block until a peer send new message. You can
+-- also use 'await'.
+recvMessage :: Wire s Message
+recvMessage = await >>= maybe (monadThrow PeerDisconnected) return
+
+-- | You can also use 'yield'.
+sendMessage :: PeerMessage msg => msg -> Wire s ()
+sendMessage msg = do
+  ecaps <- use connExtCaps
+  yield $ envelop ecaps msg
+
+getMaxQueueLength :: Connected s Int
+getMaxQueueLength = do
+  advertisedLen <- ehsQueueLength <$> use connRemoteEhs
+  defaultLen    <- asks (requestQueueLength . connOptions)
+  return $ fromMaybe defaultLen advertisedLen
+
+-- | Filter pending messages from send buffer.
+filterQueue :: (Message -> Bool) -> Wire s ()
+filterQueue p = lift $ do
+  chan <- asks connChan
+  liftIO $ getChanContents chan >>= writeList2Chan chan . L.filter p
+
+-- | Forcefully terminate wire session and close socket.
+disconnectPeer :: Wire s a
+disconnectPeer = monadThrow DisconnectPeer
+
+extendedHandshake :: ExtendedCaps -> Wire s ()
+extendedHandshake caps = do
+  -- TODO add other params to the handshake
+  sendMessage $ nullExtendedHandshake caps
+  msg <- recvMessage
+  case msg of
+    Extended (EHandshake remoteEhs@(ExtendedHandshake {..})) -> do
+      connExtCaps   .= (ehsCaps <> caps)
+      connRemoteEhs .= remoteEhs
+    _ -> protocolError HandshakeRefused
+
+rehandshake :: ExtendedCaps -> Wire s ()
+rehandshake caps = error "rehandshake"
+
+reconnect :: Wire s ()
+reconnect = error "reconnect"
+
+data ConnectionId    = ConnectionId
+  { topic      :: !InfoHash
+  , remoteAddr :: !(PeerAddr IP)
+  , thisAddr   :: !(PeerAddr (Maybe IP)) -- ^ foreign address of this node.
+  }
+
+-- | /Preffered/ settings of wire. To get the real use 'ask'.
+data ConnectionPrefs = ConnectionPrefs
+  { prefOptions  :: !Options
+  , prefProtocol :: !ProtocolName
+  , prefCaps     :: !Caps
+  , prefExtCaps  :: !ExtendedCaps
+  } deriving (Show, Eq)
+
+instance Default ConnectionPrefs where
+  def = ConnectionPrefs
+    { prefOptions  = def
+    , prefProtocol = def
+    , prefCaps     = def
+    , prefExtCaps  = def
+    }
+
+normalize :: ConnectionPrefs -> ConnectionPrefs
+normalize = error "normalize"
+
+-- | Bridge between 'Connection' and 'Network.BitTorrent.Exchange.Session'.
+data SessionLink s = SessionLink
+  { linkTopic        :: !(InfoHash)
+  , linkPeerId       :: !(PeerId)
+  , linkMetadataSize :: !(Maybe Int)
+  , linkOutputChan   :: !(Maybe (Chan Message))
+  , linkSession      :: !(s)
+  }
+
+data ConnectionConfig s = ConnectionConfig
+  { cfgPrefs   :: !(ConnectionPrefs)
+  , cfgSession :: !(SessionLink s)
+  , cfgWire    :: !(Wire s ())
+  }
+
+configHandshake :: ConnectionConfig s -> Handshake
+configHandshake ConnectionConfig {..} = Handshake
+  { hsProtocol = prefProtocol  cfgPrefs
+  , hsReserved = prefCaps      cfgPrefs
+  , hsInfoHash = linkTopic     cfgSession
+  , hsPeerId   = linkPeerId    cfgSession
+  }
+
+{-----------------------------------------------------------------------
+--  Pending connections
+-----------------------------------------------------------------------}
+
+-- | Connection in half opened state. A normal usage scenario:
+--
+--    * Opened using 'newPendingConnection', usually in the listener
+--    loop;
+--
+--    * Closed using 'closePending' if 'pendingPeer' is banned,
+--    'pendingCaps' is prohibited or pendingTopic is unknown;
+--
+--    * Accepted using 'acceptWire' otherwise.
+--
+data PendingConnection = PendingConnection
+  { pendingSock  :: Socket
+  , pendingPeer  :: PeerAddr IP -- ^ 'peerId' is always non empty;
+  , pendingCaps  :: Caps        -- ^ advertised by the peer;
+  , pendingTopic :: InfoHash    -- ^ possible non-existent topic.
+  }
+
+-- | Reconstruct handshake sent by the remote peer.
+pendingHandshake :: PendingConnection -> Handshake
+pendingHandshake PendingConnection {..} = Handshake
+  { hsProtocol = def
+  , hsReserved = pendingCaps
+  , hsInfoHash = pendingTopic
+  , hsPeerId   = fromMaybe (error "pendingHandshake: impossible")
+                           (peerId pendingPeer)
+  }
+
+-- |
+--
+--   This function can throw 'WireFailure' exception.
+--
+newPendingConnection :: Socket -> PeerAddr IP -> IO PendingConnection
+newPendingConnection sock addr = do
+  Handshake {..} <- recvHandshake sock
+  unless (hsProtocol == def) $ do
+    throwIO $ ProtocolError $ InvalidProtocol hsProtocol
+  return PendingConnection
+    { pendingSock  = sock
+    , pendingPeer  = addr { peerId = Just hsPeerId }
+    , pendingCaps  = hsReserved
+    , pendingTopic = hsInfoHash
+    }
+
+-- | Release all resources associated with the given connection. Note
+-- that you /must not/ 'closePending' if you 'acceptWire'.
+closePending :: PendingConnection -> IO ()
+closePending PendingConnection {..} = do
+  close pendingSock
+
+{-----------------------------------------------------------------------
+--  Connection setup
+-----------------------------------------------------------------------}
+
+chanToSock :: Int -> Chan Message -> Socket -> IO ()
+chanToSock ka chan sock =
+  sourceChan ka chan $= conduitPut S.put C.$$ sinkSocket sock
+
+afterHandshaking :: ChannelSide -> PeerAddr IP -> Socket -> HandshakePair
+                 -> ConnectionConfig s -> IO ()
+afterHandshaking initiator addr sock
+  hpair @ (HandshakePair hs hs')
+          (ConnectionConfig
+           { cfgPrefs   = ConnectionPrefs {..}
+           , cfgSession = SessionLink     {..}
+           , cfgWire    = wire
+           }) = do
+    let caps  = hsReserved hs <> hsReserved hs'
+    cstate <- newIORef def { _connStats = establishedStats hpair }
+    chan   <- maybe newChan return linkOutputChan
+    let conn  = Connection {
+          connInitiatedBy  = initiator
+        , connRemoteAddr   = addr
+        , connProtocol     = hsProtocol hs
+        , connCaps         = caps
+        , connTopic        = hsInfoHash hs
+        , connRemotePeerId = hsPeerId   hs'
+        , connThisPeerId   = hsPeerId   hs
+        , connOptions      = def
+        , connState        = cstate
+        , connSession      = linkSession
+        , connChan         = chan
+        }
+
+    -- TODO make KA interval configurable
+    let kaInterval = defaultKeepAliveInterval
+        wire' = if ExtExtended `allowed` caps
+                then extendedHandshake prefExtCaps >> wire
+                else wire
+
+    bracket (forkIO (chanToSock kaInterval chan sock))
+            (killThread)
+            (\ _ -> runWire wire' sock chan conn)
+
+-- | Initiate 'Wire' connection and handshake with a peer. This function will
+-- also do the BEP10 extension protocol handshake if 'ExtExtended' is enabled on
+-- both sides.
+--
+-- This function can throw 'WireFailure' exception.
+--
+connectWire :: PeerAddr IP -> ConnectionConfig s -> IO ()
+connectWire addr cfg = do
+  let catchRefusal m = try m >>= either (throwIO . ConnectionRefused) return
+  bracket (catchRefusal (peerSocket Stream addr)) close $ \ sock -> do
+    let hs = configHandshake cfg
+    hs' <- initiateHandshake sock hs
+    let hpair = HandshakePair hs hs'
+    validatePair hpair addr
+    afterHandshaking ThisPeer addr sock hpair cfg
+
+-- | Accept 'Wire' connection using already 'Network.Socket.accept'ed
+--   socket. For peer listener loop the 'acceptSafe' should be
+--   prefered against 'accept'. The socket will be closed at exit.
+--
+--   This function can throw 'WireFailure' exception.
+--
+acceptWire :: PendingConnection -> ConnectionConfig s -> IO ()
+acceptWire pc @ PendingConnection {..} cfg = do
+  bracket (return pendingSock) close $ \ _ -> do
+    unless (linkTopic (cfgSession cfg) == pendingTopic) $ do
+      throwIO (ProtocolError (UnexpectedTopic pendingTopic))
+
+    let hs = configHandshake cfg
+    sendHandshake pendingSock hs
+    let hpair = HandshakePair hs (pendingHandshake pc)
+
+    afterHandshaking RemotePeer pendingPeer pendingSock hpair cfg
+
+-- | Used when size of bitfield becomes known.
+resizeBitfield :: Int -> Connected s ()
+resizeBitfield n = connBitfield %= adjustSize n
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Download.hs b/bittorrent/src/Network/BitTorrent/Exchange/Download.hs
new file mode 100644
index 00000000..981db2fb
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Download.hs
@@ -0,0 +1,296 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--
+--
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TemplateHaskell        #-}
+module Network.BitTorrent.Exchange.Download
+       ( -- * Downloading
+         Download (..)
+       , Updates
+       , runDownloadUpdates
+
+         -- ** Metadata
+         -- $metadata-download
+       , MetadataDownload
+       , metadataDownload
+
+         -- ** Content
+         -- $content-download
+       , ContentDownload
+       , contentDownload
+       ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Lens
+import Control.Monad.State
+import Data.BEncode as BE
+import Data.ByteString as BS
+import Data.ByteString.Lazy as BL
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Data.Map as M
+import Data.Tuple
+
+import Data.Torrent as Torrent
+import Network.Address
+import Network.BitTorrent.Exchange.Bitfield as BF
+import Network.BitTorrent.Exchange.Block    as Block
+import Network.BitTorrent.Exchange.Message  as Msg
+import System.Torrent.Storage (Storage, writePiece)
+
+
+{-----------------------------------------------------------------------
+--  Class
+-----------------------------------------------------------------------}
+
+type Updates s a = StateT s IO a
+
+runDownloadUpdates :: MVar s -> Updates s a -> IO a
+runDownloadUpdates var m = modifyMVar var (fmap swap . runStateT m)
+
+class Download s chunk | s -> chunk where
+  scheduleBlocks :: Int -> PeerAddr IP -> Bitfield -> Updates s [BlockIx]
+
+  -- |
+  scheduleBlock  :: PeerAddr IP -> Bitfield -> Updates s (Maybe BlockIx)
+  scheduleBlock addr bf = listToMaybe <$> scheduleBlocks 1 addr bf
+
+  -- | Get number of sent requests to this peer.
+  getRequestQueueLength :: PeerAddr IP -> Updates s Int
+
+  -- | Remove all pending block requests to the remote peer. May be used
+  -- when:
+  --
+  --     * a peer closes connection;
+  --
+  --     * remote peer choked this peer;
+  --
+  --     * timeout expired.
+  --
+  resetPending :: PeerAddr IP -> Updates s ()
+
+  -- | MAY write to storage, if a new piece have been completed.
+  --
+  --  You should check if a returned by peer block is actually have
+  -- been requested and in-flight. This is needed to avoid "I send
+  -- random corrupted block" attacks.
+  pushBlock :: PeerAddr IP -> chunk -> Updates s (Maybe Bool)
+
+{-----------------------------------------------------------------------
+--  Metadata download
+-----------------------------------------------------------------------}
+-- $metadata-download
+-- TODO
+
+data MetadataDownload = MetadataDownload
+  { _pendingPieces :: [(PeerAddr IP, PieceIx)]
+  , _bucket        :: Bucket
+  , _topic         :: InfoHash
+  }
+
+makeLenses ''MetadataDownload
+
+-- | Create a new scheduler for infodict of the given size.
+metadataDownload :: Int -> InfoHash -> MetadataDownload
+metadataDownload ps = MetadataDownload [] (Block.empty ps)
+
+instance Default MetadataDownload where
+  def = error "instance Default MetadataDownload"
+
+--cancelPending :: PieceIx -> Updates ()
+cancelPending pix = pendingPieces %= L.filter ((pix ==) . snd)
+
+instance Download MetadataDownload (Piece BS.ByteString) where
+  scheduleBlock addr bf = do
+    bkt  <- use bucket
+    case spans metadataPieceSize bkt of
+      []              -> return Nothing
+      ((off, _ ) : _) -> do
+        let pix = off `div` metadataPieceSize
+        pendingPieces %= ((addr, pix) :)
+        return (Just (BlockIx pix 0 metadataPieceSize))
+
+  resetPending addr = pendingPieces %= L.filter ((addr ==) . fst)
+
+  pushBlock addr Torrent.Piece {..} = do
+    p    <- use pendingPieces
+    when ((addr, pieceIndex) `L.notElem` p) $
+      error "not requested"
+    cancelPending pieceIndex
+
+    bucket %= Block.insert (metadataPieceSize * pieceIndex) pieceData
+    b <- use bucket
+    case toPiece b of
+      Nothing     -> return Nothing
+      Just chunks -> do
+          t <- use topic
+          case parseInfoDict (BL.toStrict chunks) t of
+            Right x -> do
+                pendingPieces .= []
+                return undefined -- (Just x)
+            Left  e -> do
+                pendingPieces .= []
+                bucket .= Block.empty (Block.size b)
+                return undefined -- Nothing
+   where
+      -- todo use incremental parsing to avoid BS.concat call
+      parseInfoDict :: BS.ByteString -> InfoHash -> Result InfoDict
+      parseInfoDict chunk topic =
+        case BE.decode chunk of
+          Right (infodict @ InfoDict {..})
+            | topic == idInfoHash -> return infodict
+            |      otherwise      -> Left "broken infodict"
+          Left err -> Left $ "unable to parse infodict " ++ err
+
+{-----------------------------------------------------------------------
+--  Content download
+-----------------------------------------------------------------------}
+-- $content-download
+--
+--  A block can have one of the following status:
+--
+--     1) /not allowed/: Piece is not in download set.
+--
+--     2) /waiting/: (allowed?) Block have been allowed to download,
+--     but /this/ peer did not send any 'Request' message for this
+--     block. To allow some piece use
+--     'Network.BitTorrent.Exchange.Selector' and then 'allowedSet'
+--     and 'allowPiece'.
+--
+--     3) /inflight/: (pending?) Block have been requested but
+--     /remote/ peer did not send any 'Piece' message for this block.
+--     Related functions 'markInflight'
+--
+--     4) /pending/: (stalled?) Block have have been downloaded
+--     Related functions 'insertBlock'.
+--
+--   Piece status:
+--
+--     1) /assembled/: (downloaded?) All blocks in piece have been
+--     downloaded but the piece did not verified yet.
+--
+--       * Valid: go to completed;
+--
+--       * Invalid: go to waiting.
+--
+--     2) /corrupted/:
+--
+--     3) /downloaded/: (verified?) A piece have been successfully
+--     verified via the hash. Usually the piece should be stored to
+--     the 'System.Torrent.Storage' and /this/ peer should send 'Have'
+--     messages to the /remote/ peers.
+--
+
+data PieceEntry = PieceEntry
+  { pending :: [(PeerAddr IP, BlockIx)]
+  , stalled :: Bucket
+  }
+
+pieceEntry :: PieceSize -> PieceEntry
+pieceEntry s = PieceEntry [] (Block.empty s)
+
+isEmpty :: PieceEntry -> Bool
+isEmpty PieceEntry {..} = L.null pending && Block.null stalled
+
+_holes :: PieceIx -> PieceEntry -> [BlockIx]
+_holes pix PieceEntry {..} = fmap mkBlockIx (spans defaultTransferSize stalled)
+  where
+    mkBlockIx (off, sz) = BlockIx pix off sz
+
+data ContentDownload = ContentDownload
+  { inprogress     :: !(Map PieceIx PieceEntry)
+  , bitfield       :: !Bitfield
+  , pieceSize      :: !PieceSize
+  , contentStorage ::  Storage
+  }
+
+contentDownload :: Bitfield -> PieceSize -> Storage -> ContentDownload
+contentDownload = ContentDownload M.empty
+
+--modifyEntry :: PieceIx -> (PieceEntry -> PieceEntry) -> DownloadUpdates ()
+modifyEntry pix f = modify $ \ s @ ContentDownload {..} -> s
+    { inprogress = alter (g pieceSize) pix inprogress }
+  where
+    g s = h . f . fromMaybe (pieceEntry s)
+    h e
+      | isEmpty e = Nothing
+      | otherwise = Just e
+
+instance Download ContentDownload (Block BL.ByteString) where
+  scheduleBlocks n addr maskBF = do
+    ContentDownload {..} <- get
+    let wantPieces = maskBF `BF.difference` bitfield
+    let wantBlocks = L.concat $ M.elems $ M.mapWithKey _holes $
+                     M.filterWithKey (\ pix _ -> pix `BF.member` wantPieces)
+                      inprogress
+
+    bixs <- if L.null wantBlocks
+      then do
+        mpix <- choosePiece wantPieces
+        case mpix of -- TODO return 'n' blocks
+          Nothing  -> return []
+          Just pix -> return [leadingBlock pix defaultTransferSize]
+      else chooseBlocks wantBlocks n
+
+    forM_ bixs $ \ bix -> do
+      modifyEntry (ixPiece bix) $ \ e @ PieceEntry {..} -> e
+        { pending = (addr, bix) : pending }
+
+    return bixs
+    where
+      -- TODO choose block nearest to pending or stalled sets to reduce disk
+      -- seeks on remote machines
+      --chooseBlocks :: [BlockIx] -> Int -> DownloadUpdates [BlockIx]
+      chooseBlocks xs n = return (L.take n xs)
+
+      -- TODO use selection strategies from Exchange.Selector
+      --choosePiece :: Bitfield -> DownloadUpdates (Maybe PieceIx)
+      choosePiece bf
+        | BF.null bf = return $ Nothing
+        | otherwise  = return $ Just $ BF.findMin bf
+
+  getRequestQueueLength addr = do
+    m <- gets (M.map (L.filter ((==) addr . fst) . pending) . inprogress)
+    return $ L.sum $ L.map L.length $ M.elems m
+
+  resetPending addr = modify $ \ s -> s { inprogress = reset (inprogress s) }
+    where
+      reset = fmap $ \ e -> e
+            { pending = L.filter (not . (==) addr . fst) (pending e) }
+
+  pushBlock addr blk @ Block {..} = do
+    mpe <- gets (M.lookup blkPiece . inprogress)
+    case mpe of
+      Nothing -> return Nothing
+      Just (pe @ PieceEntry {..})
+        | blockIx blk `L.notElem` fmap snd pending -> return Nothing
+        |             otherwise                    -> do
+         let bkt' = Block.insertLazy blkOffset blkData stalled
+         case toPiece bkt' of
+           Nothing        -> do
+             modifyEntry blkPiece $ \ e @ PieceEntry {..} -> e
+               { pending = L.filter ((==) (blockIx blk) . snd) pending
+               , stalled = bkt'
+               }
+             return (Just False)
+
+           Just pieceData -> do
+             -- TODO verify
+             storage <- gets contentStorage
+             liftIO $ writePiece (Torrent.Piece blkPiece pieceData) storage
+             modify $ \ s @ ContentDownload {..} -> s
+               { inprogress =  M.delete blkPiece inprogress
+               , bitfield   = BF.insert blkPiece bitfield
+               }
+             return (Just True)
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs b/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs
new file mode 100644
index 00000000..30a6a607
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs
@@ -0,0 +1,62 @@
+module Network.BitTorrent.Exchange.Manager
+       ( Options (..)
+       , Manager
+       , Handler
+       , newManager
+       , closeManager
+       ) where
+
+import Control.Concurrent
+import Control.Exception hiding (Handler)
+import Control.Monad
+import Data.Default
+import Network.Socket
+
+import Data.Torrent
+import Network.Address
+import Network.BitTorrent.Exchange.Connection hiding (Options)
+import Network.BitTorrent.Exchange.Session
+
+
+data Options = Options
+  { optBacklog  :: Int
+  , optPeerAddr :: PeerAddr IP
+  } deriving (Show, Eq)
+
+instance Default Options where
+  def = Options
+    { optBacklog  = maxListenQueue
+    , optPeerAddr = def
+    }
+
+data Manager = Manager
+  { listener :: !ThreadId
+  }
+
+type Handler = InfoHash -> IO Session
+
+handleNewConn :: Socket -> PeerAddr IP -> Handler -> IO ()
+handleNewConn sock addr handler = do
+  conn <- newPendingConnection sock addr
+  ses  <- handler (pendingTopic conn) `onException` closePending conn
+  establish conn ses
+
+listenIncoming :: Options -> Handler -> IO ()
+listenIncoming Options {..} handler = do
+  bracket (socket AF_INET Stream defaultProtocol) close $ \ sock -> do
+    bind sock (toSockAddr optPeerAddr)
+    listen sock optBacklog
+    forever $ do
+      (conn, sockAddr) <- accept sock
+      case fromSockAddr sockAddr of
+        Nothing   -> return ()
+        Just addr -> void $ forkIO $ handleNewConn sock addr handler
+
+newManager :: Options -> Handler -> IO Manager
+newManager opts handler = do
+  tid <- forkIO $ listenIncoming opts handler
+  return (Manager tid)
+
+closeManager :: Manager -> IO ()
+closeManager Manager {..} = do
+  killThread listener
\ No newline at end of file
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Message.hs b/bittorrent/src/Network/BitTorrent/Exchange/Message.hs
new file mode 100644
index 00000000..2c6770f7
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Message.hs
@@ -0,0 +1,1232 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Normally peer to peer communication consisting of the following
+--   steps:
+--
+--   * In order to establish the connection between peers we should
+--   send 'Handshake' message. The 'Handshake' is a required message
+--   and must be the first message transmitted by the peer to the
+--   another peer. Another peer should reply with a handshake as well.
+--
+--   * Next peer might sent bitfield message, but might not. In the
+--   former case we should update bitfield peer have. Again, if we
+--   have some pieces we should send bitfield. Normally bitfield
+--   message should sent after the handshake message.
+--
+--   * Regular exchange messages. TODO docs
+--
+--   For more high level API see "Network.BitTorrent.Exchange" module.
+--
+--   For more infomation see:
+--   <https://wiki.theory.org/BitTorrentSpecification#Peer_wire_protocol_.28TCP.29>
+--
+{-# LANGUAGE ViewPatterns               #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# OPTIONS  -fno-warn-orphans          #-}
+module Network.BitTorrent.Exchange.Message
+       ( -- * Capabilities
+         Capabilities (..)
+       , Extension (..)
+       , Caps
+
+         -- * Handshake
+       , ProtocolName
+       , Handshake(..)
+       , defaultHandshake
+       , handshakeSize
+       , handshakeMaxSize
+       , handshakeStats
+
+         -- * Stats
+       , ByteCount
+       , ByteStats   (..)
+       , byteLength
+
+         -- * Messages
+       , Message        (..)
+       , defaultKeepAliveTimeout
+       , defaultKeepAliveInterval
+       , PeerMessage    (..)
+
+         -- ** Core messages
+       , StatusUpdate   (..)
+       , Available      (..)
+       , Transfer       (..)
+       , defaultRequestQueueLength
+
+         -- ** Fast extension
+       , FastMessage    (..)
+
+         -- ** Extension protocol
+       , ExtendedMessage   (..)
+
+         -- *** Capabilities
+       , ExtendedExtension (..)
+       , ExtendedCaps      (..)
+
+         -- *** Handshake
+       , ExtendedHandshake (..)
+       , defaultQueueLength
+       , nullExtendedHandshake
+
+         -- *** Metadata
+       , ExtendedMetadata  (..)
+       , metadataPieceSize
+       , defaultMetadataFactor
+       , defaultMaxInfoDictSize
+       , isLastPiece
+       , isValidPiece
+       ) where
+
+import Control.Applicative
+import Control.Arrow ((&&&), (***))
+import Control.Monad (when)
+import Data.Attoparsec.ByteString.Char8 as BS
+import Data.BEncode as BE
+import Data.BEncode.BDict as BE
+import Data.BEncode.Internal as BE (ppBEncode, parser)
+import Data.BEncode.Types    (BDict)
+import Data.Bits
+import Data.ByteString as BS
+import Data.ByteString.Char8 as BC
+import Data.ByteString.Lazy  as BL
+import Data.Default
+import Data.List as L
+import Data.Map.Strict as M
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import Data.Serialize as S
+import Data.String
+import Data.Text as T
+import Data.Typeable
+import Data.Word
+import Data.IP
+import Network
+import Network.Socket hiding (KeepAlive)
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+
+import Data.Torrent hiding (Piece (..))
+import qualified Data.Torrent as P (Piece (..))
+import Network.Address
+import Network.BitTorrent.Exchange.Bitfield
+import Network.BitTorrent.Exchange.Block
+
+{-----------------------------------------------------------------------
+--  Capabilities
+-----------------------------------------------------------------------}
+
+-- |
+class Capabilities caps where
+  type Ext caps :: *
+
+  -- | Pack extensions to caps.
+  toCaps   :: [Ext caps] -> caps
+
+  -- | Unpack extensions from caps.
+  fromCaps :: caps -> [Ext caps]
+
+  -- | Check if an extension is a member of the specified set.
+  allowed  :: Ext caps -> caps -> Bool
+
+ppCaps :: Capabilities caps => Pretty (Ext caps) => caps -> Doc
+ppCaps = hcat . punctuate ", " . L.map pPrint . fromCaps
+
+{-----------------------------------------------------------------------
+--  Extensions
+-----------------------------------------------------------------------}
+
+-- | Enumeration of message extension protocols.
+--
+--   For more info see: <http://www.bittorrent.org/beps/bep_0004.html>
+--
+data Extension
+  = ExtDHT      -- ^ BEP 5:  allow to send PORT messages.
+  | ExtFast     -- ^ BEP 6:  allow to send FAST messages.
+  | ExtExtended -- ^ BEP 10: allow to send the extension protocol messages.
+    deriving (Show, Eq, Ord, Enum, Bounded)
+
+-- | Full extension names, suitable for logging.
+instance Pretty Extension where
+  pPrint ExtDHT      = "Distributed Hash Table Protocol"
+  pPrint ExtFast     = "Fast Extension"
+  pPrint ExtExtended = "Extension Protocol"
+
+-- | Extension bitmask as specified by BEP 4.
+extMask :: Extension -> Word64
+extMask ExtDHT      = 0x01
+extMask ExtFast     = 0x04
+extMask ExtExtended = 0x100000
+
+{-----------------------------------------------------------------------
+--  Capabilities
+-----------------------------------------------------------------------}
+
+-- | Capabilities is a set of 'Extension's usually sent in 'Handshake'
+-- messages.
+newtype Caps = Caps Word64
+  deriving (Show, Eq)
+
+-- | Render set of extensions as comma separated list.
+instance Pretty Caps where
+  pPrint = ppCaps
+  {-# INLINE pPrint #-}
+
+-- | The empty set.
+instance Default Caps where
+  def = Caps 0
+  {-# INLINE def #-}
+
+-- | Monoid under intersection. 'mempty' includes all known extensions.
+instance Monoid Caps where
+  mempty = toCaps [minBound .. maxBound]
+  {-# INLINE mempty #-}
+
+  mappend (Caps a) (Caps b) = Caps (a .&. b)
+  {-# INLINE mappend #-}
+
+-- | 'Handshake' compatible encoding.
+instance Serialize Caps where
+  put (Caps caps) = S.putWord64be caps
+  {-# INLINE put #-}
+
+  get = Caps <$> S.getWord64be
+  {-# INLINE get #-}
+
+instance Capabilities Caps where
+  type Ext Caps = Extension
+
+  allowed e (Caps caps) = (extMask e .&. caps) /= 0
+  {-# INLINE allowed #-}
+
+  toCaps        = Caps . L.foldr (.|.) 0 . L.map extMask
+  fromCaps caps = L.filter (`allowed` caps) [minBound..maxBound]
+
+{-----------------------------------------------------------------------
+    Handshake
+-----------------------------------------------------------------------}
+
+maxProtocolNameSize :: Word8
+maxProtocolNameSize = maxBound
+
+-- | The protocol name is used to identify to the local peer which
+-- version of BTP the remote peer uses.
+newtype ProtocolName = ProtocolName BS.ByteString
+  deriving (Eq, Ord, Typeable)
+
+-- | In BTP/1.0 the name is 'BitTorrent protocol'. If this string is
+-- different from the local peers own protocol name, then the
+-- connection is to be dropped.
+instance Default ProtocolName where
+  def = ProtocolName "BitTorrent protocol"
+
+instance Show ProtocolName where
+  show (ProtocolName bs) = show bs
+
+instance Pretty ProtocolName where
+  pPrint (ProtocolName bs) = PP.text $ BC.unpack bs
+
+instance IsString ProtocolName where
+  fromString str
+    | L.length str <= fromIntegral maxProtocolNameSize
+    = ProtocolName (fromString str)
+    | otherwise = error $ "fromString: ProtocolName too long: " ++ str
+
+instance Serialize ProtocolName where
+  put (ProtocolName bs) = do
+    putWord8 $ fromIntegral $ BS.length bs
+    putByteString bs
+
+  get = do
+    len  <- getWord8
+    bs   <- getByteString $ fromIntegral len
+    return (ProtocolName bs)
+
+-- | Handshake message is used to exchange all information necessary
+-- to establish connection between peers.
+--
+data Handshake = Handshake {
+    -- | Identifier of the protocol. This is usually equal to 'def'.
+    hsProtocol    :: ProtocolName
+
+    -- | Reserved bytes used to specify supported BEP's.
+  , hsReserved    :: Caps
+
+    -- | Info hash of the info part of the metainfo file. that is
+    -- transmitted in tracker requests. Info hash of the initiator
+    -- handshake and response handshake should match, otherwise
+    -- initiator should break the connection.
+    --
+  , hsInfoHash    :: InfoHash
+
+    -- | Peer id of the initiator. This is usually the same peer id
+    -- that is transmitted in tracker requests.
+    --
+  , hsPeerId      :: PeerId
+
+  } deriving (Show, Eq)
+
+instance Serialize Handshake where
+  put Handshake {..} = do
+    put hsProtocol
+    put hsReserved
+    put hsInfoHash
+    put hsPeerId
+  get = Handshake <$> get <*> get <*> get <*> get
+
+-- | Show handshake protocol string, caps and fingerprint.
+instance Pretty Handshake where
+  pPrint Handshake {..}
+    = pPrint hsProtocol           $$
+      pPrint hsReserved           $$
+      pPrint (fingerprint hsPeerId)
+
+-- | Get handshake message size in bytes from the length of protocol
+-- string.
+handshakeSize :: Word8 -> Int
+handshakeSize n = 1 + fromIntegral n + 8 + 20 + 20
+
+-- | Maximum size of handshake message in bytes.
+handshakeMaxSize :: Int
+handshakeMaxSize = handshakeSize maxProtocolNameSize
+
+-- | Handshake with default protocol string and reserved bitmask.
+defaultHandshake :: InfoHash -> PeerId -> Handshake
+defaultHandshake = Handshake def def
+
+handshakeStats :: Handshake -> ByteStats
+handshakeStats (Handshake (ProtocolName bs) _ _ _)
+  = ByteStats 1 (BS.length bs + 8 + 20 + 20) 0
+
+{-----------------------------------------------------------------------
+--  Stats
+-----------------------------------------------------------------------}
+
+-- | Number of bytes.
+type ByteCount = Int
+
+-- | Summary of encoded message byte layout can be used to collect
+-- stats about message flow in both directions. This data can be
+-- retrieved using 'stats' function.
+data ByteStats = ByteStats
+  { -- | Number of bytes used to help encode 'control' and 'payload'
+    -- bytes: message size, message ID's, etc
+    overhead :: {-# UNPACK #-} !ByteCount
+
+    -- | Number of bytes used to exchange peers state\/options: piece
+    -- and block indexes, infohash, port numbers, peer ID\/IP, etc.
+  , control  :: {-# UNPACK #-} !ByteCount
+
+    -- | Number of payload bytes: torrent data blocks and infodict
+    -- metadata.
+  , payload  :: {-# UNPACK #-} !ByteCount
+  } deriving Show
+
+instance Pretty ByteStats where
+  pPrint s @ ByteStats {..} = fsep
+    [ PP.int overhead, "overhead"
+    , PP.int control,  "control"
+    , PP.int payload,  "payload"
+    , "bytes"
+    ] $+$ fsep
+    [ PP.int (byteLength s), "total bytes"
+    ]
+
+-- | Empty byte sequences.
+instance Default ByteStats where
+  def = ByteStats 0 0 0
+
+-- | Monoid under addition.
+instance Monoid ByteStats where
+  mempty      = def
+  mappend a b = ByteStats
+    { overhead = overhead a + overhead b
+    , control  = control  a + control  b
+    , payload  = payload  a + payload  b
+    }
+
+-- | Sum of the all byte sequences.
+byteLength :: ByteStats -> Int
+byteLength ByteStats {..} = overhead + control + payload
+
+{-----------------------------------------------------------------------
+--  Regular messages
+-----------------------------------------------------------------------}
+
+-- | Messages which can be sent after handshaking. Minimal complete
+-- definition: 'envelop'.
+class PeerMessage a where
+  -- | Construct a message to be /sent/. Note that if 'ExtendedCaps'
+  -- do not contain mapping for this message the default
+  -- 'ExtendedMessageId' is used.
+  envelop :: ExtendedCaps -- ^ The /receiver/ extended capabilities;
+          -> a            -- ^ An regular message;
+          -> Message      -- ^ Enveloped message to sent.
+
+  -- | Find out the extension this message belong to. Can be used to
+  -- check if this message is allowed to send\/recv in current
+  -- session.
+  requires :: a -> Maybe Extension
+  requires _ = Nothing
+
+  -- | Get sizes of overhead\/control\/payload byte sequences of
+  -- binary message representation without encoding message to binary
+  -- bytestring.
+  --
+  --   This function should obey one law:
+  --
+  --     * 'byteLength' ('stats' msg) == 'BL.length' ('encode' msg)
+  --
+  stats :: a -> ByteStats
+  stats _ = ByteStats 4 0 0
+
+{-----------------------------------------------------------------------
+--  Status messages
+-----------------------------------------------------------------------}
+
+-- | Notification that the sender have updated its
+-- 'Network.BitTorrent.Exchange.Status.PeerStatus'.
+data StatusUpdate
+    -- | Notification that the sender will not upload data to the
+    -- receiver until unchoking happen.
+  = Choking    !Bool
+
+    -- | Notification that the sender is interested (or not interested)
+    -- in any of the receiver's data pieces.
+  | Interested !Bool
+    deriving (Show, Eq, Ord, Typeable)
+
+instance Pretty StatusUpdate where
+  pPrint (Choking    False) = "not choking"
+  pPrint (Choking    True ) = "choking"
+  pPrint (Interested False) = "not interested"
+  pPrint (Interested True ) = "interested"
+
+instance PeerMessage StatusUpdate where
+  envelop _ = Status
+  {-# INLINE envelop #-}
+
+  stats _ = ByteStats 4 1 0
+  {-# INLINE stats #-}
+
+{-----------------------------------------------------------------------
+--  Available messages
+-----------------------------------------------------------------------}
+
+-- | Messages used to inform receiver which pieces of the torrent
+-- sender have.
+data Available =
+    -- | Zero-based index of a piece that has just been successfully
+    -- downloaded and verified via the hash.
+    Have    ! PieceIx
+
+    -- | The bitfield message may only be sent immediately after the
+    -- handshaking sequence is complete, and before any other message
+    -- are sent. If client have no pieces then bitfield need not to be
+    -- sent.
+  | Bitfield !Bitfield
+    deriving (Show, Eq)
+
+instance Pretty Available where
+  pPrint (Have     ix ) = "Have"     <+> int ix
+  pPrint (Bitfield _  ) = "Bitfield"
+
+instance PeerMessage Available where
+  envelop _ = Available
+  {-# INLINE envelop #-}
+
+  stats (Have      _) = ByteStats (4 + 1) 4 0
+  stats (Bitfield bf) = ByteStats (4 + 1) (q + trailing)  0
+    where
+      trailing = if r == 0 then 0 else 1
+      (q, r) = quotRem (totalCount bf) 8
+
+{-----------------------------------------------------------------------
+--  Transfer messages
+-----------------------------------------------------------------------}
+
+-- | Messages used to transfer 'Block's.
+data Transfer
+    -- | Request for a particular block. If a client is requested a
+    -- block that another peer do not have the peer might not answer
+    -- at all.
+  = Request ! BlockIx
+
+    -- | Response to a request for a block.
+  | Piece   !(Block BL.ByteString)
+
+    -- | Used to cancel block requests. It is typically used during
+    -- "End Game".
+  | Cancel  !BlockIx
+    deriving (Show, Eq)
+
+instance Pretty Transfer where
+  pPrint (Request  ix ) = "Request"  <+> pPrint ix
+  pPrint (Piece    blk) = "Piece"    <+> pPrint blk
+  pPrint (Cancel   i  ) = "Cancel"   <+> pPrint i
+
+instance PeerMessage Transfer where
+  envelop _ = Transfer
+  {-# INLINE envelop #-}
+
+  stats (Request _  ) = ByteStats (4 + 1) (3 * 4) 0
+  stats (Piece   p  ) = ByteStats (4 + 1) (4 + 4 + blockSize p) 0
+  stats (Cancel  _  ) = ByteStats (4 + 1) (3 * 4) 0
+
+-- TODO increase
+-- | Max number of pending 'Request's inflight.
+defaultRequestQueueLength :: Int
+defaultRequestQueueLength = 1
+
+{-----------------------------------------------------------------------
+--  Fast messages
+-----------------------------------------------------------------------}
+
+-- | BEP6 messages.
+data FastMessage =
+    -- | If a peer have all pieces it might send the 'HaveAll' message
+    -- instead of 'Bitfield' message. Used to save bandwidth.
+    HaveAll
+
+    -- | If a peer have no pieces it might send 'HaveNone' message
+    -- intead of 'Bitfield' message. Used to save bandwidth.
+  | HaveNone
+
+    -- | This is an advisory message meaning "you might like to
+    -- download this piece." Used to avoid excessive disk seeks and
+    -- amount of IO.
+  | SuggestPiece  !PieceIx
+
+    -- | Notifies a requesting peer that its request will not be
+    -- satisfied.
+  | RejectRequest !BlockIx
+
+    -- | This is an advisory messsage meaning \"if you ask for this
+    -- piece, I'll give it to you even if you're choked.\" Used to
+    -- shorten starting phase.
+  | AllowedFast   !PieceIx
+    deriving (Show, Eq)
+
+instance Pretty FastMessage where
+  pPrint (HaveAll          ) = "Have all"
+  pPrint (HaveNone         ) = "Have none"
+  pPrint (SuggestPiece  pix) = "Suggest"      <+> int    pix
+  pPrint (RejectRequest bix) = "Reject"       <+> pPrint bix
+  pPrint (AllowedFast   pix) = "Allowed fast" <+> int    pix
+
+instance PeerMessage FastMessage where
+  envelop  _ = Fast
+  {-# INLINE envelop #-}
+
+  requires _ = Just ExtFast
+  {-# INLINE requires #-}
+
+  stats  HaveAll          = ByteStats 4 1  0
+  stats  HaveNone         = ByteStats 4 1  0
+  stats (SuggestPiece  _) = ByteStats 5 4  0
+  stats (RejectRequest _) = ByteStats 5 12 0
+  stats (AllowedFast   _) = ByteStats 5 4  0
+
+{-----------------------------------------------------------------------
+--  Extension protocol
+-----------------------------------------------------------------------}
+
+{-----------------------------------------------------------------------
+--  Extended capabilities
+-----------------------------------------------------------------------}
+
+data ExtendedExtension
+  = ExtMetadata -- ^ BEP 9: Extension for Peers to Send Metadata Files
+    deriving (Show, Eq, Ord, Enum, Bounded, Typeable)
+
+instance IsString ExtendedExtension where
+  fromString = fromMaybe (error msg) . fromKey . fromString
+    where
+      msg = "fromString: could not parse ExtendedExtension"
+
+instance Pretty ExtendedExtension where
+  pPrint ExtMetadata = "Extension for Peers to Send Metadata Files"
+
+fromKey :: BKey -> Maybe ExtendedExtension
+fromKey "ut_metadata" = Just ExtMetadata
+fromKey _             = Nothing
+{-# INLINE fromKey #-}
+
+toKey :: ExtendedExtension -> BKey
+toKey ExtMetadata = "ut_metadata"
+{-# INLINE toKey #-}
+
+type ExtendedMessageId = Word8
+
+extId :: ExtendedExtension -> ExtendedMessageId
+extId ExtMetadata = 1
+{-# INLINE extId #-}
+
+type ExtendedMap = Map ExtendedExtension ExtendedMessageId
+
+-- | The extension IDs must be stored for every peer, because every
+-- peer may have different IDs for the same extension.
+--
+newtype ExtendedCaps = ExtendedCaps { extendedCaps :: ExtendedMap }
+  deriving (Show, Eq)
+
+instance Pretty ExtendedCaps where
+  pPrint = ppCaps
+  {-# INLINE pPrint #-}
+
+-- | The empty set.
+instance Default ExtendedCaps where
+  def = ExtendedCaps M.empty
+
+-- | Monoid under intersection:
+--
+--     * The 'mempty' caps includes all known extensions;
+--
+--     * the 'mappend' operation is NOT commutative: it return message
+-- id from the first caps for the extensions existing in both caps.
+--
+instance Monoid ExtendedCaps where
+  mempty  = toCaps [minBound..maxBound]
+  mappend (ExtendedCaps a) (ExtendedCaps b) =
+    ExtendedCaps (M.intersection a b)
+
+appendBDict ::  BDict -> ExtendedMap -> ExtendedMap
+appendBDict (Cons key val xs) caps
+  | Just  ext <- fromKey     key
+  , Right eid <- fromBEncode val   = M.insert ext eid (appendBDict xs caps)
+  |           otherwise            = appendBDict xs caps
+appendBDict  Nil              caps = caps
+
+-- | Handshake compatible encoding.
+instance BEncode ExtendedCaps where
+  toBEncode = BDict . BE.fromAscList . L.sortBy (comparing fst)
+            . L.map (toKey *** toBEncode) . M.toList . extendedCaps
+
+  fromBEncode (BDict bd) = pure $ ExtendedCaps $ appendBDict bd M.empty
+  fromBEncode _          = decodingError "ExtendedCaps"
+
+instance Capabilities ExtendedCaps where
+  type Ext ExtendedCaps = ExtendedExtension
+
+  toCaps = ExtendedCaps . M.fromList . L.map (id &&& extId)
+
+  fromCaps = M.keys . extendedCaps
+  {-# INLINE fromCaps #-}
+
+  allowed e (ExtendedCaps caps) = M.member e caps
+  {-# INLINE allowed #-}
+
+remoteMessageId :: ExtendedExtension -> ExtendedCaps -> ExtendedMessageId
+remoteMessageId ext = fromMaybe (extId ext) . M.lookup ext . extendedCaps
+
+{-----------------------------------------------------------------------
+--  Extended handshake
+-----------------------------------------------------------------------}
+
+-- | This message should be sent immediately after the standard
+-- bittorrent handshake to any peer that supports this extension
+-- protocol. Extended handshakes can be sent more than once, however
+-- an implementation may choose to ignore subsequent handshake
+-- messages.
+--
+data ExtendedHandshake = ExtendedHandshake
+  { -- | If this peer has an IPv4 interface, this is the compact
+    -- representation of that address.
+    ehsIPv4        :: Maybe HostAddress
+
+    -- | If this peer has an IPv6 interface, this is the compact
+    -- representation of that address.
+  , ehsIPv6        :: Maybe HostAddress6
+
+    -- | Dictionary of supported extension messages which maps names
+    -- of extensions to an extended message ID for each extension
+    -- message.
+  , ehsCaps        :: ExtendedCaps
+
+    -- | Size of 'Data.Torrent.InfoDict' in bytes. This field should
+    -- be added if 'ExtMetadata' is enabled in current session /and/
+    -- peer have the torrent file.
+  , ehsMetadataSize :: Maybe Int
+
+    -- | Local TCP /listen/ port. Allows each side to learn about the
+    -- TCP port number of the other side.
+  , ehsPort        :: Maybe PortNumber
+
+    -- | Request queue the number of outstanding 'Request' messages
+    -- this client supports without dropping any.
+  , ehsQueueLength :: Maybe Int
+
+    -- | Client name and version.
+  , ehsVersion     :: Maybe Text
+
+    -- | IP of the remote end
+  , ehsYourIp      :: Maybe IP
+  } deriving (Show, Eq, Typeable)
+
+extHandshakeId :: ExtendedMessageId
+extHandshakeId = 0
+
+-- | Default 'Request' queue size.
+defaultQueueLength :: Int
+defaultQueueLength = 1
+
+-- | All fields are empty.
+instance Default ExtendedHandshake where
+  def = ExtendedHandshake def def def def def def def def
+
+instance Monoid ExtendedHandshake where
+    mempty = def { ehsCaps = mempty }
+    mappend old new = ExtendedHandshake {
+      ehsCaps         = ehsCaps old <> ehsCaps new,
+      ehsIPv4         = ehsIPv4 old         `mergeOld` ehsIPv4 new,
+      ehsIPv6         = ehsIPv6 old         `mergeOld` ehsIPv6 new,
+      ehsMetadataSize = ehsMetadataSize old `mergeNew` ehsMetadataSize new,
+      ehsPort         = ehsPort old         `mergeOld` ehsPort new,
+      ehsQueueLength  = ehsQueueLength old  `mergeNew` ehsQueueLength new,
+      ehsVersion      = ehsVersion old      `mergeOld` ehsVersion new,
+      ehsYourIp       = ehsYourIp old       `mergeOld` ehsYourIp new
+    }
+      where
+        mergeOld mold mnew = mold <|> mnew
+        mergeNew mold mnew = mnew <|> mold
+
+
+instance BEncode ExtendedHandshake where
+  toBEncode ExtendedHandshake {..} = toDict $
+       "ipv4"   .=? (S.encode <$> ehsIPv4)
+    .: "ipv6"   .=? (S.encode <$> ehsIPv6)
+    .: "m"      .=! ehsCaps
+    .: "metadata_size" .=? ehsMetadataSize
+    .: "p"      .=? ehsPort
+    .: "reqq"   .=? ehsQueueLength
+    .: "v"      .=? ehsVersion
+    .: "yourip" .=? (runPut <$> either put put <$> toEither <$> ehsYourIp)
+    .: endDict
+    where
+      toEither (IPv4 v4) = Left v4
+      toEither (IPv6 v6) = Right v6
+
+  fromBEncode = fromDict $ ExtendedHandshake
+    <$>? "ipv4"
+    <*>? "ipv6"
+    <*>! "m"
+    <*>? "metadata_size"
+    <*>? "p"
+    <*>? "reqq"
+    <*>? "v"
+    <*> (opt "yourip" >>= getYourIp)
+
+getYourIp :: Maybe BValue -> BE.Get (Maybe IP)
+getYourIp f =
+  return $ do
+    BString ip <- f
+    either (const Nothing) Just $
+           case BS.length ip of
+             4  -> IPv4 <$> S.decode ip
+             16 -> IPv6 <$> S.decode ip
+             _ -> fail ""
+
+instance Pretty ExtendedHandshake where
+  pPrint = PP.text . show
+
+-- | NOTE: Approximated 'stats'.
+instance PeerMessage ExtendedHandshake where
+  envelop  c = envelop c . EHandshake
+  {-# INLINE envelop #-}
+
+  requires _ = Just ExtExtended
+  {-# INLINE requires #-}
+
+  stats _ = ByteStats (4 + 1 + 1) 100 {- is it ok? -} 0 -- FIXME
+  {-# INLINE stats #-}
+
+-- | Set default values and the specified 'ExtendedCaps'.
+nullExtendedHandshake :: ExtendedCaps -> ExtendedHandshake
+nullExtendedHandshake caps = ExtendedHandshake
+    { ehsIPv4         = Nothing
+    , ehsIPv6         = Nothing
+    , ehsCaps         = caps
+    , ehsMetadataSize = Nothing
+    , ehsPort         = Nothing
+    , ehsQueueLength  = Just defaultQueueLength
+    , ehsVersion      = Just $ T.pack $ render $ pPrint libFingerprint
+    , ehsYourIp       = Nothing
+    }
+
+{-----------------------------------------------------------------------
+-- Metadata exchange extension
+-----------------------------------------------------------------------}
+
+-- | A peer MUST verify that any piece it sends passes the info-hash
+-- verification. i.e. until the peer has the entire metadata, it
+-- cannot run SHA-1 to verify that it yields the same hash as the
+-- info-hash.
+--
+data ExtendedMetadata
+    -- | This message requests the a specified metadata piece. The
+    -- response to this message, from a peer supporting the extension,
+    -- is either a 'MetadataReject' or a 'MetadataData' message.
+  = MetadataRequest PieceIx
+
+    -- | If sender requested a valid 'PieceIx' and receiver have the
+    -- corresponding piece then receiver should respond with this
+    -- message.
+  | MetadataData
+    { -- | A piece of 'Data.Torrent.InfoDict'.
+      piece     :: P.Piece BS.ByteString
+
+      -- | This key has the same semantics as the 'ehsMetadataSize' in
+      -- the 'ExtendedHandshake' — it is size of the torrent info
+      -- dict.
+    , totalSize :: Int
+    }
+
+    -- | Peers that do not have the entire metadata MUST respond with
+    -- a reject message to any metadata request.
+    --
+    --   Clients MAY implement flood protection by rejecting request
+    --   messages after a certain number of them have been
+    --   served. Typically the number of pieces of metadata times a
+    --   factor.
+  | MetadataReject  PieceIx
+
+    -- | Reserved. By specification we should ignore unknown metadata
+    -- messages.
+  | MetadataUnknown BValue
+    deriving (Show, Eq, Typeable)
+
+-- | Extended metadata message id used in 'msg_type_key'.
+type MetadataId = Int
+
+msg_type_key, piece_key, total_size_key :: BKey
+msg_type_key   = "msg_type"
+piece_key      = "piece"
+total_size_key = "total_size"
+
+-- | BEP9 compatible encoding.
+instance BEncode ExtendedMetadata where
+  toBEncode (MetadataRequest pix) = toDict $
+       msg_type_key   .=! (0 :: MetadataId)
+    .: piece_key      .=! pix
+    .: endDict
+  toBEncode (MetadataData (P.Piece pix _) totalSize) = toDict $
+       msg_type_key   .=! (1 :: MetadataId)
+    .: piece_key      .=! pix
+    .: total_size_key .=! totalSize
+    .: endDict
+  toBEncode (MetadataReject  pix)  = toDict $
+       msg_type_key   .=! (2 :: MetadataId)
+    .: piece_key      .=! pix
+    .: endDict
+  toBEncode (MetadataUnknown bval) = bval
+
+  fromBEncode bval = (`fromDict` bval) $ do
+    mid <- field $ req msg_type_key
+    case mid :: MetadataId of
+      0 -> MetadataRequest <$>! piece_key
+      1 -> metadataData    <$>! piece_key <*>! total_size_key
+      2 -> MetadataReject  <$>! piece_key
+      _ -> pure (MetadataUnknown bval)
+   where
+     metadataData pix s = MetadataData (P.Piece pix BS.empty) s
+
+-- | Piece data bytes are omitted.
+instance Pretty ExtendedMetadata where
+  pPrint (MetadataRequest pix  ) = "Request" <+> PP.int    pix
+  pPrint (MetadataData    p   t) = "Data"    <+>    pPrint p   <+> PP.int t
+  pPrint (MetadataReject  pix  ) = "Reject"  <+> PP.int    pix
+  pPrint (MetadataUnknown bval ) = "Unknown" <+> ppBEncode bval
+
+-- | NOTE: Approximated 'stats'.
+instance PeerMessage ExtendedMetadata where
+  envelop  c = envelop c . EMetadata (remoteMessageId ExtMetadata c)
+  {-# INLINE envelop #-}
+
+  requires _ = Just ExtExtended
+  {-# INLINE requires #-}
+
+  stats (MetadataRequest _) = ByteStats (4 + 1 + 1) {- ~ -} 25 0
+  stats (MetadataData p  _) = ByteStats (4 + 1 + 1) {- ~ -} 41 $
+                              BS.length (P.pieceData p)
+  stats (MetadataReject  _) = ByteStats (4 + 1 + 1) {- ~ -} 25 0
+  stats (MetadataUnknown _) = ByteStats (4 + 1 + 1) {- ? -} 0  0
+
+-- | All 'Piece's in 'MetadataData' messages MUST have size equal to
+-- this value. The last trailing piece can be shorter.
+metadataPieceSize :: PieceSize
+metadataPieceSize = 16 * 1024
+
+isLastPiece :: P.Piece a -> Int -> Bool
+isLastPiece P.Piece {..} total = succ pieceIndex == pcnt
+  where
+    pcnt = q + if r > 0 then 1 else 0
+    (q, r) = quotRem total metadataPieceSize
+
+-- TODO we can check if the piece payload bytestring have appropriate
+-- length; otherwise serialization MUST fail.
+isValidPiece :: P.Piece BL.ByteString -> Int -> Bool
+isValidPiece p @ P.Piece {..} total
+  | isLastPiece p total = pieceSize p <= metadataPieceSize
+  |       otherwise     = pieceSize p == metadataPieceSize
+
+setMetadataPayload :: BS.ByteString -> ExtendedMetadata -> ExtendedMetadata
+setMetadataPayload bs (MetadataData (P.Piece pix _) t) =
+  MetadataData (P.Piece pix bs) t
+setMetadataPayload _   msg               = msg
+
+getMetadataPayload :: ExtendedMetadata -> Maybe BS.ByteString
+getMetadataPayload (MetadataData (P.Piece _ bs) _) = Just bs
+getMetadataPayload _                                  = Nothing
+
+-- | Metadata BDict usually contain only 'msg_type_key', 'piece_key'
+-- and 'total_size_key' fields so it normally should take less than
+-- 100 bytes. This limit is two order of magnitude larger to be
+-- permissive to 'MetadataUnknown' messages.
+--
+--   See 'maxMessageSize' for further explanation.
+--
+maxMetadataBDictSize :: Int
+maxMetadataBDictSize = 16 * 1024
+
+maxMetadataSize :: Int
+maxMetadataSize = maxMetadataBDictSize + metadataPieceSize
+
+-- to make MetadataData constructor fields a little bit prettier we
+-- cheat here: first we read empty 'pieceData' from bdict, but then we
+-- fill that field with the actual piece data — trailing bytes of
+-- the message
+getMetadata :: Int -> S.Get ExtendedMetadata
+getMetadata len
+    | len > maxMetadataSize = fail $ parseError "size exceeded limit"
+    | otherwise = do
+      bs <- getByteString len
+      parseRes $ BS.parse BE.parser bs
+  where
+    parseError reason = "unable to parse metadata message: " ++ reason
+
+    parseRes (BS.Fail _ _ m) = fail $ parseError $ "bdict: " ++ m
+    parseRes (BS.Partial _)  = fail $ parseError   "bdict: not enough bytes"
+    parseRes (BS.Done piece bvalueBS)
+      | BS.length piece > metadataPieceSize
+      = fail "infodict piece: size exceeded limit"
+      | otherwise = do
+        metadata <- either (fail . parseError) pure $ fromBEncode bvalueBS
+        return $ setMetadataPayload piece metadata
+
+putMetadata :: ExtendedMetadata -> BL.ByteString
+putMetadata msg
+  | Just bs <- getMetadataPayload msg = BE.encode msg <> BL.fromStrict bs
+  |              otherwise            = BE.encode msg
+
+-- | Allows a requesting peer to send 2 'MetadataRequest's for the
+--   each piece.
+--
+--   See 'Network.BitTorrent.Wire.Options.metadataFactor' for
+--   explanation why do we need this limit.
+defaultMetadataFactor :: Int
+defaultMetadataFactor = 2
+
+-- | Usually torrent size do not exceed 1MB. This value limit torrent
+--   /content/ size to about 8TB.
+--
+--   See 'Network.BitTorrent.Wire.Options.maxInfoDictSize' for
+--   explanation why do we need this limit.
+defaultMaxInfoDictSize :: Int
+defaultMaxInfoDictSize = 10 * 1024 * 1024
+
+{-----------------------------------------------------------------------
+--  Extension protocol messages
+-----------------------------------------------------------------------}
+
+-- | For more info see <http://www.bittorrent.org/beps/bep_0010.html>
+data ExtendedMessage
+  = EHandshake ExtendedHandshake
+  | EMetadata  ExtendedMessageId ExtendedMetadata
+  | EUnknown   ExtendedMessageId BS.ByteString
+    deriving (Show, Eq, Typeable)
+
+instance Pretty ExtendedMessage where
+  pPrint (EHandshake     ehs) = pPrint ehs
+  pPrint (EMetadata  _   msg) = "Metadata" <+> pPrint msg
+  pPrint (EUnknown   mid _  ) = "Unknown"  <+> PP.text (show mid)
+
+instance PeerMessage ExtendedMessage where
+  envelop  _ = Extended
+  {-# INLINE envelop #-}
+
+  requires _ = Just ExtExtended
+  {-# INLINE requires #-}
+
+  stats (EHandshake  hs)  = stats hs
+  stats (EMetadata _ msg) = stats msg
+  stats (EUnknown  _ msg) = ByteStats (4 + 1 + 1) (BS.length msg) 0
+
+{-----------------------------------------------------------------------
+-- The message datatype
+-----------------------------------------------------------------------}
+
+type MessageId = Word8
+
+-- | Messages used in communication between peers.
+--
+--   Note: If some extensions are disabled (not present in extension
+--   mask) and client receive message used by the disabled
+--   extension then the client MUST close the connection.
+--
+data Message
+    -- | Peers may close the TCP connection if they have not received
+    -- any messages for a given period of time, generally 2
+    -- minutes. Thus, the KeepAlive message is sent to keep the
+    -- connection between two peers alive, if no /other/ message has
+    -- been sent in a given period of time.
+  = KeepAlive
+  | Status    !StatusUpdate -- ^ Messages used to update peer status.
+  | Available !Available    -- ^ Messages used to inform availability.
+  | Transfer  !Transfer     -- ^ Messages used to transfer 'Block's.
+
+    -- | Peer receiving a handshake indicating the remote peer
+    -- supports the 'ExtDHT' should send a 'Port' message. Peers that
+    -- receive this message should attempt to ping the node on the
+    -- received port and IP address of the remote peer.
+  | Port      !PortNumber
+  | Fast      !FastMessage
+  | Extended  !ExtendedMessage
+    deriving (Show, Eq)
+
+instance Default Message where
+  def = KeepAlive
+  {-# INLINE def #-}
+
+-- | Payload bytes are omitted.
+instance Pretty Message where
+  pPrint (KeepAlive  ) = "Keep alive"
+  pPrint (Status    m) = "Status" <+> pPrint m
+  pPrint (Available m) = pPrint m
+  pPrint (Transfer  m) = pPrint m
+  pPrint (Port      p) = "Port" <+> int (fromEnum p)
+  pPrint (Fast      m) = pPrint m
+  pPrint (Extended  m) = pPrint m
+
+instance PeerMessage Message where
+  envelop _ = id
+  {-# INLINE envelop #-}
+
+  requires  KeepAlive    = Nothing
+  requires (Status    _) = Nothing
+  requires (Available _) = Nothing
+  requires (Transfer  _) = Nothing
+  requires (Port      _) = Just ExtDHT
+  requires (Fast      _) = Just ExtFast
+  requires (Extended  _) = Just ExtExtended
+
+  stats  KeepAlive    = ByteStats 4 0 0
+  stats (Status    m) = stats m
+  stats (Available m) = stats m
+  stats (Transfer  m) = stats m
+  stats (Port      _) = ByteStats 5 2 0
+  stats (Fast      m) = stats m
+  stats (Extended  m) = stats m
+
+-- | PORT message.
+instance PeerMessage PortNumber where
+  envelop  _ = Port
+  {-# INLINE envelop #-}
+
+  requires _ = Just ExtDHT
+  {-# INLINE requires #-}
+
+-- | How long /this/ peer should wait before dropping connection, in
+-- seconds.
+defaultKeepAliveTimeout :: Int
+defaultKeepAliveTimeout = 2 * 60
+
+-- | How often /this/ peer should send 'KeepAlive' messages, in
+-- seconds.
+defaultKeepAliveInterval :: Int
+defaultKeepAliveInterval = 60
+
+getInt :: S.Get Int
+getInt = fromIntegral <$> S.getWord32be
+{-# INLINE getInt #-}
+
+putInt :: S.Putter Int
+putInt = S.putWord32be . fromIntegral
+{-# INLINE putInt #-}
+
+-- | This limit should protect against "out-of-memory" attacks: if a
+-- malicious peer have sent a long varlength message then receiver can
+-- accumulate too long bytestring in the 'Get'.
+--
+--   Normal messages should never exceed this limits.
+--
+--   See also 'maxBitfieldSize', 'maxBlockSize' limits.
+--
+maxMessageSize :: Int
+maxMessageSize = 20 + 1024 * 1024
+
+-- | This also limit max torrent size to:
+--
+--     max_bitfield_size * piece_ix_per_byte * max_piece_size =
+--     2 ^ 20 * 8 * 1MB =
+--     8TB
+--
+maxBitfieldSize :: Int
+maxBitfieldSize = 1024 * 1024
+
+getBitfield :: Int -> S.Get Bitfield
+getBitfield len
+  | len > maxBitfieldSize = fail "BITFIELD message size exceeded limit"
+  |       otherwise       = fromBitmap <$> getByteString len
+
+maxBlockSize :: Int
+maxBlockSize = 4 * defaultTransferSize
+
+getBlock :: Int -> S.Get (Block BL.ByteString)
+getBlock len
+  | len > maxBlockSize = fail "BLOCK message size exceeded limit"
+  | otherwise = Block <$> getInt <*> getInt
+                      <*> getLazyByteString (fromIntegral len)
+{-# INLINE getBlock #-}
+
+instance Serialize Message where
+  get = do
+    len <- getInt
+
+    when (len > maxMessageSize) $ do
+      fail "message body size exceeded the limit"
+
+    if len == 0 then return KeepAlive
+      else do
+        mid <- S.getWord8
+        case mid of
+          0x00 -> return $ Status (Choking True)
+          0x01 -> return $ Status (Choking False)
+          0x02 -> return $ Status (Interested True)
+          0x03 -> return $ Status (Interested False)
+          0x04 -> (Available . Have)     <$> getInt
+          0x05 -> (Available . Bitfield) <$> getBitfield (pred len)
+          0x06 -> (Transfer  . Request)  <$> S.get
+          0x07 -> (Transfer  . Piece)    <$> getBlock (len - 9)
+          0x08 -> (Transfer  . Cancel)   <$> S.get
+          0x09 -> Port <$> S.get
+          0x0D -> (Fast . SuggestPiece) <$> getInt
+          0x0E -> return $ Fast HaveAll
+          0x0F -> return $ Fast HaveNone
+          0x10 -> (Fast . RejectRequest) <$> S.get
+          0x11 -> (Fast . AllowedFast)   <$> getInt
+          0x14 -> Extended <$> getExtendedMessage (pred len)
+          _    -> do
+            rm <- S.remaining >>= S.getBytes
+            fail $ "unknown message ID: " ++ show mid ++ "\n"
+                ++ "remaining available bytes: " ++ show rm
+
+  put  KeepAlive      = putInt 0
+  put (Status    msg) = putStatus    msg
+  put (Available msg) = putAvailable msg
+  put (Transfer  msg) = putTransfer  msg
+  put (Port      p  ) = putPort      p
+  put (Fast      msg) = putFast      msg
+  put (Extended  m )  = putExtendedMessage m
+
+statusUpdateId :: StatusUpdate -> MessageId
+statusUpdateId (Choking    choking) = fromIntegral (0 + fromEnum choking)
+statusUpdateId (Interested choking) = fromIntegral (2 + fromEnum choking)
+
+putStatus :: Putter StatusUpdate
+putStatus su = do
+  putInt 1
+  putWord8 (statusUpdateId su)
+
+putAvailable :: Putter Available
+putAvailable (Have i)      = do
+  putInt 5
+  putWord8 0x04
+  putInt i
+putAvailable (Bitfield (toBitmap -> bs)) = do
+  putInt $ 1 + fromIntegral (BL.length bs)
+  putWord8 0x05
+  putLazyByteString bs
+
+putBlock :: Putter (Block BL.ByteString)
+putBlock Block {..} = do
+  putInt blkPiece
+  putInt blkOffset
+  putLazyByteString blkData
+
+putTransfer :: Putter Transfer
+putTransfer (Request blk) = putInt 13 >> S.putWord8 0x06 >> S.put blk
+putTransfer (Piece   blk) = do
+  putInt (9 + blockSize blk)
+  putWord8 0x07
+  putBlock blk
+putTransfer (Cancel  blk)  = putInt 13 >> S.putWord8 0x08 >> S.put blk
+
+putPort :: Putter PortNumber
+putPort p = do
+  putInt 3
+  putWord8 0x09
+  put p
+
+putFast :: Putter FastMessage
+putFast  HaveAll           = putInt 1  >> putWord8 0x0E
+putFast  HaveNone          = putInt 1  >> putWord8 0x0F
+putFast (SuggestPiece pix) = putInt 5  >> putWord8 0x0D >> putInt pix
+putFast (RejectRequest i ) = putInt 13 >> putWord8 0x10 >> put i
+putFast (AllowedFast   i ) = putInt 5  >> putWord8 0x11 >> putInt i
+
+maxEHandshakeSize :: Int
+maxEHandshakeSize = 16 * 1024
+
+getExtendedHandshake :: Int -> S.Get ExtendedHandshake
+getExtendedHandshake messageSize
+  | messageSize > maxEHandshakeSize
+  = fail "extended handshake size exceeded limit"
+  | otherwise = do
+    bs <- getByteString messageSize
+    either fail pure $ BE.decode bs
+
+maxEUnknownSize :: Int
+maxEUnknownSize = 64 * 1024
+
+getExtendedUnknown :: Int -> S.Get BS.ByteString
+getExtendedUnknown len
+  | len > maxEUnknownSize = fail "unknown extended message size exceeded limit"
+  |        otherwise      = getByteString len
+
+getExtendedMessage :: Int -> S.Get ExtendedMessage
+getExtendedMessage messageSize = do
+  msgId   <- getWord8
+  let msgBodySize = messageSize - 1
+  case msgId of
+    0 -> EHandshake      <$> getExtendedHandshake msgBodySize
+    1 -> EMetadata msgId <$> getMetadata          msgBodySize
+    _ -> EUnknown  msgId <$> getExtendedUnknown   msgBodySize
+
+-- | By spec.
+extendedMessageId :: MessageId
+extendedMessageId = 20
+
+putExt :: ExtendedMessageId -> BL.ByteString -> Put
+putExt mid lbs = do
+  putWord32be $ fromIntegral (1 + 1 + BL.length lbs)
+  putWord8 extendedMessageId
+  putWord8 mid
+  putLazyByteString lbs
+
+-- NOTE: in contrast to getExtendedMessage this function put length
+-- and message id too!
+putExtendedMessage :: Putter ExtendedMessage
+putExtendedMessage (EHandshake hs)     = putExt extHandshakeId $ BE.encode hs
+putExtendedMessage (EMetadata mid msg) = putExt mid $ putMetadata msg
+putExtendedMessage (EUnknown  mid  bs) = putExt mid $ BL.fromStrict bs
diff --git a/bittorrent/src/Network/BitTorrent/Exchange/Session.hs b/bittorrent/src/Network/BitTorrent/Exchange/Session.hs
new file mode 100644
index 00000000..38a3c3a6
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Exchange/Session.hs
@@ -0,0 +1,586 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeFamilies       #-}
+module Network.BitTorrent.Exchange.Session
+       ( -- * Session
+         Session
+       , Event (..)
+       , LogFun
+       , sessionLogger
+
+         -- * Construction
+       , newSession
+       , closeSession
+       , withSession
+
+         -- * Connection Set
+       , connect
+       , connectSink
+       , establish
+
+         -- * Query
+       , waitMetadata
+       , takeMetadata
+       ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.Chan.Split as CS
+import Control.Concurrent.STM
+import Control.Exception hiding (Handler)
+import Control.Lens
+import Control.Monad as M
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Data.ByteString as BS
+import Data.ByteString.Lazy as BL
+import Data.Conduit as C (Sink, awaitForever, (=$=), ($=))
+import qualified Data.Conduit as C
+import Data.Conduit.List as C
+import Data.Map as M
+import Data.Monoid
+import Data.Set  as S
+import Data.Text as T
+import Data.Typeable
+import Text.PrettyPrint hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+import System.Log.FastLogger (LogStr, ToLogStr (..))
+
+import Data.BEncode as BE
+import Data.Torrent as Torrent
+import Network.BitTorrent.Internal.Types
+import Network.Address
+import Network.BitTorrent.Exchange.Bitfield as BF
+import Network.BitTorrent.Exchange.Block   as Block
+import Network.BitTorrent.Exchange.Connection
+import Network.BitTorrent.Exchange.Download as D
+import Network.BitTorrent.Exchange.Message as Message
+import System.Torrent.Storage
+
+#if !MIN_VERSION_iproute(1,2,12)
+deriving instance Ord IP
+#endif
+
+{-----------------------------------------------------------------------
+--  Exceptions
+-----------------------------------------------------------------------}
+
+data ExchangeError
+  = InvalidRequest BlockIx StorageFailure
+  | CorruptedPiece PieceIx
+    deriving (Show, Typeable)
+
+instance Exception ExchangeError
+
+packException :: Exception e => (e -> ExchangeError) -> IO a -> IO a
+packException f m = try m >>= either (throwIO . f) return
+
+{-----------------------------------------------------------------------
+--  Session state
+-----------------------------------------------------------------------}
+-- TODO unmap storage on zero connections
+
+data Cached a = Cached
+  { cachedValue :: !a
+  , cachedData  :: BL.ByteString -- keep lazy
+  }
+
+cache :: BEncode a => a -> Cached a
+cache s = Cached s (BE.encode s)
+
+-- | Logger function.
+type LogFun = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+
+--data SessionStatus = Seeder | Leecher
+
+data SessionState
+  = WaitingMetadata
+    { metadataDownload  :: MVar MetadataDownload
+    , metadataCompleted :: MVar InfoDict -- ^ used to unblock waiters
+    , contentRootPath   :: FilePath
+    }
+  | HavingMetadata
+    { metadataCache     :: Cached InfoDict
+    , contentDownload   :: MVar ContentDownload
+    , contentStorage    :: Storage
+    }
+
+newSessionState :: FilePath -> Either InfoHash InfoDict -> IO SessionState
+newSessionState rootPath (Left  ih  ) = do
+  WaitingMetadata <$> newMVar def <*> newEmptyMVar <*> pure rootPath
+newSessionState rootPath (Right dict) = do
+  storage     <- openInfoDict ReadWriteEx rootPath dict
+  download    <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage))
+                                           (piPieceLength (idPieceInfo dict))
+                                           storage
+  return $ HavingMetadata (cache dict) download storage
+
+closeSessionState :: SessionState -> IO ()
+closeSessionState WaitingMetadata {..} = return ()
+closeSessionState HavingMetadata  {..} = close contentStorage
+
+haveMetadata :: InfoDict -> SessionState -> IO SessionState
+haveMetadata dict WaitingMetadata {..} = do
+  storage     <- openInfoDict ReadWriteEx contentRootPath dict
+  download    <- newMVar $ D.contentDownload (BF.haveNone (totalPieces storage))
+                                           (piPieceLength (idPieceInfo dict))
+                                            storage
+  return HavingMetadata
+    { metadataCache   = cache dict
+    , contentDownload = download
+    , contentStorage  = storage
+    }
+haveMetadata _    s                    = return s
+
+{-----------------------------------------------------------------------
+--  Session
+-----------------------------------------------------------------------}
+
+data Session = Session
+  { sessionPeerId          :: !(PeerId)
+  , sessionTopic           :: !(InfoHash)
+  , sessionLogger          :: !(LogFun)
+  , sessionEvents          :: !(SendPort (Event Session))
+
+  , sessionState           :: !(MVar SessionState)
+
+------------------------------------------------------------------------
+  , connectionsPrefs       :: !ConnectionPrefs
+
+    -- | Connections either waiting for TCP/uTP 'connect' or waiting
+    -- for BT handshake.
+  , connectionsPending     :: !(TVar (Set (PeerAddr IP)))
+
+    -- | Connections successfully handshaked and data transfer can
+    -- take place.
+  , connectionsEstablished :: !(TVar (Map (PeerAddr IP) (Connection Session)))
+
+    -- | TODO implement choking mechanism
+  , connectionsUnchoked    ::  [PeerAddr IP]
+
+    -- | Messages written to this channel will be sent to the all
+    -- connections, including pending connections (but right after
+    -- handshake).
+  , connectionsBroadcast   :: !(Chan Message)
+  }
+
+instance EventSource Session where
+  data Event Session
+    = ConnectingTo (PeerAddr IP)
+    | ConnectionEstablished (PeerAddr IP)
+    | ConnectionAborted
+    | ConnectionClosed (PeerAddr IP)
+    | SessionClosed
+      deriving Show
+
+  listen Session {..} = CS.listen sessionEvents
+
+newSession :: LogFun
+           -> PeerAddr (Maybe IP)      -- ^ /external/ address of this peer;
+           -> FilePath                 -- ^ root directory for content files;
+           -> Either InfoHash InfoDict -- ^ torrent info dictionary;
+           -> IO Session
+newSession logFun addr rootPath source = do
+  let ih       = either id idInfoHash source
+  pid         <- maybe genPeerId return (peerId addr)
+  eventStream <- newSendPort
+  sState      <- newSessionState rootPath source
+  sStateVar   <- newMVar sState
+  pSetVar     <- newTVarIO S.empty
+  eSetVar     <- newTVarIO M.empty
+  chan        <- newChan
+  return Session
+    { sessionPeerId          = pid
+    , sessionTopic           = ih
+    , sessionLogger          = logFun
+    , sessionEvents          = eventStream
+    , sessionState           = sStateVar
+    , connectionsPrefs       = def
+    , connectionsPending     = pSetVar
+    , connectionsEstablished = eSetVar
+    , connectionsUnchoked    = []
+    , connectionsBroadcast   = chan
+    }
+
+closeSession :: Session -> IO ()
+closeSession Session {..} = do
+  s <- readMVar sessionState
+  closeSessionState s
+{-
+  hSet <- atomically $ do
+    pSet <- swapTVar connectionsPending     S.empty
+    eSet <- swapTVar connectionsEstablished S.empty
+    return pSet
+  mapM_ kill hSet
+-}
+
+withSession :: ()
+withSession = error "withSession"
+
+{-----------------------------------------------------------------------
+--  Logging
+-----------------------------------------------------------------------}
+
+instance MonadLogger (Connected Session) where
+  monadLoggerLog loc src lvl msg = do
+    conn <- ask
+    ses  <- asks connSession
+    addr <- asks connRemoteAddr
+    let addrSrc = src <> " @ " <> T.pack (render (pPrint addr))
+    liftIO $ sessionLogger ses loc addrSrc lvl (toLogStr msg)
+
+logMessage :: MonadLogger m => Message -> m ()
+logMessage msg = logDebugN $ T.pack (render (pPrint msg))
+
+logEvent   :: MonadLogger m => Text    -> m ()
+logEvent       = logInfoN
+
+{-----------------------------------------------------------------------
+--  Connection set
+-----------------------------------------------------------------------}
+--- Connection status transition:
+---
+--- pending -> established -> finished -> closed
+---    |           \|/                      /|\
+---    \-------------------------------------|
+---
+--- Purpose of slots:
+---   1) to avoid duplicates
+---   2) connect concurrently
+---
+
+-- | Add connection to the pending set.
+pendingConnection :: PeerAddr IP -> Session -> STM Bool
+pendingConnection addr Session {..} = do
+  pSet <- readTVar connectionsPending
+  eSet <- readTVar connectionsEstablished
+  if (addr `S.member` pSet) || (addr `M.member` eSet)
+    then return False
+    else do
+      modifyTVar' connectionsPending (S.insert addr)
+      return True
+
+-- | Pending connection successfully established, add it to the
+-- established set.
+establishedConnection :: Connected Session ()
+establishedConnection = do
+  conn         <- ask
+  addr         <- asks connRemoteAddr
+  Session {..} <- asks connSession
+  liftIO $ atomically $ do
+    modifyTVar connectionsPending     (S.delete addr)
+    modifyTVar connectionsEstablished (M.insert addr conn)
+
+-- | Either this or remote peer decided to finish conversation
+-- (conversation is alread /established/ connection), remote it from
+-- the established set.
+finishedConnection :: Connected Session ()
+finishedConnection = do
+  Session {..} <- asks connSession
+  addr         <- asks connRemoteAddr
+  liftIO $ atomically $ do
+    modifyTVar connectionsEstablished $ M.delete addr
+
+-- | There are no state for this connection, remove it from the all
+-- sets.
+closedConnection :: PeerAddr IP -> Session -> STM ()
+closedConnection addr Session {..} = do
+  modifyTVar connectionsPending     $ S.delete addr
+  modifyTVar connectionsEstablished $ M.delete addr
+
+getConnectionConfig :: Session -> IO (ConnectionConfig Session)
+getConnectionConfig s @ Session {..} = do
+  chan <- dupChan connectionsBroadcast
+  let sessionLink = SessionLink {
+      linkTopic        = sessionTopic
+    , linkPeerId       = sessionPeerId
+    , linkMetadataSize = Nothing
+    , linkOutputChan   = Just chan
+    , linkSession      = s
+    }
+  return ConnectionConfig
+    { cfgPrefs   = connectionsPrefs
+    , cfgSession = sessionLink
+    , cfgWire    = mainWire
+    }
+
+type Finalizer      = IO ()
+type Runner = (ConnectionConfig Session -> IO ())
+
+runConnection :: Runner -> Finalizer -> PeerAddr IP -> Session -> IO ()
+runConnection runner finalize addr set @ Session {..} = do
+    _ <- forkIO (action `finally` cleanup)
+    return ()
+  where
+    action = do
+      notExist <- atomically $ pendingConnection addr set
+      when notExist $ do
+        cfg <- getConnectionConfig set
+        runner cfg
+
+    cleanup = do
+      finalize
+--      runStatusUpdates status (SS.resetPending addr)
+      -- TODO Metata.resetPending addr
+      atomically $ closedConnection addr set
+
+-- | Establish connection from scratch. If this endpoint is already
+-- connected, no new connections is created. This function do not block.
+connect :: PeerAddr IP -> Session -> IO ()
+connect addr = runConnection (connectWire addr) (return ()) addr
+
+-- | Establish connection with already pre-connected endpoint. If this
+-- endpoint is already connected, no new connections is created. This
+-- function do not block.
+--
+--  'PendingConnection' will be closed automatically, you do not need
+--  to call 'closePending'.
+establish :: PendingConnection -> Session -> IO ()
+establish conn = runConnection (acceptWire conn) (closePending conn)
+                 (pendingPeer conn)
+
+-- | Conduit version of 'connect'.
+connectSink :: MonadIO m => Session -> Sink [PeerAddr IPv4] m ()
+connectSink s = C.mapM_ (liftIO . connectBatch)
+  where
+    connectBatch = M.mapM_ (\ addr -> connect (IPv4 <$> addr) s)
+
+-- | Why do we need this message?
+type BroadcastMessage = ExtendedCaps -> Message
+
+broadcast :: BroadcastMessage -> Session -> IO ()
+broadcast = error "broadcast"
+
+{-----------------------------------------------------------------------
+--  Helpers
+-----------------------------------------------------------------------}
+
+waitMVar :: MVar a -> IO ()
+waitMVar m = withMVar m (const (return ()))
+
+-- This function appear in new GHC "out of box". (moreover it is atomic)
+tryReadMVar :: MVar a -> IO (Maybe a)
+tryReadMVar m = do
+  ma <- tryTakeMVar m
+  maybe (return ()) (putMVar m) ma
+  return ma
+
+readBlock :: BlockIx -> Storage -> IO (Block BL.ByteString)
+readBlock bix @ BlockIx {..} s = do
+  p <- packException (InvalidRequest bix) $ do readPiece ixPiece s
+  let chunk = BL.take (fromIntegral ixLength) $
+              BL.drop (fromIntegral ixOffset) (pieceData p)
+  if BL.length chunk == fromIntegral ixLength
+    then return  $ Block ixPiece ixOffset chunk
+    else throwIO $ InvalidRequest bix (InvalidSize ixLength)
+
+-- |
+tryReadMetadataBlock :: PieceIx
+   -> Connected Session (Maybe (Torrent.Piece BS.ByteString, Int))
+tryReadMetadataBlock pix = do
+  Session {..} <- asks connSession
+  s            <- liftIO (readMVar sessionState)
+  case s of
+    WaitingMetadata {..} -> error "tryReadMetadataBlock"
+    HavingMetadata  {..} -> error "tryReadMetadataBlock"
+
+sendBroadcast :: PeerMessage msg => msg -> Wire Session ()
+sendBroadcast msg = do
+  Session {..} <- asks connSession
+  error "sendBroadcast"
+--  liftIO $ msg `broadcast` sessionConnections
+
+waitMetadata :: Session -> IO InfoDict
+waitMetadata Session {..} = do
+  s <- readMVar sessionState
+  case s of
+    WaitingMetadata {..} -> readMVar metadataCompleted
+    HavingMetadata  {..} -> return (cachedValue metadataCache)
+
+takeMetadata :: Session -> IO (Maybe InfoDict)
+takeMetadata Session {..} = do
+  s <- readMVar sessionState
+  case s of
+    WaitingMetadata {..} -> return Nothing
+    HavingMetadata  {..} -> return (Just (cachedValue metadataCache))
+
+{-----------------------------------------------------------------------
+--  Triggers
+-----------------------------------------------------------------------}
+
+-- | Trigger is the reaction of a handler at some event.
+type Trigger = Wire Session ()
+
+interesting :: Trigger
+interesting = do
+  addr <- asks connRemoteAddr
+  sendMessage (Interested True)
+  sendMessage (Choking    False)
+  tryFillRequestQueue
+
+fillRequestQueue :: Trigger
+fillRequestQueue = do
+  maxN <- lift getMaxQueueLength
+  rbf  <- use  connBitfield
+  addr <- asks connRemoteAddr
+--  blks <- withStatusUpdates $ do
+--    n <- getRequestQueueLength addr
+--    scheduleBlocks addr rbf (maxN - n)
+--  mapM_ (sendMessage . Request) blks
+  return ()
+
+tryFillRequestQueue :: Trigger
+tryFillRequestQueue = do
+  allowed <- canDownload <$> use connStatus
+  when allowed $ do
+    fillRequestQueue
+
+{-----------------------------------------------------------------------
+--  Incoming message handling
+-----------------------------------------------------------------------}
+
+type Handler msg = msg -> Wire Session ()
+
+handleStatus :: Handler StatusUpdate
+handleStatus s = do
+  connStatus %= over remoteStatus (updateStatus s)
+  case s of
+    Interested _     -> return ()
+    Choking    True  -> do
+      addr <- asks connRemoteAddr
+--      withStatusUpdates (SS.resetPending addr)
+      return ()
+    Choking    False -> tryFillRequestQueue
+
+handleAvailable :: Handler Available
+handleAvailable msg = do
+  connBitfield %= case msg of
+    Have     ix -> BF.insert ix
+    Bitfield bf -> const     bf
+
+  --thisBf <- getThisBitfield
+  thisBf <- undefined
+  case msg of
+    Have     ix
+      | ix `BF.member`     thisBf -> return ()
+      |     otherwise             -> interesting
+    Bitfield bf
+      | bf `BF.isSubsetOf` thisBf -> return ()
+      |     otherwise             -> interesting
+
+handleTransfer :: Handler Transfer
+handleTransfer (Request bix) = do
+  Session {..} <- asks connSession
+  s            <- liftIO $ readMVar sessionState
+  case s of
+    WaitingMetadata {..} -> return ()
+    HavingMetadata  {..} -> do
+      bitfield <- undefined -- getThisBitfield
+      upload   <- canUpload <$> use connStatus
+      when (upload && ixPiece bix `BF.member` bitfield) $ do
+        blk <- liftIO $ readBlock bix contentStorage
+        sendMessage (Message.Piece blk)
+
+handleTransfer (Message.Piece   blk) = do
+  Session {..} <- asks connSession
+  s            <- liftIO $ readMVar sessionState
+  case s of
+    WaitingMetadata {..} -> return () -- TODO (?) break connection
+    HavingMetadata  {..} -> do
+      isSuccess <- undefined -- withStatusUpdates (SS.pushBlock blk storage)
+      case isSuccess of
+        Nothing -> liftIO $ throwIO $ userError "block is not requested"
+        Just isCompleted -> do
+          when isCompleted $ do
+            sendBroadcast (Have (blkPiece blk))
+--            maybe send not interested
+            tryFillRequestQueue
+
+handleTransfer (Cancel  bix) = filterQueue (not . (transferResponse bix))
+  where
+    transferResponse bix (Transfer (Message.Piece blk)) = blockIx blk == bix
+    transferResponse _    _                             = False
+
+{-----------------------------------------------------------------------
+--  Metadata exchange
+-----------------------------------------------------------------------}
+-- TODO introduce new metadata exchange specific exceptions
+
+waitForMetadata :: Trigger
+waitForMetadata = do
+  Session {..} <- asks connSession
+  needFetch    <- undefined --liftIO (isEmptyMVar infodict)
+  when needFetch $ do
+    canFetch   <- allowed ExtMetadata <$> use connExtCaps
+    if canFetch
+      then tryRequestMetadataBlock
+      else undefined -- liftIO (waitMVar infodict)
+
+tryRequestMetadataBlock :: Trigger
+tryRequestMetadataBlock = do
+  mpix <- lift $ undefined --withMetadataUpdates Metadata.scheduleBlock
+  case mpix of
+    Nothing  -> error "tryRequestMetadataBlock"
+    Just pix -> sendMessage (MetadataRequest pix)
+
+handleMetadata :: Handler ExtendedMetadata
+handleMetadata (MetadataRequest pix) =
+    lift (tryReadMetadataBlock pix) >>= sendMessage . mkResponse
+  where
+    mkResponse  Nothing              = MetadataReject pix
+    mkResponse (Just (piece, total)) = MetadataData   piece total
+
+handleMetadata (MetadataData   {..}) = do
+  ih    <- asks connTopic
+  mdict <- lift $ undefined --withMetadataUpdates (Metadata.pushBlock piece ih)
+  case mdict of
+    Nothing   -> tryRequestMetadataBlock -- not completed, need all blocks
+    Just dict -> do   -- complete, wake up payload fetch
+      Session {..} <- asks connSession
+      liftIO $ modifyMVar_ sessionState (haveMetadata dict)
+
+handleMetadata (MetadataReject  pix) = do
+  lift $ undefined -- withMetadataUpdates (Metadata.cancelPending pix)
+
+handleMetadata (MetadataUnknown _  ) = do
+  logInfoN "Unknown metadata message"
+
+{-----------------------------------------------------------------------
+--  Main entry point
+-----------------------------------------------------------------------}
+
+acceptRehandshake :: ExtendedHandshake -> Trigger
+acceptRehandshake ehs = error "acceptRehandshake"
+
+handleExtended :: Handler ExtendedMessage
+handleExtended (EHandshake     ehs) = acceptRehandshake ehs
+handleExtended (EMetadata  _   msg) = handleMetadata msg
+handleExtended (EUnknown   _   _  ) = logWarnN "Unknown extension message"
+
+handleMessage :: Handler Message
+handleMessage KeepAlive       = return ()
+handleMessage (Status s)      = handleStatus s
+handleMessage (Available msg) = handleAvailable msg
+handleMessage (Transfer  msg) = handleTransfer msg
+handleMessage (Port      n)   = error "handleMessage"
+handleMessage (Fast      _)   = error "handleMessage"
+handleMessage (Extended  msg) = handleExtended msg
+
+exchange :: Wire Session ()
+exchange = do
+  waitForMetadata
+  bf <- undefined --getThisBitfield
+  sendMessage (Bitfield bf)
+  awaitForever handleMessage
+
+mainWire :: Wire Session ()
+mainWire = do
+  lift establishedConnection
+  Session {..} <- asks connSession
+--  lift $ resizeBitfield (totalPieces storage)
+  logEvent "Connection established"
+  iterM logMessage =$= exchange =$= iterM logMessage
+  lift finishedConnection
diff --git a/bittorrent/src/Network/BitTorrent/Internal/Cache.hs b/bittorrent/src/Network/BitTorrent/Internal/Cache.hs
new file mode 100644
index 00000000..8c74467a
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Internal/Cache.hs
@@ -0,0 +1,169 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2014
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Cached data for tracker responses.
+--
+module Network.BitTorrent.Internal.Cache
+       ( -- * Cache
+         Cached
+       , lastUpdated
+       , updateInterval
+       , minUpdateInterval
+
+         -- * Construction
+       , newCached
+       , newCached_
+
+         -- * Query
+       , isAlive
+       , isStalled
+       , isExpired
+       , canUpdate
+       , shouldUpdate
+
+         -- * Cached data
+       , tryTakeData
+       , unsafeTryTakeData
+       , takeData
+       ) where
+
+import Control.Applicative
+import Data.Monoid
+import Data.Default
+import Data.Time
+import Data.Time.Clock.POSIX
+import System.IO.Unsafe
+
+
+data Cached a = Cached
+  { -- | Time of resource creation.
+    lastUpdated           :: !POSIXTime
+
+    -- | Minimum invalidation timeout.
+  , minUpdateInterval     :: !NominalDiffTime
+
+    -- | Resource lifetime.
+  , updateInterval        :: !NominalDiffTime
+
+    -- | Resource data.
+  , cachedData            :: a
+  } deriving (Show, Eq)
+
+-- INVARIANT: minUpdateInterval <= updateInterval
+
+instance Default (Cached a) where
+  def = mempty
+
+instance Functor Cached where
+  fmap f (Cached t i m a) = Cached t i m (f a)
+
+posixEpoch :: NominalDiffTime
+posixEpoch = 1000000000000000000000000000000000000000000000000000000
+
+instance Applicative Cached where
+  pure = Cached 0 posixEpoch posixEpoch
+  f <*> c = Cached
+    { lastUpdated       = undefined
+    , minUpdateInterval = undefined
+    , updateInterval    = undefined
+    , cachedData        = cachedData f (cachedData c)
+    }
+
+instance Alternative Cached where
+  empty = mempty
+  (<|>) = error "cached alternative instance: not implemented"
+
+instance Monad Cached where
+  return = pure
+  Cached {..} >>= f = Cached
+    { lastUpdated       = undefined
+    , updateInterval    = undefined
+    , minUpdateInterval = undefined
+    , cachedData        = undefined
+    }
+
+instance Monoid (Cached a) where
+  mempty = Cached
+    { lastUpdated       = 0
+    , minUpdateInterval = 0
+    , updateInterval    = 0
+    , cachedData        = error "cached mempty: impossible happen"
+    }
+
+  mappend a b
+    | expirationTime a > expirationTime b = a
+    |             otherwise               = b
+
+normalize :: NominalDiffTime -> NominalDiffTime
+          -> (NominalDiffTime, NominalDiffTime)
+normalize a b
+  |   a < b   = (a, b)
+  | otherwise = (b, a)
+{-# INLINE normalize #-}
+
+newCached :: NominalDiffTime -> NominalDiffTime -> a -> IO (Cached a)
+newCached minInterval interval x = do
+  t <- getPOSIXTime
+  let (mui, ui) = normalize minInterval interval
+  return Cached
+    { lastUpdated       = t
+    , minUpdateInterval = mui
+    , updateInterval    = ui
+    , cachedData        = x
+    }
+
+newCached_ :: NominalDiffTime -> a -> IO (Cached a)
+newCached_ interval x = newCached interval interval x
+{-# INLINE newCached_ #-}
+
+expirationTime :: Cached a -> POSIXTime
+expirationTime Cached {..} = undefined
+
+isAlive :: Cached a -> IO Bool
+isAlive Cached {..} = do
+  currentTime <- getPOSIXTime
+  return $ lastUpdated + updateInterval > currentTime
+
+isExpired :: Cached a -> IO Bool
+isExpired Cached {..} = undefined
+
+isStalled :: Cached a -> IO Bool
+isStalled Cached {..} = undefined
+
+canUpdate :: Cached a -> IO (Maybe NominalDiffTime)
+canUpdate = undefined --isStaled
+
+shouldUpdate :: Cached a -> IO (Maybe NominalDiffTime)
+shouldUpdate = undefined -- isExpired
+
+tryTakeData :: Cached a -> IO (Maybe a)
+tryTakeData c = do
+  alive <- isAlive c
+  return $ if alive then Just (cachedData c) else Nothing
+
+unsafeTryTakeData :: Cached a -> Maybe a
+unsafeTryTakeData = unsafePerformIO . tryTakeData
+
+invalidateData :: Cached a -> IO a -> IO (Cached a)
+invalidateData Cached {..} action = do
+  t <- getPOSIXTime
+  x <- action
+  return Cached
+    { lastUpdated       = t
+    , updateInterval    = updateInterval
+    , minUpdateInterval = minUpdateInterval
+    , cachedData        = x
+    }
+
+takeData :: Cached a -> IO a -> IO a
+takeData c action = do
+  mdata <- tryTakeData c
+  case mdata of
+    Just  a -> return a
+    Nothing -> do
+      c' <- invalidateData c action
+      takeData c' action
diff --git a/bittorrent/src/Network/BitTorrent/Internal/Progress.hs b/bittorrent/src/Network/BitTorrent/Internal/Progress.hs
new file mode 100644
index 00000000..6ac889e2
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Internal/Progress.hs
@@ -0,0 +1,154 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   'Progress' used to track amount downloaded\/left\/upload bytes
+--   either on per client or per torrent basis. This value is used to
+--   notify the tracker and usually shown to the user. To aggregate
+--   total progress you can use the Monoid instance.
+--
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns    #-}
+{-# OPTIONS -fno-warn-orphans #-}
+module Network.BitTorrent.Internal.Progress
+       ( -- * Progress
+         Progress (..)
+
+         -- * Lens
+       , left
+       , uploaded
+       , downloaded
+
+         -- * Construction
+       , startProgress
+       , downloadedProgress
+       , enqueuedProgress
+       , uploadedProgress
+       , dequeuedProgress
+
+         -- * Query
+       , canDownload
+       , canUpload
+       ) where
+
+import Control.Applicative
+import Control.Lens hiding ((%=))
+import Data.ByteString.Lazy.Builder  as BS
+import Data.ByteString.Lazy.Builder.ASCII as BS
+import Data.Default
+import Data.Monoid
+import Data.Serialize as S
+import Data.Ratio
+import Data.Word
+import Network.HTTP.Types.QueryLike
+import Text.PrettyPrint as PP
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+
+
+-- | Progress data is considered as dynamic within one client
+-- session. This data also should be shared across client application
+-- sessions (e.g. files), otherwise use 'startProgress' to get initial
+-- 'Progress' value.
+--
+data Progress = Progress
+  { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded;
+  , _left       :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left;
+  , _uploaded   :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded.
+  } deriving (Show, Read, Eq)
+
+$(makeLenses ''Progress)
+
+-- | UDP tracker compatible encoding.
+instance Serialize Progress where
+  put Progress {..} = do
+    putWord64be $ fromIntegral _downloaded
+    putWord64be $ fromIntegral _left
+    putWord64be $ fromIntegral _uploaded
+
+  get = Progress
+    <$> (fromIntegral <$> getWord64be)
+    <*> (fromIntegral <$> getWord64be)
+    <*> (fromIntegral <$> getWord64be)
+
+instance Default Progress where
+  def = Progress 0 0 0
+  {-# INLINE def #-}
+
+-- | Can be used to aggregate total progress.
+instance Monoid Progress where
+  mempty  = def
+  {-# INLINE mempty #-}
+
+  mappend (Progress da la ua) (Progress db lb ub) = Progress
+    { _downloaded = da + db
+    , _left       = la + lb
+    , _uploaded   = ua + ub
+    }
+  {-# INLINE mappend #-}
+
+instance QueryValueLike Builder where
+  toQueryValue = toQueryValue . BS.toLazyByteString
+
+instance QueryValueLike Word64 where
+  toQueryValue = toQueryValue . BS.word64Dec
+
+-- | HTTP Tracker protocol compatible encoding.
+instance QueryLike Progress where
+  toQuery Progress {..} =
+    [ ("uploaded"  , toQueryValue _uploaded)
+    , ("left"      , toQueryValue _left)
+    , ("downloaded", toQueryValue _downloaded)
+    ]
+
+instance Pretty Progress where
+  pPrint Progress {..} =
+    "/\\"  <+> PP.text (show _uploaded)   $$
+    "\\/"  <+> PP.text (show _downloaded) $$
+    "left" <+> PP.text (show _left)
+
+-- | Initial progress is used when there are no session before.
+--
+-- Please note that tracker might penalize client some way if the do
+-- not accumulate progress. If possible and save 'Progress' between
+-- client sessions to avoid that.
+--
+startProgress :: Integer -> Progress
+startProgress = Progress 0 0 . fromIntegral
+{-# INLINE startProgress #-}
+
+-- | Used when the client download some data from /any/ peer.
+downloadedProgress :: Int -> Progress -> Progress
+downloadedProgress (fromIntegral -> amount)
+                 = (left         -~ amount)
+                 . (downloaded   +~ amount)
+{-# INLINE downloadedProgress #-}
+
+-- | Used when the client upload some data to /any/ peer.
+uploadedProgress :: Int -> Progress -> Progress
+uploadedProgress (fromIntegral -> amount) = uploaded +~ amount
+{-# INLINE uploadedProgress #-}
+
+-- | Used when leecher join client session.
+enqueuedProgress :: Integer -> Progress -> Progress
+enqueuedProgress amount = left +~ fromIntegral amount
+{-# INLINE enqueuedProgress #-}
+
+-- | Used when leecher leave client session.
+--   (e.g. user deletes not completed torrent)
+dequeuedProgress :: Integer -> Progress -> Progress
+dequeuedProgress amount = left -~ fromIntegral amount
+{-# INLINE dequeuedProgress #-}
+
+ri2rw64 :: Ratio Int -> Ratio Word64
+ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x)
+
+-- | Check global /download/ limit by uploaded \/ downloaded ratio.
+canDownload :: Ratio Int -> Progress -> Bool
+canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit
+
+-- | Check global /upload/ limit by downloaded \/ uploaded ratio.
+canUpload :: Ratio Int -> Progress -> Bool
+canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit
diff --git a/bittorrent/src/Network/BitTorrent/Internal/Types.hs b/bittorrent/src/Network/BitTorrent/Internal/Types.hs
new file mode 100644
index 00000000..d157db3e
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Internal/Types.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
+module Network.BitTorrent.Internal.Types
+       ( EventSource (..)
+       ) where
+
+import Control.Concurrent.Chan.Split
+
+class EventSource source  where
+  data Event source
+  listen :: source -> IO (ReceivePort (Event source))
diff --git a/bittorrent/src/Network/BitTorrent/Readme.md b/bittorrent/src/Network/BitTorrent/Readme.md
new file mode 100644
index 00000000..ebf9545e
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Readme.md
@@ -0,0 +1,10 @@
+Layout
+======
+
+| module group | can import   | main purpose                           |
+|:-------------|:------------:|:--------------------------------------:|
+| Core         |              | common datatypes                       |
+| DHT          |  Core        | centralized peer discovery             |
+| Tracker      |  Core        | decentralized peer discovery           |
+| Exchange     |  Core        | torrent content exchange               |
+| Client       | any other    | core of bittorrent client application  |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker.hs b/bittorrent/src/Network/BitTorrent/Tracker.hs
new file mode 100644
index 00000000..6db67559
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker.hs
@@ -0,0 +1,50 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--   This module provides high level API for peer -> tracker
+--   communication. Tracker is used to discover other peers in the
+--   network using torrent info hash.
+--
+{-# LANGUAGE TemplateHaskell   #-}
+module Network.BitTorrent.Tracker
+       ( -- * RPC Manager
+         PeerInfo (..)
+       , Options
+       , Manager
+       , newManager
+       , closeManager
+       , withManager
+
+         -- * Multitracker session
+       , trackerList
+       , Session
+       , Event (..)
+       , newSession
+       , closeSession
+       , withSession
+
+         -- ** Events
+       , AnnounceEvent (..)
+       , notify
+       , askPeers
+
+         -- ** Session state
+       , TrackerSession
+       , trackerPeers
+       , trackerScrape
+
+       , tryTakeData
+       , unsafeTryTakeData
+
+       , getSessionState
+       ) where
+
+import Network.BitTorrent.Internal.Cache (tryTakeData, unsafeTryTakeData)
+import Network.BitTorrent.Tracker.Message
+import Network.BitTorrent.Tracker.List
+import Network.BitTorrent.Tracker.RPC
+import Network.BitTorrent.Tracker.Session
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/List.hs b/bittorrent/src/Network/BitTorrent/Tracker/List.hs
new file mode 100644
index 00000000..0eb11641
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/List.hs
@@ -0,0 +1,193 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2014
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Multitracker Metadata Extension support.
+--
+--   For more info see: <http://www.bittorrent.org/beps/bep_0012.html>
+--
+{-# LANGUAGE FlexibleInstances #-}
+module Network.BitTorrent.Tracker.List
+       ( -- * Tracker list
+         TierEntry
+       , TrackerList
+
+         -- * Construction
+       , trackerList
+       , shuffleTiers
+       , mapWithURI
+       , Network.BitTorrent.Tracker.List.toList
+
+         -- * Traversals
+       , traverseAll
+       , traverseTiers
+       ) where
+
+import Prelude hiding (mapM, foldr)
+import Control.Arrow
+import Control.Applicative
+import Control.Exception
+import Data.Default
+import Data.List as L (map, elem, any, filter, null)
+import Data.Maybe
+import Data.Foldable
+import Data.Traversable
+import Network.URI
+import System.Random.Shuffle
+
+import Data.Torrent
+import Network.BitTorrent.Tracker.RPC as RPC
+
+{-----------------------------------------------------------------------
+--  Tracker list datatype
+-----------------------------------------------------------------------}
+
+type TierEntry a = (URI, a)
+type Tier a = [TierEntry a]
+
+-- | Tracker list is either a single tracker or list of tiers. All
+-- trackers in each tier must be checked before the client goes on to
+-- the next tier.
+data TrackerList a
+  = Announce (TierEntry a) -- ^ torrent file 'announce'      field only
+  | TierList [Tier a]      -- ^ torrent file 'announce-list' field only
+    deriving (Show, Eq)
+
+-- | Empty tracker list. Can be used for trackerless torrents.
+instance Default (TrackerList a) where
+  def = TierList []
+
+instance Functor TrackerList where
+  fmap f (Announce (uri, a)) = Announce (uri, f a)
+  fmap f (TierList a)        = TierList (fmap (fmap (second f)) a)
+
+instance Foldable TrackerList where
+  foldr f z (Announce e ) = f (snd e) z
+  foldr f z (TierList xs) = foldr (flip (foldr (f . snd))) z xs
+
+_traverseEntry f (uri, a) = (,) uri <$> f a
+
+instance Traversable TrackerList where
+  traverse f (Announce e ) = Announce <$> _traverseEntry f e
+  traverse f (TierList xs) =
+      TierList <$> traverse (traverse (_traverseEntry f)) xs
+
+traverseWithURI :: Applicative f
+                => (TierEntry a -> f b) -> TrackerList a -> f (TrackerList b)
+traverseWithURI f (Announce (uri, a)) = (Announce . (,) uri) <$> f (uri, a)
+traverseWithURI f (TierList  xxs    ) =
+    TierList <$> traverse (traverse (traverseEntry f)) xxs
+  where
+    traverseEntry f (uri, a) = (,) uri <$> f (uri, a)
+
+{-----------------------------------------------------------------------
+--  List extraction
+-----------------------------------------------------------------------}
+-- BEP12 do not expose any restrictions for the content of
+-- 'announce-list' key - there are some /bad/ cases can happen with
+-- poorly designed or even malicious torrent creation software.
+--
+-- Bad case #1: announce-list is present, but empty.
+--
+--   { tAnnounce     = Just "http://a.com"
+--   , tAnnounceList = Just [[]]
+--   }
+--
+-- Bad case #2: announce uri do not present in announce list.
+--
+--   { tAnnounce     = Just "http://a.com"
+--   , tAnnounceList = Just [["udp://a.com"]]
+--   }
+--
+--  The addBackup function solves both problems by adding announce uri
+--  as backup tier.
+--
+addBackup :: [[URI]] -> URI -> [[URI]]
+addBackup tiers bkp
+  | L.any (L.elem bkp) tiers = tiers
+  |         otherwise        = tiers ++ [[bkp]]
+
+fixList :: Maybe [[URI]] -> Maybe URI -> Maybe [[URI]]
+fixList mxss mx = do
+  xss <- mxss
+  let xss' = L.filter (not . L.null) xss
+  return $ maybe xss' (addBackup xss') mx
+
+-- | Extract set of trackers from torrent file. The 'tAnnounce' key is
+-- only ignored if the 'tAnnounceList' key is present.
+trackerList :: Torrent -> TrackerList ()
+trackerList Torrent {..} = fromMaybe (TierList []) $ do
+       (TierList . tierList)  <$> (tAnnounceList `fixList` tAnnounce)
+   <|> (Announce . nullEntry) <$>  tAnnounce
+  where
+    nullEntry uri = (uri, ())
+    tierList      = L.map (L.map nullEntry)
+
+-- | Shuffle /order of trackers/ in each tier, preserving original
+-- /order of tiers/. This can help to balance the load between the
+-- trackers.
+shuffleTiers :: TrackerList a -> IO (TrackerList a)
+shuffleTiers (Announce a ) = return (Announce a)
+shuffleTiers (TierList xs) = TierList <$> mapM shuffleM xs
+
+mapWithURI :: (URI -> a -> b) -> TrackerList a -> TrackerList b
+mapWithURI f (Announce (uri, a)) = Announce (uri, f uri a)
+mapWithURI f (TierList xs      ) = TierList (L.map (L.map mapEntry) xs)
+  where
+    mapEntry (uri, a) = (uri, f uri a)
+
+toList :: TrackerList a -> [[TierEntry a]]
+toList (Announce   e) = [[e]]
+toList (TierList xxs) = xxs
+
+{-----------------------------------------------------------------------
+--  Special traversals (suppressed RPC exceptions)
+-----------------------------------------------------------------------}
+
+catchRPC :: IO a -> IO a -> IO a
+catchRPC a b = catch a (f b)
+  where
+    f :: a -> RpcException -> a
+    f = const
+
+throwRPC :: String -> IO a
+throwRPC = throwIO . GenericException
+
+-- | Like 'traverse' but ignores 'RpcExceptions'.
+traverseAll :: (TierEntry a -> IO a) -> TrackerList a -> IO (TrackerList a)
+traverseAll action = traverseWithURI (action $?)
+  where
+    f $? x = catchRPC (f x) (return (snd x))
+
+-- | Like 'traverse' but put working trackers to the head of tiers.
+-- This can help to avoid exceessive requests to not available
+-- trackers at each reannounce. If no one action succeed then original
+-- list is returned.
+traverseTiers :: (TierEntry a -> IO a) -> TrackerList a -> IO (TrackerList a)
+traverseTiers action ts = catchRPC (goList ts) (return ts)
+  where
+    goList tl @ (Announce _    ) = traverseWithURI action tl
+    goList      (TierList tiers) = TierList <$> goTiers (goTier []) tiers
+
+    goTiers _ []       = throwRPC "traverseTiers: no tiers"
+    goTiers f (x : xs) = catchRPC shortcut failback
+      where
+        shortcut = do
+          x' <- f x
+          return (x' : xs)
+
+        failback = do
+          xs' <- goTiers f xs
+          return (x : xs')
+
+    goTier _      []       = throwRPC "traverseTiers: no trackers in tier"
+    goTier failed ((uri, a) : as) = catchRPC shortcut failback
+      where
+        shortcut = do
+          a' <- action (uri, a)
+          return ((uri, a') : as ++ failed) -- failed trackers at the end
+
+        failback = goTier ((uri, a) : failed) as
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Message.hs b/bittorrent/src/Network/BitTorrent/Tracker/Message.hs
new file mode 100644
index 00000000..b9b6a9d3
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/Message.hs
@@ -0,0 +1,920 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--                  (c) Daniel Gröber 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Every tracker should support announce query. This query is used
+--   to discover peers within a swarm and have two-fold effect:
+--
+--     * peer doing announce discover other peers using peer list from
+--     the response to the announce query.
+--
+--     * tracker store peer information and use it in the succeeding
+--     requests made by other peers, until the peer info expires.
+--
+--   By convention most trackers support another form of request —
+--   scrape query — which queries the state of a given torrent (or
+--   a list of torrents) that the tracker is managing.
+--
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.BitTorrent.Tracker.Message
+       ( -- * Announce
+         -- ** Query
+         AnnounceEvent (..)
+       , AnnounceQuery (..)
+       , renderAnnounceQuery
+       , ParamParseFailure
+       , parseAnnounceQuery
+
+         -- ** Info
+       , PeerList (..)
+       , getPeerList
+       , AnnounceInfo(..)
+       , defaultNumWant
+       , defaultMaxNumWant
+       , defaultReannounceInterval
+
+         -- * Scrape
+         -- ** Query
+       , ScrapeQuery
+       , renderScrapeQuery
+       , parseScrapeQuery
+
+         -- ** Info
+       , ScrapeEntry (..)
+       , ScrapeInfo
+
+         -- * HTTP specific
+         -- ** Routes
+       , PathPiece
+       , defaultAnnouncePath
+       , defaultScrapePath
+
+         -- ** Preferences
+       , AnnouncePrefs (..)
+       , renderAnnouncePrefs
+       , parseAnnouncePrefs
+
+         -- ** Request
+       , AnnounceRequest  (..)
+       , parseAnnounceRequest
+       , renderAnnounceRequest
+
+         -- ** Response
+       , announceType
+       , scrapeType
+       , parseFailureStatus
+
+         -- ** Extra
+       , queryToSimpleQuery
+
+         -- * UDP specific
+         -- ** Connection
+       , ConnectionId
+       , initialConnectionId
+
+         -- ** Messages
+       , Request (..)
+       , Response (..)
+       , responseName
+
+         -- ** Transaction
+       , genTransactionId
+       , TransactionId
+       , Transaction  (..)
+       )
+       where
+
+import Control.Applicative
+import Control.Monad
+import Data.BEncode as BE hiding (Result)
+import Data.BEncode.BDict as BE
+import Data.ByteString as BS
+import Data.ByteString.Char8 as BC
+import Data.Char as Char
+import Data.Convertible
+import Data.Default
+import Data.Either
+import Data.List as L
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize as S hiding (Result)
+import Data.String
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Typeable
+import Data.Word
+import Data.IP
+import Network
+import Network.HTTP.Types.QueryLike
+import Network.HTTP.Types.URI hiding (urlEncode)
+import Network.HTTP.Types.Status
+import Network.Socket hiding (Connected)
+import Numeric
+import System.Entropy
+import Text.Read (readMaybe)
+
+import Data.Torrent
+import Network.Address
+import Network.BitTorrent.Internal.Progress
+
+{-----------------------------------------------------------------------
+--  Events
+-----------------------------------------------------------------------}
+
+-- | Events are used to specify which kind of announce query is performed.
+data AnnounceEvent
+    -- | For the first request: when download first begins.
+  = Started
+
+    -- | This peer stopped downloading /and/ uploading the torrent or
+    -- just shutting down.
+  | Stopped
+
+    -- | This peer completed downloading the torrent. This only happen
+    -- right after last piece have been verified. No 'Completed' is
+    -- sent if the file was completed when 'Started'.
+  | Completed
+    deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
+
+-- | HTTP tracker protocol compatible encoding.
+instance QueryValueLike AnnounceEvent where
+  toQueryValue e = toQueryValue (Char.toLower x : xs)
+    where
+      (x : xs) = show e -- INVARIANT: this is always nonempty list
+
+type EventId = Word32
+
+-- | UDP tracker encoding event codes.
+eventId :: AnnounceEvent -> EventId
+eventId Completed = 1
+eventId Started   = 2
+eventId Stopped   = 3
+
+-- TODO add Regular event
+putEvent :: Putter (Maybe AnnounceEvent)
+putEvent Nothing  = putWord32be 0
+putEvent (Just e) = putWord32be (eventId e)
+
+getEvent :: S.Get (Maybe AnnounceEvent)
+getEvent = do
+  eid <- getWord32be
+  case eid of
+    0 -> return Nothing
+    1 -> return $ Just Completed
+    2 -> return $ Just Started
+    3 -> return $ Just Stopped
+    _ -> fail "unknown event id"
+
+{-----------------------------------------------------------------------
+  Announce query
+-----------------------------------------------------------------------}
+-- TODO add &ipv6= and &ipv4= params to AnnounceQuery
+-- http://www.bittorrent.org/beps/bep_0007.html#announce-parameter
+
+-- | A tracker request is HTTP GET request; used to include metrics
+--   from clients that help the tracker keep overall statistics about
+--   the torrent. The most important, requests are used by the tracker
+--   to keep track lists of active peer for a particular torrent.
+--
+data AnnounceQuery = AnnounceQuery
+   {
+     -- | Hash of info part of the torrent usually obtained from
+     -- 'Torrent' or 'Magnet'.
+     reqInfoHash   :: !InfoHash
+
+     -- | ID of the peer doing request.
+   , reqPeerId     :: !PeerId
+
+     -- | Port to listen to for connections from other
+     -- peers. Tracker should respond with this port when
+     -- some /other/ peer request the tracker with the same info hash.
+     -- Normally, this port is choosed from 'defaultPorts'.
+   , reqPort       :: !PortNumber
+
+     -- | Current progress of peer doing request.
+   , reqProgress   :: !Progress
+
+     -- | The peer IP. Needed only when client communicated with
+     -- tracker throught a proxy.
+   , reqIP         :: Maybe HostAddress
+
+     -- | Number of peers that the peers wants to receive from. It is
+     -- optional for trackers to honor this limit. See note for
+     -- 'defaultNumWant'.
+   , reqNumWant    :: Maybe Int
+
+     -- | If not specified, the request is regular periodic
+     -- request. Regular request should be sent
+   , reqEvent      :: Maybe AnnounceEvent
+   } deriving (Show, Eq, Typeable)
+
+-- | UDP tracker protocol compatible encoding.
+instance Serialize AnnounceQuery where
+  put AnnounceQuery {..} = do
+    put           reqInfoHash
+    put           reqPeerId
+    put           reqProgress
+    putEvent      reqEvent
+    putWord32host $ fromMaybe 0 reqIP
+    putWord32be   $ 0 -- TODO what the fuck is "key"?
+    putWord32be   $ fromIntegral $ fromMaybe (-1) reqNumWant
+
+    put           reqPort
+
+  get = do
+    ih   <- get
+    pid  <- get
+
+    progress <- get
+
+    ev   <- getEvent
+    ip   <- getWord32be
+--    key  <- getWord32be -- TODO
+    want <- getWord32be
+
+    port <- get
+
+    return $ AnnounceQuery {
+        reqInfoHash   = ih
+      , reqPeerId     = pid
+      , reqPort       = port
+      , reqProgress   = progress
+      , reqIP         = if ip == 0 then Nothing else Just ip
+      , reqNumWant    = if want == -1 then Nothing
+                        else Just (fromIntegral want)
+      , reqEvent      = ev
+      }
+
+instance QueryValueLike PortNumber where
+  toQueryValue = toQueryValue . show . fromEnum
+
+instance QueryValueLike Word32 where
+  toQueryValue = toQueryValue . show
+
+instance QueryValueLike Int where
+  toQueryValue = toQueryValue . show
+
+-- | HTTP tracker protocol compatible encoding.
+instance QueryLike AnnounceQuery where
+  toQuery AnnounceQuery {..} =
+      toQuery reqProgress ++
+      [ ("info_hash", toQueryValue reqInfoHash) -- TODO use 'paramName'
+      , ("peer_id"  , toQueryValue reqPeerId)
+      , ("port"     , toQueryValue reqPort)
+      , ("ip"       , toQueryValue reqIP)
+      , ("numwant"  , toQueryValue reqNumWant)
+      , ("event"    , toQueryValue reqEvent)
+      ]
+
+-- | Filter @param=value@ pairs with the unset value.
+queryToSimpleQuery :: Query -> SimpleQuery
+queryToSimpleQuery = catMaybes . L.map f
+  where
+    f (_, Nothing) = Nothing
+    f (a, Just b ) = Just (a, b)
+
+-- | Encode announce query to query string.
+renderAnnounceQuery :: AnnounceQuery -> SimpleQuery
+renderAnnounceQuery = queryToSimpleQuery . toQuery
+
+data QueryParam
+    -- announce query
+  = ParamInfoHash
+  | ParamPeerId
+  | ParamPort
+  | ParamUploaded
+  | ParamLeft
+  | ParamDownloaded
+  | ParamIP
+  | ParamNumWant
+  | ParamEvent
+    -- announce query ext
+  | ParamCompact
+  | ParamNoPeerId
+    deriving (Show, Eq, Ord, Enum)
+
+paramName :: QueryParam -> BS.ByteString
+paramName ParamInfoHash   = "info_hash"
+paramName ParamPeerId     = "peer_id"
+paramName ParamPort       = "port"
+paramName ParamUploaded   = "uploaded"
+paramName ParamLeft       = "left"
+paramName ParamDownloaded = "downloaded"
+paramName ParamIP         = "ip"
+paramName ParamNumWant    = "numwant"
+paramName ParamEvent      = "event"
+paramName ParamCompact    = "compact"
+paramName ParamNoPeerId   = "no_peer_id"
+{-# INLINE paramName #-}
+
+class FromParam a where
+  fromParam :: BS.ByteString -> Maybe a
+
+instance FromParam Bool where
+  fromParam "0" = Just False
+  fromParam "1" = Just True
+  fromParam _   = Nothing
+
+instance FromParam InfoHash where
+  fromParam = either (const Nothing) pure . safeConvert
+
+instance FromParam PeerId where
+  fromParam = either (const Nothing) pure . safeConvert
+
+instance FromParam Word32 where
+  fromParam = readMaybe . BC.unpack
+
+instance FromParam Word64 where
+  fromParam = readMaybe . BC.unpack
+
+instance FromParam Int where
+  fromParam = readMaybe . BC.unpack
+
+instance FromParam PortNumber where
+  fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32)
+
+instance FromParam AnnounceEvent where
+  fromParam bs = do
+    (x, xs) <- BC.uncons bs
+    readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs
+
+-- | 'ParamParseFailure' represent errors can occur while parsing HTTP
+-- tracker requests. In case of failure, this can be used to provide
+-- more informative 'statusCode' and 'statusMessage' in tracker
+-- responses.
+--
+data ParamParseFailure
+  = Missing QueryParam               -- ^ param not found in query string;
+  | Invalid QueryParam BS.ByteString -- ^ param present but not valid.
+    deriving (Show, Eq)
+
+type ParseResult = Either ParamParseFailure
+
+withError :: ParamParseFailure -> Maybe a -> ParseResult a
+withError e = maybe (Left e) Right
+
+reqParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult a
+reqParam param xs = do
+  val <- withError (Missing param) $ L.lookup (paramName param) xs
+  withError (Invalid param val) (fromParam val)
+
+optParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult (Maybe a)
+optParam param ps
+  | Just x <- L.lookup (paramName param) ps
+  = pure <$> withError (Invalid param x) (fromParam x)
+  | otherwise = pure Nothing
+
+parseProgress :: SimpleQuery -> ParseResult Progress
+parseProgress params = Progress
+  <$> reqParam ParamDownloaded params
+  <*> reqParam ParamLeft       params
+  <*> reqParam ParamUploaded   params
+
+-- | Parse announce request from a query string.
+parseAnnounceQuery :: SimpleQuery -> ParseResult AnnounceQuery
+parseAnnounceQuery params = AnnounceQuery
+  <$> reqParam ParamInfoHash params
+  <*> reqParam ParamPeerId   params
+  <*> reqParam ParamPort     params
+  <*> parseProgress params
+  <*> optParam ParamIP       params
+  <*> optParam ParamNumWant  params
+  <*> optParam ParamEvent    params
+
+{-----------------------------------------------------------------------
+--  Announce Info
+-----------------------------------------------------------------------}
+-- TODO check if announceinterval/complete/incomplete is positive ints
+
+-- | Tracker can return peer list in either compact(BEP23) or not
+-- compact form.
+--
+--   For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
+--
+data PeerList ip
+  = PeerList        [PeerAddr IP]
+  | CompactPeerList [PeerAddr ip]
+    deriving (Show, Eq, Typeable, Functor)
+
+-- | The empty non-compact peer list.
+instance Default (PeerList IP) where
+  def = PeerList []
+  {-# INLINE def #-}
+
+getPeerList :: PeerList IP -> [PeerAddr IP]
+getPeerList (PeerList        xs) = xs
+getPeerList (CompactPeerList xs) = xs
+
+instance Serialize a => BEncode (PeerList a) where
+  toBEncode (PeerList        xs) = toBEncode xs
+  toBEncode (CompactPeerList xs) = toBEncode $ runPut (mapM_ put xs)
+
+  fromBEncode (BList    l ) = PeerList        <$> fromBEncode (BList l)
+  fromBEncode (BString  s ) = CompactPeerList <$> runGet (many get) s
+  fromBEncode  _ = decodingError "PeerList: should be a BString or BList"
+
+-- | The tracker response includes a peer list that helps the client
+--   participate in the torrent. The most important is 'respPeer' list
+--   used to join the swarm.
+--
+data AnnounceInfo =
+     Failure !Text -- ^ Failure reason in human readable form.
+   | AnnounceInfo {
+       -- | Number of peers completed the torrent. (seeders)
+       respComplete    :: !(Maybe Int)
+
+       -- | Number of peers downloading the torrent. (leechers)
+     , respIncomplete  :: !(Maybe Int)
+
+       -- | Recommended interval to wait between requests, in seconds.
+     , respInterval    :: !Int
+
+       -- | Minimal amount of time between requests, in seconds. A
+       -- peer /should/ make timeout with at least 'respMinInterval'
+       -- value, otherwise tracker might not respond. If not specified
+       -- the same applies to 'respInterval'.
+     , respMinInterval :: !(Maybe Int)
+
+       -- | Peers that must be contacted.
+     , respPeers       :: !(PeerList IP)
+
+       -- | Human readable warning.
+     , respWarning     :: !(Maybe Text)
+     } deriving (Show, Eq, Typeable)
+
+-- | Empty peer list with default reannounce interval.
+instance Default AnnounceInfo where
+  def = AnnounceInfo
+    { respComplete    = Nothing
+    , respIncomplete  = Nothing
+    , respInterval    = defaultReannounceInterval
+    , respMinInterval = Nothing
+    , respPeers       = def
+    , respWarning     = Nothing
+    }
+
+-- | HTTP tracker protocol compatible encoding.
+instance BEncode AnnounceInfo where
+  toBEncode (Failure t)        = toDict $
+       "failure reason" .=! t
+    .: endDict
+
+  toBEncode  AnnounceInfo {..} = toDict $
+       "complete"        .=? respComplete
+    .: "incomplete"      .=? respIncomplete
+    .: "interval"        .=! respInterval
+    .: "min interval"    .=? respMinInterval
+    .: "peers"           .=! peers
+    .: "peers6"          .=? peers6
+    .: "warning message" .=? respWarning
+    .: endDict
+    where
+      (peers, peers6) = prttn respPeers
+
+      prttn :: PeerList IP -> (PeerList IPv4, Maybe (PeerList IPv6))
+      prttn (PeerList        xs) = (PeerList xs, Nothing)
+      prttn (CompactPeerList xs) = mk $ partitionEithers $ toEither <$> xs
+        where
+          mk (v4s, v6s)
+            | L.null v6s = (CompactPeerList v4s, Nothing)
+            | otherwise  = (CompactPeerList v4s, Just (CompactPeerList v6s))
+
+          toEither :: PeerAddr IP -> Either (PeerAddr IPv4) (PeerAddr IPv6)
+          toEither PeerAddr {..} = case peerHost of
+            IPv4 ipv4 -> Left  $ PeerAddr peerId ipv4 peerPort
+            IPv6 ipv6 -> Right $ PeerAddr peerId ipv6 peerPort
+
+  fromBEncode (BDict d)
+    | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t
+    | otherwise = (`fromDict` (BDict d)) $
+       AnnounceInfo
+        <$>? "complete"
+        <*>? "incomplete"
+        <*>! "interval"
+        <*>? "min interval"
+        <*>  (uncurry merge =<< (,) <$>! "peers" <*>? "peers6")
+        <*>? "warning message"
+    where
+      merge :: PeerList IPv4 -> Maybe (PeerList IPv6) -> BE.Get (PeerList IP)
+      merge (PeerList ips)          Nothing  = pure (PeerList ips)
+      merge (PeerList _  )          (Just _)
+        = fail "PeerList: non-compact peer list provided, \
+                         \but the `peers6' field present"
+
+      merge (CompactPeerList ipv4s) Nothing
+        = pure $ CompactPeerList (fmap IPv4 <$> ipv4s)
+
+      merge (CompactPeerList _    ) (Just (PeerList _))
+        = fail "PeerList: the `peers6' field value \
+                         \should contain *compact* peer list"
+
+      merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s))
+        = pure $ CompactPeerList $
+                 (fmap IPv4 <$> ipv4s) <> (fmap IPv6 <$> ipv6s)
+
+  fromBEncode _ = decodingError "Announce info"
+
+-- | UDP tracker protocol compatible encoding.
+instance Serialize AnnounceInfo where
+  put (Failure msg) = put $ encodeUtf8 msg
+  put  AnnounceInfo {..} = do
+    putWord32be $ fromIntegral respInterval
+    putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete
+    putWord32be $ fromIntegral $ fromMaybe 0 respComplete
+    forM_ (fmap ipv4 <$> getPeerList respPeers) put
+
+  get = do
+    interval <- getWord32be
+    leechers <- getWord32be
+    seeders  <- getWord32be
+    peers    <- many $ fmap IPv4 <$> get
+
+    return $ AnnounceInfo {
+        respWarning     = Nothing
+      , respInterval    = fromIntegral interval
+      , respMinInterval = Nothing
+      , respIncomplete  = Just $ fromIntegral leechers
+      , respComplete    = Just $ fromIntegral seeders
+      , respPeers       = PeerList peers
+      }
+
+-- | Decodes announce response from bencoded string, for debugging only.
+instance IsString AnnounceInfo where
+  fromString str = either (error . format) id $ BE.decode (fromString str)
+    where
+      format msg = "fromString: unable to decode AnnounceInfo: " ++ msg
+
+-- | Above 25, new peers are highly unlikely to increase download
+--   speed.  Even 30 peers is /plenty/, the official client version 3
+--   in fact only actively forms new connections if it has less than
+--   30 peers and will refuse connections if it has 55.
+--
+--   <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Basic_Tracker_Announce_Request>
+--
+defaultNumWant :: Int
+defaultNumWant = 50
+
+-- | Reasonable upper bound of numwant parameter.
+defaultMaxNumWant :: Int
+defaultMaxNumWant = 200
+
+-- | Widely used reannounce interval. Note: tracker clients should not
+-- use this value!
+defaultReannounceInterval :: Int
+defaultReannounceInterval = 30 * 60
+
+{-----------------------------------------------------------------------
+  Scrape message
+-----------------------------------------------------------------------}
+
+-- | Scrape query used to specify a set of torrent to scrape.
+-- If list is empty then tracker should return scrape info about each
+-- torrent.
+type ScrapeQuery = [InfoHash]
+
+-- TODO
+-- data ScrapeQuery
+--  = ScrapeAll
+--  | ScrapeSingle InfoHash
+--  | ScrapeMulti (HashSet InfoHash)
+--    deriving (Show)
+--
+--  data ScrapeInfo
+--    = ScrapeAll   (HashMap InfoHash ScrapeEntry)
+--    | ScrapeSingle InfoHash ScrapeEntry
+--    | ScrapeMulti (HashMap InfoHash ScrapeEntry)
+--
+
+scrapeParam :: BS.ByteString
+scrapeParam = "info_hash"
+
+isScrapeParam :: BS.ByteString -> Bool
+isScrapeParam = (==) scrapeParam
+
+-- | Parse scrape query to query string.
+parseScrapeQuery :: SimpleQuery -> ScrapeQuery
+parseScrapeQuery
+  = catMaybes . L.map (fromParam . snd) . L.filter (isScrapeParam . fst)
+
+-- | Render scrape query to query string.
+renderScrapeQuery :: ScrapeQuery -> SimpleQuery
+renderScrapeQuery = queryToSimpleQuery . L.map mkPair
+  where
+    mkPair ih = (scrapeParam, toQueryValue ih)
+
+-- | Overall information about particular torrent.
+data ScrapeEntry = ScrapeEntry {
+    -- | Number of seeders - peers with the entire file.
+    siComplete   :: {-# UNPACK #-} !Int
+
+    -- | Total number of times the tracker has registered a completion.
+  , siDownloaded :: {-# UNPACK #-} !Int
+
+    -- | Number of leechers.
+  , siIncomplete :: {-# UNPACK #-} !Int
+
+    -- | Name of the torrent file, as specified by the "name"
+    --   file in the info section of the .torrent file.
+  , siName       :: !(Maybe Text)
+  } deriving (Show, Eq, Typeable)
+
+-- | HTTP tracker protocol compatible encoding.
+instance BEncode ScrapeEntry where
+  toBEncode ScrapeEntry {..} = toDict $
+       "complete"   .=! siComplete
+    .: "downloaded" .=! siDownloaded
+    .: "incomplete" .=! siIncomplete
+    .: "name"       .=? siName
+    .: endDict
+
+  fromBEncode = fromDict $ ScrapeEntry
+    <$>! "complete"
+    <*>! "downloaded"
+    <*>! "incomplete"
+    <*>? "name"
+
+-- | UDP tracker protocol compatible encoding.
+instance Serialize ScrapeEntry where
+  put ScrapeEntry {..} = do
+    putWord32be $ fromIntegral siComplete
+    putWord32be $ fromIntegral siDownloaded
+    putWord32be $ fromIntegral siIncomplete
+
+  get = ScrapeEntry
+    <$> (fromIntegral <$> getWord32be)
+    <*> (fromIntegral <$> getWord32be)
+    <*> (fromIntegral <$> getWord32be)
+    <*> pure Nothing
+
+-- | Scrape info about a set of torrents.
+type ScrapeInfo = [(InfoHash, ScrapeEntry)]
+
+{-----------------------------------------------------------------------
+--  HTTP specific
+-----------------------------------------------------------------------}
+
+-- | Some HTTP trackers allow to choose prefered representation of the
+-- 'AnnounceInfo'. It's optional for trackers to honor any of this
+-- options.
+data AnnouncePrefs = AnnouncePrefs
+  { -- | If specified, "compact" parameter is used to advise the
+    --   tracker to send peer id list as:
+    --
+    --   * bencoded list                 (extCompact = Just False);
+    --   * or more compact binary string (extCompact = Just True).
+    --
+    --   The later is prefered since compact peer list will reduce the
+    --   size of tracker responses. Hovewer, if tracker do not support
+    --   this extension then it can return peer list in either form.
+    --
+    --   For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
+    --
+    extCompact  :: !(Maybe Bool)
+
+    -- | If specified, "no_peer_id" parameter is used advise tracker
+    --   to either send or not to send peer id in tracker response.
+    --   Tracker may not support this extension as well.
+    --
+    --   For more info see:
+    --  <http://permalink.gmane.org/gmane.network.bit-torrent.general/4030>
+    --
+  , extNoPeerId :: !(Maybe Bool)
+  } deriving (Show, Eq, Typeable)
+
+instance Default AnnouncePrefs where
+  def = AnnouncePrefs Nothing Nothing
+
+instance QueryLike AnnouncePrefs where
+  toQuery AnnouncePrefs {..} =
+      [ ("compact",    toQueryFlag <$> extCompact) -- TODO use 'paramName'
+      , ("no_peer_id", toQueryFlag <$> extNoPeerId)
+      ]
+    where
+      toQueryFlag False = "0"
+      toQueryFlag True  = "1"
+
+-- | Parse announce query extended part from query string.
+parseAnnouncePrefs :: SimpleQuery -> AnnouncePrefs
+parseAnnouncePrefs params = either (const def) id $
+  AnnouncePrefs
+    <$> optParam ParamCompact  params
+    <*> optParam ParamNoPeerId params
+
+-- | Render announce preferences to query string.
+renderAnnouncePrefs :: AnnouncePrefs -> SimpleQuery
+renderAnnouncePrefs = queryToSimpleQuery . toQuery
+
+-- | HTTP tracker request with preferences.
+data AnnounceRequest = AnnounceRequest
+  { announceQuery :: AnnounceQuery -- ^ Request query params.
+  , announcePrefs :: AnnouncePrefs -- ^ Optional advises to the tracker.
+  } deriving (Show, Eq, Typeable)
+
+instance QueryLike AnnounceRequest where
+  toQuery AnnounceRequest{..} =
+    toQuery announcePrefs <>
+    toQuery announceQuery
+
+-- | Parse announce request from query string.
+parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest
+parseAnnounceRequest params = AnnounceRequest
+  <$> parseAnnounceQuery params
+  <*> pure (parseAnnouncePrefs params)
+
+-- | Render announce request to query string.
+renderAnnounceRequest :: AnnounceRequest -> SimpleQuery
+renderAnnounceRequest = queryToSimpleQuery . toQuery
+
+type PathPiece = BS.ByteString
+
+defaultAnnouncePath :: PathPiece
+defaultAnnouncePath = "announce"
+
+defaultScrapePath :: PathPiece
+defaultScrapePath = "scrape"
+
+missingOffset :: Int
+missingOffset = 101
+
+invalidOffset :: Int
+invalidOffset = 150
+
+parseFailureCode :: ParamParseFailure -> Int
+parseFailureCode (Missing param  ) = missingOffset + fromEnum param
+parseFailureCode (Invalid param _) = invalidOffset + fromEnum param
+
+parseFailureMessage :: ParamParseFailure -> BS.ByteString
+parseFailureMessage e = BS.concat $ case e of
+  Missing p   -> ["Missing parameter: ", paramName p]
+  Invalid p v -> ["Invalid parameter: ", paramName p, " = ", v]
+
+-- | HTTP response /content type/ for announce info.
+announceType :: ByteString
+announceType = "text/plain"
+
+-- | HTTP response /content type/ for scrape info.
+scrapeType :: ByteString
+scrapeType = "text/plain"
+
+-- | Get HTTP response status from a announce params parse failure.
+--
+--   For more info see:
+--   <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Response_Codes>
+--
+parseFailureStatus :: ParamParseFailure -> Status
+parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage
+
+{-----------------------------------------------------------------------
+--  UDP specific message types
+-----------------------------------------------------------------------}
+
+genToken :: IO Word64
+genToken = do
+    bs <- getEntropy 8
+    either err return $ runGet getWord64be bs
+  where
+    err = error "genToken: impossible happen"
+
+-- | Connection Id is used for entire tracker session.
+newtype ConnectionId  = ConnectionId Word64
+  deriving (Eq, Serialize)
+
+instance Show ConnectionId where
+  showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid
+
+initialConnectionId :: ConnectionId
+initialConnectionId =  ConnectionId 0x41727101980
+
+-- | Transaction Id is used within a UDP RPC.
+newtype TransactionId = TransactionId Word32
+  deriving (Eq, Ord, Enum, Bounded, Serialize)
+
+instance Show TransactionId where
+  showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid
+
+genTransactionId :: IO TransactionId
+genTransactionId = (TransactionId . fromIntegral) <$> genToken
+
+data Request
+  = Connect
+  | Announce  AnnounceQuery
+  | Scrape    ScrapeQuery
+    deriving Show
+
+data Response
+  = Connected ConnectionId
+  | Announced AnnounceInfo
+  | Scraped   [ScrapeEntry]
+  | Failed    Text
+    deriving Show
+
+responseName :: Response -> String
+responseName (Connected _) = "connected"
+responseName (Announced _) = "announced"
+responseName (Scraped   _) = "scraped"
+responseName (Failed    _) = "failed"
+
+data family Transaction a
+data instance Transaction Request  = TransactionQ
+    { connIdQ  :: {-# UNPACK #-} !ConnectionId
+    , transIdQ :: {-# UNPACK #-} !TransactionId
+    , request  :: !Request
+    } deriving Show
+data instance Transaction Response = TransactionR
+    { transIdR :: {-# UNPACK #-} !TransactionId
+    , response :: !Response
+    } deriving Show
+
+-- TODO newtype
+newtype MessageId = MessageId Word32
+                    deriving (Show, Eq, Num, Serialize)
+
+connectId, announceId, scrapeId, errorId :: MessageId
+connectId  = 0
+announceId = 1
+scrapeId   = 2
+errorId    = 3
+
+instance Serialize (Transaction Request) where
+  put TransactionQ {..} = do
+    case request of
+      Connect        -> do
+        put initialConnectionId
+        put connectId
+        put transIdQ
+
+      Announce ann -> do
+        put connIdQ
+        put announceId
+        put transIdQ
+        put ann
+
+      Scrape   hashes -> do
+        put connIdQ
+        put scrapeId
+        put transIdQ
+        forM_ hashes put
+
+  get = do
+      cid <- get
+      mid <- get
+      TransactionQ cid <$> S.get <*> getBody mid
+    where
+      getBody :: MessageId -> S.Get Request
+      getBody msgId
+        | msgId == connectId  = pure Connect
+        | msgId == announceId = Announce <$> get
+        | msgId == scrapeId   = Scrape   <$> many get
+        |       otherwise     = fail errMsg
+        where
+          errMsg = "unknown request: " ++ show msgId
+
+instance Serialize (Transaction Response) where
+  put TransactionR {..} = do
+    case response of
+      Connected conn -> do
+        put connectId
+        put transIdR
+        put conn
+
+      Announced info -> do
+        put announceId
+        put transIdR
+        put info
+
+      Scraped infos -> do
+        put scrapeId
+        put transIdR
+        forM_ infos put
+
+      Failed info -> do
+        put errorId
+        put transIdR
+        put (encodeUtf8 info)
+
+
+  get = do
+      mid <- get
+      TransactionR <$> get <*> getBody mid
+    where
+      getBody :: MessageId -> S.Get Response
+      getBody msgId
+        | msgId == connectId  = Connected <$> get
+        | msgId == announceId = Announced <$> get
+        | msgId == scrapeId   = Scraped   <$> many get
+        | msgId == errorId    = (Failed . decodeUtf8) <$> get
+        |       otherwise     = fail msg
+        where
+          msg = "unknown response: " ++ show msgId
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs
new file mode 100644
index 00000000..45fef05e
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs
@@ -0,0 +1,175 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This module provides unified RPC interface to BitTorrent
+--   trackers. The tracker is an UDP/HTTP/HTTPS service used to
+--   discovery peers for a particular existing torrent and keep
+--   statistics about the swarm. This module also provides a way to
+--   request scrape info for a particular torrent list.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Network.BitTorrent.Tracker.RPC
+       ( PeerInfo (..)
+
+         -- * Manager
+       , Options (..)
+       , Manager
+       , newManager
+       , closeManager
+       , withManager
+
+         -- * RPC
+       , SAnnounceQuery (..)
+       , RpcException (..)
+       , Network.BitTorrent.Tracker.RPC.announce
+       , scrape
+       ) where
+
+import Control.Exception
+import Data.Default
+import Data.Typeable
+import Network
+import Network.URI
+import Network.Socket (HostAddress)
+
+import           Data.Torrent
+import           Network.Address
+import           Network.BitTorrent.Internal.Progress
+import           Network.BitTorrent.Tracker.Message
+import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP
+import qualified Network.BitTorrent.Tracker.RPC.UDP  as UDP
+
+
+{-----------------------------------------------------------------------
+--  Simplified announce
+-----------------------------------------------------------------------}
+
+-- | Info to advertise to trackers.
+data PeerInfo = PeerInfo
+  { peerId   :: !PeerId
+  , peerIP   :: !(Maybe HostAddress)
+  , peerPort :: !PortNumber
+  } deriving (Show, Eq)
+
+instance Default PeerInfo where
+  def = PeerInfo def Nothing 6881
+
+-- | Simplified announce query.
+data SAnnounceQuery = SAnnounceQuery
+  { sInfoHash :: InfoHash
+  , sProgress :: Progress
+  , sNumWant  :: Maybe Int
+  , sEvent    :: Maybe AnnounceEvent
+  }
+
+fillAnnounceQuery :: PeerInfo  ->  SAnnounceQuery  ->    AnnounceQuery
+fillAnnounceQuery    PeerInfo{..} SAnnounceQuery {..} = AnnounceQuery
+  { reqInfoHash = sInfoHash
+  , reqPeerId   = peerId
+  , reqPort     = peerPort
+  , reqProgress = sProgress
+  , reqIP       = peerIP
+  , reqNumWant  = sNumWant
+  , reqEvent    = sEvent
+  }
+
+{-----------------------------------------------------------------------
+--  RPC manager
+-----------------------------------------------------------------------}
+
+-- | Tracker manager settings.
+data Options = Options
+  { -- | HTTP tracker protocol specific options.
+    optHttpRPC      :: !HTTP.Options
+
+    -- | UDP tracker protocol specific options.
+  , optUdpRPC       :: !UDP.Options
+
+    -- | Whether to use multitracker extension.
+  , optMultitracker :: !Bool
+  }
+
+instance Default Options where
+  def = Options
+    { optHttpRPC      = def
+    , optUdpRPC       = def
+    , optMultitracker = True
+    }
+
+-- | Tracker RPC Manager.
+data Manager  = Manager
+  { options  :: !Options
+  , peerInfo :: !PeerInfo
+  , httpMgr  :: !HTTP.Manager
+  , udpMgr   :: !UDP.Manager
+  }
+
+-- | Create a new 'Manager'. You /must/ manually 'closeManager'
+-- otherwise resource leakage is possible. Normally, a bittorrent
+-- client need a single RPC manager only.
+--
+--   This function can throw 'IOException' on invalid 'Options'.
+--
+newManager :: Options -> PeerInfo -> IO Manager
+newManager opts info = do
+  h <- HTTP.newManager (optHttpRPC opts)
+  u <-  UDP.newManager (optUdpRPC  opts) `onException` HTTP.closeManager h
+  return $ Manager opts info h u
+
+-- | Close all pending RPCs. Behaviour of currently in-flight RPCs can
+-- differ depending on underlying protocol used. No rpc calls should
+-- be performed after manager becomes closed.
+closeManager :: Manager -> IO ()
+closeManager Manager {..} = do
+  UDP.closeManager udpMgr `finally` HTTP.closeManager httpMgr
+
+-- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'.
+withManager :: Options -> PeerInfo -> (Manager -> IO a) -> IO a
+withManager opts info = bracket (newManager opts info) closeManager
+
+{-----------------------------------------------------------------------
+--  Exceptions
+-----------------------------------------------------------------------}
+-- TODO Catch IO exceptions on rpc calls (?)
+
+data RpcException
+  = UdpException    UDP.RpcException  -- ^ UDP RPC driver failure;
+  | HttpException   HTTP.RpcException -- ^ HTTP RPC driver failure;
+  | UnrecognizedScheme   String       -- ^ unsupported scheme in announce URI;
+  | GenericException     String       -- ^ for furter extensibility.
+    deriving (Show, Typeable)
+
+instance Exception RpcException
+
+packException :: Exception e => (e -> RpcException) -> IO a -> IO a
+packException f m = try m >>= either (throwIO . f) return
+{-# INLINE packException #-}
+
+{-----------------------------------------------------------------------
+--  RPC calls
+-----------------------------------------------------------------------}
+
+dispatch :: URI -> IO a -> IO a -> IO a
+dispatch URI {..} http udp
+  | uriScheme == "http:" ||
+    uriScheme == "https:" = packException HttpException http
+  | uriScheme == "udp:"   = packException UdpException  udp
+  |       otherwise       = throwIO $ UnrecognizedScheme uriScheme
+
+announce :: Manager -> URI -> SAnnounceQuery -> IO AnnounceInfo
+announce Manager {..} uri simpleQuery
+  = dispatch uri
+      (HTTP.announce httpMgr uri annQ)
+      ( UDP.announce udpMgr  uri annQ)
+  where
+    annQ = fillAnnounceQuery peerInfo simpleQuery
+
+scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo
+scrape Manager {..} uri q
+  = dispatch uri
+      (HTTP.scrape httpMgr uri q)
+      ( UDP.scrape udpMgr  uri q)
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
new file mode 100644
index 00000000..9b6e056a
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -0,0 +1,191 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  provisional
+--   Portability :  portable
+--
+--   This module implement HTTP tracker protocol.
+--
+--   For more information see:
+--   <https://wiki.theory.org/BitTorrentSpecification#Tracker_HTTP.2FHTTPS_Protocol>
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Network.BitTorrent.Tracker.RPC.HTTP
+       ( -- * Manager
+         Options (..)
+       , Manager
+       , newManager
+       , closeManager
+       , withManager
+
+         -- * RPC
+       , RpcException (..)
+       , announce
+       , scrape
+       , scrapeOne
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans.Resource
+import Data.BEncode as BE
+import Data.ByteString as BS
+import Data.ByteString.Char8 as BC
+import Data.ByteString.Lazy  as BL
+import Data.Default
+import Data.List as L
+import Data.Monoid
+import Data.Typeable hiding (Proxy)
+import Network.URI
+import           Network.HTTP.Conduit hiding
+                 (Manager, newManager, closeManager, withManager)
+import           Network.HTTP.Client (defaultManagerSettings)
+import           Network.HTTP.Client.Internal (setUri)
+import qualified Network.HTTP.Conduit as HTTP
+import           Network.HTTP.Types.Header (hUserAgent)
+import           Network.HTTP.Types.URI    (SimpleQuery, renderSimpleQuery)
+
+import Data.Torrent                        (InfoHash)
+import Network.Address             (libUserAgent)
+import Network.BitTorrent.Tracker.Message hiding (Request, Response)
+
+{-----------------------------------------------------------------------
+-- Exceptions
+-----------------------------------------------------------------------}
+
+data RpcException
+  = RequestFailed HttpException -- ^ failed HTTP request.
+  | ParserFailure String        -- ^ unable to decode tracker response;
+  | ScrapelessTracker           -- ^ tracker do not support scraping;
+  | BadScrape                   -- ^ unable to find info hash in response dict;
+    deriving (Show, Typeable)
+
+instance Exception RpcException
+
+packHttpException :: IO a -> IO a
+packHttpException m = try m >>= either (throwIO . RequestFailed) return
+
+{-----------------------------------------------------------------------
+--  Manager
+-----------------------------------------------------------------------}
+
+-- | HTTP tracker specific RPC options.
+data Options = Options
+  { -- | Global HTTP announce query preferences.
+    optAnnouncePrefs :: !AnnouncePrefs
+
+    -- | Whether to use HTTP proxy for HTTP tracker requests.
+  , optHttpProxy     :: !(Maybe Proxy)
+
+    -- | Value to put in HTTP user agent header.
+  , optUserAgent     :: !BS.ByteString
+
+    -- | HTTP manager options.
+  , optHttpOptions   :: !ManagerSettings
+  }
+
+instance Default Options where
+  def = Options
+    { optAnnouncePrefs = def
+    , optHttpProxy     = Nothing
+    , optUserAgent     = BC.pack libUserAgent
+    , optHttpOptions   = defaultManagerSettings
+    }
+
+-- | HTTP tracker manager.
+data Manager = Manager
+  { options :: !Options
+  , httpMgr :: !HTTP.Manager
+  }
+
+-- |
+newManager :: Options -> IO Manager
+newManager opts = Manager opts <$> HTTP.newManager (optHttpOptions opts)
+
+-- |
+closeManager :: Manager -> IO ()
+closeManager Manager {..} = HTTP.closeManager httpMgr
+
+-- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'.
+withManager :: Options -> (Manager -> IO a) -> IO a
+withManager opts = bracket (newManager opts) closeManager
+
+{-----------------------------------------------------------------------
+--  Queries
+-----------------------------------------------------------------------}
+
+fillRequest :: Options -> SimpleQuery -> Request -> Request
+fillRequest Options {..} q r = r
+  { queryString    = joinQuery (queryString r) (renderSimpleQuery False q)
+  , requestHeaders = (hUserAgent, optUserAgent) : requestHeaders r
+  , proxy          = optHttpProxy
+  }
+  where
+    joinQuery a b
+      | BS.null a = b
+      | otherwise = a <> "&" <> b
+
+httpTracker :: BEncode a => Manager -> URI -> SimpleQuery -> IO a
+httpTracker Manager {..} uri q = packHttpException $ do
+  request  <- fillRequest options q <$> setUri def {- http-client instance for Request -} uri
+  response <- runResourceT $ httpLbs request httpMgr
+  case BE.decode $ BL.toStrict $ responseBody response of
+    Left  msg  -> throwIO (ParserFailure msg)
+    Right info -> return info
+
+{-----------------------------------------------------------------------
+--  RPC
+-----------------------------------------------------------------------}
+
+-- | Send request and receive response from the tracker specified in
+-- announce list.
+--
+--   This function can throw 'RpcException'.
+--
+announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo
+announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ)
+  where
+    uriQ = AnnounceRequest
+      { announceQuery = q
+      , announcePrefs = optAnnouncePrefs (options mgr)
+      }
+
+-- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL'
+--   gives 'Nothing' then tracker do not support scraping.
+--
+scrapeURL :: URI -> Maybe URI
+scrapeURL uri = do
+    newPath <- replace (BC.pack (uriPath uri))
+    return uri { uriPath = BC.unpack newPath }
+  where
+    replace p = do
+      let ps = BC.splitWith (== '/') p
+      guard (not (L.null ps))
+      guard ("announce" `BS.isPrefixOf` L.last ps)
+      let newSuff = "scrape" <> BS.drop (BS.length "announce") (L.last ps)
+      return (BS.intercalate "/" (L.init ps ++ [newSuff]))
+
+-- | For each 'InfoHash' of torrents request scrape info from the tracker.
+--   However if the info hash list is 'null', the tracker should list
+--   all available torrents.
+--
+--   This function can throw 'RpcException'.
+--
+scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo
+scrape m u q = do
+  case scrapeURL u of
+    Nothing  -> throwIO ScrapelessTracker
+    Just uri -> httpTracker m uri (renderScrapeQuery q)
+
+-- | More particular version of 'scrape', just for one torrent.
+--
+--   This function can throw 'RpcException'.
+--
+scrapeOne :: Manager -> URI -> InfoHash -> IO ScrapeEntry
+scrapeOne m uri ih = do
+  xs <- scrape m uri [ih]
+  case L.lookup ih xs of
+    Nothing -> throwIO BadScrape
+    Just a  -> return a
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs
new file mode 100644
index 00000000..31b6b870
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs
@@ -0,0 +1,454 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013-2014
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  provisional
+--   Portability :  portable
+--
+--   This module implement UDP tracker protocol.
+--
+--   For protocol details and uri scheme see:
+--   <http://www.bittorrent.org/beps/bep_0015.html>,
+--   <https://www.iana.org/assignments/uri-schemes/prov/udp>
+--
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+module Network.BitTorrent.Tracker.RPC.UDP
+       ( -- * Manager
+         Options (..)
+       , Manager
+       , newManager
+       , closeManager
+       , withManager
+
+         -- * RPC
+       , RpcException (..)
+       , announce
+       , scrape
+       ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Data.Default
+import Data.IORef
+import Data.List as L
+import Data.Map  as M
+import Data.Maybe
+import Data.Serialize
+import Data.Text as T
+import Data.Time
+import Data.Time.Clock.POSIX
+import Data.Traversable
+import Data.Typeable
+import Text.Read (readMaybe)
+import Network.Socket hiding (Connected, connect, listen)
+import Network.Socket.ByteString as BS
+import Network.URI
+import System.Timeout
+
+import Network.BitTorrent.Tracker.Message
+
+{-----------------------------------------------------------------------
+--  Options
+-----------------------------------------------------------------------}
+
+-- | 'System.Timeout.timeout' specific.
+sec :: Int
+sec = 1000000
+
+-- | See <http://www.bittorrent.org/beps/bep_0015.html#time-outs>
+defMinTimeout :: Int
+defMinTimeout = 15
+
+-- | See <http://www.bittorrent.org/beps/bep_0015.html#time-outs>
+defMaxTimeout :: Int
+defMaxTimeout = 15 * 2 ^ (8 :: Int)
+
+-- | See: <http://www.bittorrent.org/beps/bep_0015.html#time-outs>
+defMultiplier :: Int
+defMultiplier = 2
+
+-- TODO why 98?
+defMaxPacketSize :: Int
+defMaxPacketSize = 98
+
+-- | Manager configuration.
+data Options = Options
+  { -- | Max size of a /response/ packet.
+    --
+    --   'optMaxPacketSize' /must/ be a positive value.
+    --
+    optMaxPacketSize :: {-# UNPACK #-} !Int
+
+    -- | Starting timeout interval in seconds. If a response is not
+    -- received after 'optMinTimeout' then 'Manager' repeat RPC with
+    -- timeout interval multiplied by 'optMultiplier' and so on until
+    -- timeout interval reach 'optMaxTimeout'.
+    --
+    --   'optMinTimeout' /must/ be a positive value.
+    --
+  , optMinTimeout    :: {-# UNPACK #-} !Int
+
+    -- | Final timeout interval in seconds. After 'optMaxTimeout'
+    -- reached and tracker still not responding both 'announce' and
+    -- 'scrape' functions will throw 'TimeoutExpired' exception.
+    --
+    --   'optMaxTimeout' /must/ be greater than 'optMinTimeout'.
+    --
+  , optMaxTimeout    :: {-# UNPACK #-} !Int
+
+    -- | 'optMultiplier' /must/ be a positive value.
+  , optMultiplier    :: {-# UNPACK #-} !Int
+  } deriving (Show, Eq)
+
+-- | Options suitable for bittorrent client.
+instance Default Options where
+  def = Options
+    { optMaxPacketSize = defMaxPacketSize
+    , optMinTimeout    = defMinTimeout
+    , optMaxTimeout    = defMaxTimeout
+    , optMultiplier    = defMultiplier
+    }
+
+checkOptions :: Options -> IO ()
+checkOptions Options {..} = do
+  unless (optMaxPacketSize > 0) $ do
+    throwIO $ userError "optMaxPacketSize must be positive"
+
+  unless (optMinTimeout > 0) $ do
+    throwIO $ userError "optMinTimeout must be positive"
+
+  unless (optMaxTimeout > 0) $ do
+    throwIO $ userError "optMaxTimeout must be positive"
+
+  unless (optMultiplier > 0) $ do
+    throwIO $ userError "optMultiplier must be positive"
+
+  unless (optMaxTimeout > optMinTimeout) $ do
+    throwIO $ userError "optMaxTimeout must be greater than optMinTimeout"
+
+
+{-----------------------------------------------------------------------
+--  Manager state
+-----------------------------------------------------------------------}
+
+type ConnectionCache     = Map SockAddr Connection
+
+type PendingResponse     = MVar (Either RpcException Response)
+type PendingTransactions = Map TransactionId PendingResponse
+type PendingQueries      = Map SockAddr      PendingTransactions
+
+-- | UDP tracker manager.
+data Manager = Manager
+  { options         :: !Options
+  , sock            :: !Socket
+--  , dnsCache        :: !(IORef (Map URI SockAddr))
+  , connectionCache :: !(IORef ConnectionCache)
+  , pendingResps    :: !(MVar  PendingQueries)
+  , listenerThread  :: !(MVar ThreadId)
+  }
+
+initManager :: Options -> IO Manager
+initManager opts = Manager opts
+  <$> socket AF_INET Datagram defaultProtocol
+  <*> newIORef M.empty
+  <*> newMVar  M.empty
+  <*> newEmptyMVar
+
+unblockAll :: PendingQueries -> IO ()
+unblockAll m = traverse (traverse unblockCall) m >> return ()
+  where
+    unblockCall ares = putMVar ares (Left ManagerClosed)
+
+resetState :: Manager -> IO ()
+resetState Manager {..} = do
+    writeIORef          connectionCache err
+    m    <- swapMVar    pendingResps    err
+    unblockAll m
+    mtid <- tryTakeMVar listenerThread
+    case mtid of
+      Nothing -> return () -- thread killed by 'closeManager'
+      Just _  -> return () -- thread killed by exception from 'listen'
+    return ()
+  where
+    err = error "UDP tracker manager closed"
+
+-- | This function will throw 'IOException' on invalid 'Options'.
+newManager :: Options -> IO Manager
+newManager opts = do
+  checkOptions opts
+  mgr <- initManager opts
+  tid <- forkIO (listen mgr `finally` resetState mgr)
+  putMVar (listenerThread mgr) tid
+  return mgr
+
+-- | Unblock all RPCs by throwing 'ManagerClosed' exception. No rpc
+-- calls should be performed after manager becomes closed.
+closeManager :: Manager -> IO ()
+closeManager Manager {..} = do
+  close sock
+  mtid <- tryTakeMVar listenerThread
+  case mtid of
+    Nothing  -> return ()
+    Just tid -> killThread tid
+
+-- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'.
+withManager :: Options -> (Manager -> IO a) -> IO a
+withManager opts = bracket (newManager opts) closeManager
+
+{-----------------------------------------------------------------------
+--  Exceptions
+-----------------------------------------------------------------------}
+
+data RpcException
+    -- | Unable to lookup hostname;
+  = HostUnknown
+
+    -- | Unable to lookup hostname;
+  | HostLookupFailed
+
+    -- | Expecting 'udp:', but some other scheme provided.
+  | UnrecognizedScheme String
+
+    -- | Tracker exists but not responding for specific number of seconds.
+  | TimeoutExpired Int
+
+    -- | Tracker responded with unexpected message type.
+  | UnexpectedResponse
+    { expectedMsg :: String
+    , actualMsg   :: String
+    }
+
+    -- | RPC succeed, but tracker responded with error code.
+  | QueryFailed Text
+
+    -- | RPC manager closed while waiting for response.
+  | ManagerClosed
+    deriving (Eq, Show, Typeable)
+
+instance Exception RpcException
+
+{-----------------------------------------------------------------------
+--  Host Addr resolution
+-----------------------------------------------------------------------}
+
+setPort :: PortNumber -> SockAddr -> SockAddr
+setPort p (SockAddrInet  _ h)     = SockAddrInet  p h
+setPort p (SockAddrInet6 _ f h s) = SockAddrInet6 p f h s
+setPort _  addr = addr
+
+resolveURI :: URI -> IO SockAddr
+resolveURI URI { uriAuthority = Just (URIAuth {..}) } = do
+  infos <- getAddrInfo Nothing (Just uriRegName) Nothing
+  let port = fromMaybe 0 (readMaybe (L.drop 1 uriPort) :: Maybe Int)
+  case infos of
+    AddrInfo {..} : _ -> return $ setPort (fromIntegral port) addrAddress
+    _                 -> throwIO HostLookupFailed
+resolveURI _       = throwIO HostUnknown
+
+-- TODO caching?
+getTrackerAddr :: Manager -> URI -> IO SockAddr
+getTrackerAddr _ uri
+  | uriScheme uri == "udp:" = resolveURI uri
+  |        otherwise        = throwIO (UnrecognizedScheme (uriScheme uri))
+
+{-----------------------------------------------------------------------
+  Connection
+-----------------------------------------------------------------------}
+
+connectionLifetime :: NominalDiffTime
+connectionLifetime = 60
+
+data Connection = Connection
+  { connectionId        :: ConnectionId
+  , connectionTimestamp :: UTCTime
+  } deriving Show
+
+-- placeholder for the first 'connect'
+initialConnection :: Connection
+initialConnection = Connection initialConnectionId (posixSecondsToUTCTime 0)
+
+establishedConnection :: ConnectionId -> IO Connection
+establishedConnection cid = Connection cid <$> getCurrentTime
+
+isExpired :: Connection -> IO Bool
+isExpired Connection {..} = do
+  currentTime <- getCurrentTime
+  let timeDiff = diffUTCTime currentTime connectionTimestamp
+  return $ timeDiff > connectionLifetime
+
+{-----------------------------------------------------------------------
+--  Transactions
+-----------------------------------------------------------------------}
+
+-- | Sometimes 'genTransactionId' may return already used transaction
+-- id. We use a good entropy source but the issue /still/ (with very
+-- small probabality) may happen. If the collision happen then this
+-- function tries to find nearest unused slot, otherwise pending
+-- transactions table is full.
+firstUnused :: SockAddr -> TransactionId -> PendingQueries -> TransactionId
+firstUnused addr rid m = do
+  case M.splitLookup rid <$> M.lookup addr m of
+    Nothing                -> rid
+    Just (_ , Nothing, _ ) -> rid
+    Just (lt, Just _ , gt) ->
+      case backwardHole (keys lt) rid <|> forwardHole rid (keys gt) of
+        Nothing  -> error "firstUnused: table is full" -- impossible
+        Just tid -> tid
+  where
+    forwardHole a []
+      | a == maxBound = Nothing
+      |   otherwise   = Just (succ a)
+    forwardHole a (b : xs)
+      | succ a == b   = forwardHole b xs
+      |   otherwise   = Just (succ a)
+
+    backwardHole [] a
+      | a == minBound = Nothing
+      |   otherwise   = Just (pred a)
+    backwardHole (b : xs) a
+      | b == pred a   = backwardHole xs b
+      |   otherwise   = Just (pred a)
+
+register :: SockAddr -> TransactionId -> PendingResponse
+         -> PendingQueries -> PendingQueries
+register addr tid ares = M.alter insertId addr
+  where
+    insertId Nothing  = Just (M.singleton tid ares)
+    insertId (Just m) = Just (M.insert tid ares m)
+
+unregister :: SockAddr -> TransactionId
+           -> PendingQueries -> PendingQueries
+unregister addr tid = M.update deleteId addr
+  where
+    deleteId m
+      | M.null m' = Nothing
+      | otherwise = Just m'
+      where
+        m' = M.delete tid m
+
+-- | Generate a new unused transaction id and register as pending.
+allocTransaction :: Manager -> SockAddr -> PendingResponse -> IO TransactionId
+allocTransaction Manager {..} addr ares =
+  modifyMVar pendingResps $ \ m -> do
+    rndId <- genTransactionId
+    let tid = firstUnused addr rndId m
+    return (register addr tid ares m, tid)
+
+-- | Wake up blocked thread and return response back.
+commitTransaction :: Manager -> SockAddr -> TransactionId -> Response -> IO ()
+commitTransaction Manager {..} addr tid resp =
+  modifyMVarMasked_ pendingResps $ \ m -> do
+    case M.lookup tid =<< M.lookup addr m of
+      Nothing   -> return m -- tracker responded after 'cancelTransaction' fired
+      Just ares -> do
+        putMVar ares (Right resp)
+        return $ unregister addr tid m
+
+-- | Abort transaction forcefully.
+cancelTransaction :: Manager -> SockAddr -> TransactionId -> IO ()
+cancelTransaction Manager {..} addr tid =
+  modifyMVarMasked_ pendingResps $ \m ->
+    return $ unregister addr tid m
+
+-- | Handle responses from trackers.
+listen :: Manager -> IO ()
+listen mgr @ Manager {..} = do
+  forever $ do
+    (bs, addr) <- BS.recvFrom sock (optMaxPacketSize options)
+    case decode bs of
+      Left  _                   -> return () -- parser failed, ignoring
+      Right (TransactionR {..}) -> commitTransaction mgr addr transIdR response
+
+-- | Perform RPC transaction. If the action interrupted transaction
+-- will be aborted.
+transaction :: Manager -> SockAddr -> Connection -> Request -> IO Response
+transaction mgr @ Manager {..} addr conn request = do
+    ares <- newEmptyMVar
+    tid  <- allocTransaction mgr addr ares
+    performTransaction tid ares
+      `onException` cancelTransaction mgr addr tid
+  where
+    performTransaction tid ares = do
+      let trans = TransactionQ (connectionId conn) tid request
+      BS.sendAllTo sock (encode trans) addr
+      takeMVar ares >>= either throwIO return
+
+{-----------------------------------------------------------------------
+--  Connection cache
+-----------------------------------------------------------------------}
+
+connect :: Manager -> SockAddr -> Connection -> IO ConnectionId
+connect m addr conn = do
+  resp <- transaction m addr conn Connect
+  case resp of
+    Connected cid -> return cid
+    Failed    msg -> throwIO $ QueryFailed msg
+    _ -> throwIO $ UnexpectedResponse "connected" (responseName resp)
+
+newConnection :: Manager -> SockAddr -> IO Connection
+newConnection m addr = do
+  connId  <- connect m addr initialConnection
+  establishedConnection connId
+
+refreshConnection :: Manager -> SockAddr -> Connection -> IO Connection
+refreshConnection mgr addr conn = do
+  expired <- isExpired conn
+  if expired
+    then do
+      connId <- connect mgr addr conn
+      establishedConnection connId
+    else do
+      return conn
+
+withCache :: Manager -> SockAddr
+          -> (Maybe Connection -> IO Connection) -> IO Connection
+withCache mgr addr action = do
+  cache <- readIORef (connectionCache mgr)
+  conn  <- action (M.lookup addr cache)
+  writeIORef (connectionCache mgr) (M.insert addr conn cache)
+  return conn
+
+getConnection :: Manager -> SockAddr -> IO Connection
+getConnection mgr addr = withCache mgr addr $
+  maybe (newConnection mgr addr) (refreshConnection mgr addr)
+
+{-----------------------------------------------------------------------
+--  RPC
+-----------------------------------------------------------------------}
+
+retransmission :: Options -> IO a -> IO a
+retransmission Options {..} action = go optMinTimeout
+  where
+    go curTimeout
+      | curTimeout > optMaxTimeout = throwIO $ TimeoutExpired curTimeout
+      |         otherwise          = do
+        r <- timeout (curTimeout * sec) action
+        maybe (go (optMultiplier * curTimeout)) return r
+
+queryTracker :: Manager -> URI -> Request -> IO Response
+queryTracker mgr uri req = do
+  addr <- getTrackerAddr mgr uri
+  retransmission (options mgr) $ do
+    conn <- getConnection  mgr addr
+    transaction mgr addr conn req
+
+-- | This function can throw 'RpcException'.
+announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo
+announce mgr uri q = do
+  resp <- queryTracker mgr uri (Announce q)
+  case resp of
+    Announced info -> return info
+    _ -> throwIO $ UnexpectedResponse "announce" (responseName resp)
+
+-- | This function can throw 'RpcException'.
+scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo
+scrape mgr uri ihs = do
+  resp <- queryTracker mgr uri (Scrape ihs)
+  case resp of
+    Scraped info -> return $ L.zip ihs info
+    _ -> throwIO $ UnexpectedResponse "scrape" (responseName resp)
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs
new file mode 100644
index 00000000..aa4a832f
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs
@@ -0,0 +1,306 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2014
+--   License     :  BSD
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Multitracker sessions.
+--
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TemplateHaskell      #-}
+module Network.BitTorrent.Tracker.Session
+       ( -- * Session
+         Session
+       , Event (..)
+       , newSession
+       , closeSession
+       , withSession
+
+         -- * Client send notifications
+       , notify
+       , askPeers
+
+         -- * Session state
+         -- ** Status
+       , Status (..)
+       , getStatus
+
+         -- ** Single tracker sessions
+       , LastScrape (..)
+       , TrackerSession
+       , trackerPeers
+       , trackerScrape
+       , getSessionState
+
+         -- * Tracker Exchange
+         -- | BEP28: <http://www.bittorrent.org/beps/bep_0028.html>
+       , addTracker
+       , removeTracker
+       , getTrustedTrackers
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.Chan.Split as CS
+import Control.Monad
+import Data.Default
+import Data.Fixed
+import Data.Foldable as F
+import Data.IORef
+import Data.List as L
+import Data.Maybe
+import Data.Time
+import Data.Traversable
+import Network.URI
+
+import Data.Torrent
+import Network.Address
+import Network.BitTorrent.Internal.Cache
+import Network.BitTorrent.Internal.Types
+import Network.BitTorrent.Tracker.List as TL
+import Network.BitTorrent.Tracker.Message
+import Network.BitTorrent.Tracker.RPC as RPC
+
+{-----------------------------------------------------------------------
+--  Single tracker session
+-----------------------------------------------------------------------}
+
+-- | Status of this client.
+data Status
+  = Running -- ^ This client is announced and listenning for incoming
+            -- connections.
+  | Paused  -- ^ This client does not expecting incoming connections.
+    deriving (Show, Eq, Bounded, Enum)
+
+-- | Client starting in the paused state.
+instance Default Status where
+  def = Paused
+
+-- | Tracker session starts with scrape unknown.
+instance Default LastScrape where
+  def = LastScrape Nothing Nothing
+
+data LastScrape = LastScrape
+  { -- | Count of leechers the tracker aware of.
+    scrapeLeechers :: Maybe Int
+
+    -- | Count of seeders the tracker aware of.
+  , scrapeSeeders  :: Maybe Int
+  } deriving (Show, Eq)
+
+-- | Single tracker session.
+data TrackerSession = TrackerSession
+  { -- | Used to notify 'Stopped' and 'Completed' events.
+    statusSent    :: !(Maybe Status)
+
+    -- | Can be used to retrieve peer set.
+  , trackerPeers  :: Cached [PeerAddr IP]
+
+    -- | Can be used to show brief swarm stats in client GUI.
+  , trackerScrape :: Cached LastScrape
+  }
+
+-- | Not contacted.
+instance Default TrackerSession where
+  def = TrackerSession Nothing def def
+
+-- | Do we need to notify this /specific/ tracker?
+needNotify :: AnnounceEvent -> Maybe Status -> Maybe Bool
+needNotify Started    Nothing       = Just True
+needNotify Stopped    Nothing       = Just False
+needNotify Completed  Nothing       = Just False
+needNotify Started   (Just Running) = Nothing
+needNotify Stopped   (Just Running) = Just True
+needNotify Completed (Just Running) = Just True
+needNotify Started   (Just Paused ) = Just True
+needNotify Stopped   (Just Paused ) = Just False
+needNotify Completed (Just Paused ) = Just True
+
+-- | Client status after event announce succeed.
+nextStatus :: AnnounceEvent -> Maybe Status
+nextStatus Started   = Just Running
+nextStatus Stopped   = Just Paused
+nextStatus Completed = Nothing -- must keep previous status
+
+seconds :: Int -> NominalDiffTime
+seconds n = realToFrac (toEnum n :: Uni)
+
+cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr IP])
+cachePeers AnnounceInfo {..} =
+  newCached (seconds respInterval)
+            (seconds (fromMaybe respInterval respMinInterval))
+            (getPeerList respPeers)
+
+cacheScrape :: AnnounceInfo -> IO (Cached LastScrape)
+cacheScrape AnnounceInfo {..} =
+  newCached (seconds respInterval)
+            (seconds (fromMaybe respInterval respMinInterval))
+    LastScrape
+      { scrapeSeeders  = respComplete
+      , scrapeLeechers = respIncomplete
+      }
+
+-- | Make announce request to specific tracker returning new state.
+notifyTo :: Manager -> Session -> AnnounceEvent
+         -> TierEntry TrackerSession -> IO TrackerSession
+notifyTo mgr s @ Session {..} event (uri, entry @ TrackerSession {..}) = do
+  let shouldNotify = needNotify event statusSent
+  mustNotify <- maybe (isExpired trackerPeers) return shouldNotify
+  if not mustNotify
+    then return entry
+    else do
+      let q = SAnnounceQuery sessionTopic def Nothing (Just event)
+      res <- RPC.announce mgr uri q
+      when (statusSent == Nothing) $ do
+        send sessionEvents (TrackerConfirmed uri)
+      send sessionEvents (AnnouncedTo uri)
+      let status' = nextStatus event <|> statusSent
+      TrackerSession status' <$> cachePeers res <*> cacheScrape res
+
+{-----------------------------------------------------------------------
+--  Multitracker Session
+-----------------------------------------------------------------------}
+
+-- | Multitracker session.
+data Session = Session
+  { -- | Infohash to announce at each 'announce' request.
+    sessionTopic    :: !InfoHash
+
+    -- | Current status of this client is used to filter duplicated
+    -- notifications, for e.g. we don't want to notify a tracker with
+    -- ['Stopped', 'Stopped'], the last should be ignored.
+  , sessionStatus   :: !(IORef Status)
+
+    -- | A set of single-tracker sessions. Any request to a tracker
+    -- must take a lock.
+  , sessionTrackers :: !(MVar (TrackerList TrackerSession))
+
+  , sessionEvents   :: !(SendPort (Event Session))
+  }
+
+instance EventSource Session where
+  data Event Session
+    = TrackerAdded     URI
+    | TrackerConfirmed URI
+    | TrackerRemoved   URI
+    | AnnouncedTo      URI
+    | SessionClosed
+
+  listen Session {..} = CS.listen sessionEvents
+
+
+-- | Create a new multitracker session in paused state. Tracker list
+-- must contant only /trusted/ tracker uris. To start announcing
+-- client presence use 'notify'.
+newSession :: InfoHash -> TrackerList () -> IO Session
+newSession ih origUris = do
+  urisList    <- shuffleTiers origUris
+  statusRef   <- newIORef def
+  entriesVar  <- newMVar (fmap (const def) urisList)
+  eventStream <- newSendPort
+  return Session
+    { sessionTopic    = ih
+    , sessionStatus   = statusRef
+    , sessionTrackers = entriesVar
+    , sessionEvents   = eventStream
+    }
+
+-- | Release scarce resources associated with the given session. This
+-- function block until all trackers tied with this peer notified with
+-- 'Stopped' event.
+closeSession :: Manager -> Session -> IO ()
+closeSession m s @ Session {..} = do
+  notify m s Stopped
+  send sessionEvents SessionClosed
+
+{-----------------------------------------------------------------------
+--  Operations
+-----------------------------------------------------------------------}
+
+-- | Normally you need to use 'Control.Monad.Trans.Resource.alloc'.
+withSession :: Manager -> InfoHash -> TrackerList ()
+            -> (Session -> IO ()) -> IO ()
+withSession m ih uris = bracket (newSession ih uris) (closeSession m)
+
+-- | Get last announced status. The only action can alter this status
+-- is 'notify'.
+getStatus :: Session -> IO Status
+getStatus Session {..} = readIORef sessionStatus
+
+getSessionState :: Session -> IO [[TierEntry TrackerSession]]
+getSessionState Session {..} = TL.toList <$> readMVar sessionTrackers
+
+-- | Do we need to sent this event to a first working tracker or to
+-- the all known good trackers?
+allNotify :: AnnounceEvent -> Bool
+allNotify Started   = False
+allNotify Stopped   = True
+allNotify Completed = True
+
+notifyAll :: Manager -> Session -> AnnounceEvent -> IO ()
+notifyAll mgr s @ Session {..} event = do
+    modifyMVar_ sessionTrackers $
+      (traversal (notifyTo mgr s event))
+  where
+    traversal
+      | allNotify event = traverseAll
+      |    otherwise    = traverseTiers
+
+-- TODO send notifications to tracker periodically.
+-- |
+--
+-- This function /may/ block until tracker query proceed.
+notify :: Manager -> Session -> AnnounceEvent -> IO ()
+notify mgr ses event = do
+  prevStatus <- atomicModifyIORef (sessionStatus ses) $ \ s ->
+                  (fromMaybe s (nextStatus event), s)
+  when (needNotify event (Just prevStatus) == Just True) $ do
+    notifyAll mgr ses event
+
+-- TODO run announce if sesion have no peers
+-- | The returned list of peers can have duplicates.
+--   This function /may/ block. Use async if needed.
+askPeers :: Manager -> Session -> IO [PeerAddr IP]
+askPeers _mgr ses = do
+  list    <- readMVar (sessionTrackers ses)
+  L.concat <$> collect (tryTakeData . trackerPeers) list
+
+collect :: (a -> IO (Maybe b)) -> TrackerList a -> IO [b]
+collect f lst = (catMaybes . F.toList) <$> traverse f lst
+
+--sourcePeers :: Session -> Source (PeerAddr IP)
+--sourcePeers
+
+{-----------------------------------------------------------------------
+--  Tracker exchange
+-----------------------------------------------------------------------}
+
+-- Trackers discovered through this protocol SHOULD be treated with a
+-- certain amount of suspicion. Since the source of a tracker exchange
+-- message cannot be trusted, an implementation SHOULD have a lower
+-- number of retries before giving up entirely.
+
+addTracker :: Session -> URI -> IO ()
+addTracker Session {..} uri = do
+  undefined
+  send sessionEvents (TrackerAdded uri)
+
+removeTracker :: Manager -> Session -> URI -> IO ()
+removeTracker m Session {..} uri = do
+  send sessionEvents (TrackerRemoved uri)
+
+-- Also, as specified under the definitions section, a tracker that
+-- has not worked should never be propagated to other peers over the
+-- tracker exchange protocol.
+
+-- | Return all known trackers.
+getTrackers :: Session -> IO [URI]
+getTrackers = undefined
+
+-- | Return trackers from torrent file and
+getTrustedTrackers :: Session -> IO [URI]
+getTrustedTrackers = undefined
diff --git a/bittorrent/src/System/Torrent/FileMap.hs b/bittorrent/src/System/Torrent/FileMap.hs
new file mode 100644
index 00000000..6e8d7f5a
--- /dev/null
+++ b/bittorrent/src/System/Torrent/FileMap.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE ViewPatterns     #-}
+{-# OPTIONS -fno-warn-orphans #-}
+module System.Torrent.FileMap
+       ( FileMap
+
+         -- * Construction
+       , Mode (..)
+       , def
+       , mmapFiles
+       , unmapFiles
+
+         -- * Query
+       , System.Torrent.FileMap.size
+
+         -- * Modification
+       , readBytes
+       , writeBytes
+       , unsafeReadBytes
+
+         -- * Unsafe conversions
+       , fromLazyByteString
+       , toLazyByteString
+       ) where
+
+import Control.Applicative
+import Control.Monad as L
+import Data.ByteString as BS
+import Data.ByteString.Internal as BS
+import Data.ByteString.Lazy as BL
+import Data.ByteString.Lazy.Internal as BL
+import Data.Default
+import Data.Vector as V -- TODO use unboxed vector
+import Foreign
+import System.IO.MMap
+
+import Data.Torrent
+
+
+data FileEntry = FileEntry
+  { filePosition :: {-# UNPACK #-} !FileOffset
+  , fileBytes    :: {-# UNPACK #-} !BS.ByteString
+  } deriving (Show, Eq)
+
+type FileMap = Vector FileEntry
+
+instance Default Mode where
+  def = ReadWriteEx
+
+mmapFiles :: Mode -> FileLayout FileSize -> IO FileMap
+mmapFiles mode layout = V.fromList <$> L.mapM mkEntry (accumPositions layout)
+  where
+    mkEntry (path, (pos, expectedSize)) = do
+      let esize = fromIntegral expectedSize -- FIXME does this safe?
+      (fptr, moff, msize) <- mmapFileForeignPtr path mode $ Just (0, esize)
+      if msize /= esize
+        then error "mmapFiles" -- TODO unmap mapped files on exception
+        else return $ FileEntry pos (PS fptr moff msize)
+
+unmapFiles :: FileMap -> IO ()
+unmapFiles = V.mapM_ unmapEntry
+  where
+    unmapEntry (FileEntry _ (PS fptr _ _)) = finalizeForeignPtr fptr
+
+fromLazyByteString :: BL.ByteString -> FileMap
+fromLazyByteString lbs = V.unfoldr f (0, lbs)
+  where
+    f (_,   Empty     ) = Nothing
+    f (pos, Chunk x xs) = Just (FileEntry pos x, ((pos + chunkSize), xs))
+      where chunkSize = fromIntegral $ BS.length x
+
+-- | /O(n)/.
+toLazyByteString :: FileMap -> BL.ByteString
+toLazyByteString = V.foldr f Empty
+  where
+    f FileEntry {..} bs = Chunk fileBytes bs
+
+-- | /O(1)/.
+size :: FileMap -> FileOffset
+size m
+  |           V.null m               = 0
+  | FileEntry {..} <- V.unsafeLast m
+  = filePosition + fromIntegral (BS.length fileBytes)
+
+bsearch :: FileOffset -> FileMap -> Maybe Int
+bsearch x m
+  | V.null m  = Nothing
+  | otherwise = branch (V.length m `div` 2)
+  where
+    branch c @ ((m !) -> FileEntry {..})
+      | x <  filePosition            = bsearch x (V.take c m)
+      | x >= filePosition + fileSize = do
+        ix <- bsearch x (V.drop (succ c) m)
+        return $ succ c + ix
+      |          otherwise           = Just c
+      where
+        fileSize = fromIntegral (BS.length fileBytes)
+
+-- | /O(log n)/.
+drop :: FileOffset -> FileMap -> (FileSize, FileMap)
+drop off m
+  | Just ix <- bsearch off m
+  , FileEntry {..} <- m ! ix = (off - filePosition, V.drop ix m)
+  |         otherwise        = (0                 , V.empty)
+
+-- | /O(log n)/.
+take :: FileSize -> FileMap -> (FileMap, FileSize)
+take len m
+  |           len >= s       = (m                 , 0)
+  | Just ix <- bsearch (pred len) m = let m' = V.take (succ ix) m
+                               in (m', System.Torrent.FileMap.size m' - len)
+  |          otherwise       = (V.empty           , 0)
+  where
+    s =  System.Torrent.FileMap.size m
+
+-- | /O(log n + m)/. Do not use this function with 'unmapFiles'.
+unsafeReadBytes :: FileOffset -> FileSize -> FileMap -> BL.ByteString
+unsafeReadBytes off s m
+  | (l  , m') <- System.Torrent.FileMap.drop off     m
+  , (m'', _ ) <- System.Torrent.FileMap.take (off + s) m'
+  = BL.take (fromIntegral s) $ BL.drop (fromIntegral l) $ toLazyByteString m''
+
+readBytes :: FileOffset -> FileSize -> FileMap -> IO BL.ByteString
+readBytes off s m = do
+    let bs_copy = BL.copy $ unsafeReadBytes off s m
+    forceLBS bs_copy
+    return bs_copy
+  where
+    forceLBS  Empty      = return ()
+    forceLBS (Chunk _ x) = forceLBS x
+
+bscpy :: BL.ByteString -> BL.ByteString -> IO ()
+bscpy (PS _ _ 0 `Chunk` dest_rest) src                         = bscpy dest_rest src
+bscpy dest                         (PS _ _ 0 `Chunk` src_rest) = bscpy dest      src_rest
+bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest)
+      (PS src_fptr  src_off  src_size  `Chunk` src_rest)
+  = do let csize = min dest_size src_size
+       withForeignPtr dest_fptr $ \dest_ptr ->
+         withForeignPtr src_fptr $ \src_ptr ->
+           memcpy (dest_ptr `advancePtr` dest_off)
+                  (src_ptr  `advancePtr` src_off)
+                  (fromIntegral csize) -- TODO memmove?
+       bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest)
+             (PS src_fptr  (src_off  + csize) (src_size  - csize) `Chunk` src_rest)
+bscpy _ _ = return ()
+
+writeBytes :: FileOffset -> BL.ByteString -> FileMap -> IO ()
+writeBytes off lbs m = bscpy dest src
+  where
+    src  = BL.take (fromIntegral (BL.length dest)) lbs
+    dest = unsafeReadBytes off (fromIntegral (BL.length lbs)) m
\ No newline at end of file
diff --git a/bittorrent/src/System/Torrent/Storage.hs b/bittorrent/src/System/Torrent/Storage.hs
new file mode 100644
index 00000000..1d77e55d
--- /dev/null
+++ b/bittorrent/src/System/Torrent/Storage.hs
@@ -0,0 +1,221 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   This module implements mapping from single continious piece space
+--   to file storage. Storage can be used in two modes:
+--
+--     * As in memory storage - in this case we don't touch filesystem.
+--
+--     * As ordinary mmaped file storage - when we need to store
+--       data in the filesystem.
+--
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+module System.Torrent.Storage
+       ( -- * Storage
+         Storage
+       , StorageFailure (..)
+
+         -- * Construction
+       , Mode (..)
+       , def
+       , open
+       , openInfoDict
+       , close
+       , withStorage
+
+         -- * Query
+       , totalPieces
+       , verifyPiece
+       , genPieceInfo
+       , getBitfield
+
+         -- * Modification
+       , writePiece
+       , readPiece
+       , hintRead
+       , unsafeReadPiece
+
+         -- * Streaming
+       , sourceStorage
+       , sinkStorage
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad as M
+import Control.Monad.Trans
+import Data.ByteString.Lazy as BL
+import Data.Conduit as C
+import Data.Conduit.Binary as C
+import Data.Conduit.List as C
+import Data.Typeable
+
+import Data.Torrent
+import Network.BitTorrent.Exchange.Bitfield as BF
+import System.Torrent.FileMap as FM
+
+
+-- | Some storage operations may throw an exception if misused.
+data StorageFailure
+    -- | Occurs on a write operation if the storage has been opened
+    --   using 'ReadOnly' mode.
+  = StorageIsRO
+
+    -- | Piece index is out of bounds.
+  | InvalidIndex PieceIx
+
+    -- | Piece size do not match with one passed to the 'open'
+    -- function.
+  | InvalidSize  PieceSize
+    deriving (Show, Eq, Typeable)
+
+instance Exception StorageFailure
+
+-- | Pieces store.
+data Storage = Storage
+  { mode     ::                !Mode
+  , pieceLen :: {-# UNPACK #-} !PieceSize
+  , fileMap  :: {-# UNPACK #-} !FileMap
+  }
+
+-- | Map torrent files:
+--
+--   * when torrent first created use 'ReadWriteEx' mode;
+--
+--   * when seeding, validation 'ReadOnly' mode.
+--
+open :: Mode -> PieceSize -> FileLayout FileSize -> IO Storage
+open mode s l
+  |   s <= 0  = throwIO (InvalidSize s)
+  | otherwise = Storage mode s <$> mmapFiles mode l
+
+-- | Like 'open', but use 'InfoDict' file layout.
+openInfoDict :: Mode -> FilePath -> InfoDict -> IO Storage
+openInfoDict mode rootPath InfoDict {..} =
+  open mode (piPieceLength idPieceInfo) (flatLayout rootPath idLayoutInfo)
+
+-- | Unmaps all files forcefully. It is recommended but not required.
+close :: Storage -> IO ()
+close Storage {..} = unmapFiles fileMap
+
+-- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'.
+withStorage :: Mode -> PieceSize -> FileLayout FileSize
+            -> (Storage -> IO ()) -> IO ()
+withStorage m s l = bracket (open m s l) close
+
+-- TODO allocateStorage?
+
+-- | Count of pieces in the storage.
+totalPieces :: Storage -> PieceCount
+totalPieces Storage {..} = FM.size fileMap `sizeInBase` pieceLen
+
+isValidIx :: PieceIx -> Storage -> Bool
+isValidIx i s = 0 <= i && i < totalPieces s
+
+-- | Put piece data at the piece index by overwriting existing
+-- data.
+--
+--   This operation may throw 'StorageFailure'.
+--
+writePiece :: Piece BL.ByteString -> Storage -> IO ()
+writePiece p @ Piece {..} s @ Storage {..}
+  |       mode == ReadOnly    = throwIO  StorageIsRO
+  | isNotValidIx   pieceIndex = throwIO (InvalidIndex pieceIndex)
+  | isNotValidSize pieceIndex (pieceSize p)
+                              = throwIO (InvalidSize  (pieceSize p))
+  |          otherwise        = writeBytes offset pieceData fileMap
+  where
+    isNotValidSize pix psize
+      | succ pix == pcount = psize /= lastPieceLen -- last piece may be shorter
+      |      otherwise     = psize /= pieceLen
+      where
+        lastPieceLen = fromIntegral (FM.size fileMap `rem` fromIntegral pieceLen)
+    {-# INLINE isNotValidSize #-}
+
+    isNotValidIx i = i < 0 || i >= pcount
+    {-# INLINE isNotValidIx #-}
+
+    pcount = totalPieces s
+    offset = fromIntegral pieceIndex * fromIntegral pieceLen
+
+-- | Read specific piece from storage.
+--
+--   This operation may throw 'StorageFailure'.
+--
+readPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString)
+readPiece pix s @ Storage {..}
+  | not (isValidIx pix s) = throwIO (InvalidIndex pix)
+  | otherwise = Piece pix <$> readBytes offset sz fileMap
+  where
+    offset = fromIntegral pix * fromIntegral pieceLen
+    sz     = fromIntegral pieceLen
+
+-- | Hint about the coming 'readPiece'. Ignores invalid indexes, for e.g.:
+--
+--   @forall s. hindRead (-1) s == return ()@
+--
+hintRead :: PieceIx -> Storage -> IO ()
+hintRead _pix Storage {..} = return ()
+
+-- | Zero-copy version of readPiece. Can be used only with 'ReadOnly'
+-- storages.
+unsafeReadPiece :: PieceIx -> Storage -> IO (Piece BL.ByteString)
+unsafeReadPiece pix s @ Storage {..}
+  | not (isValidIx pix s) = throwIO (InvalidIndex pix)
+  | otherwise = return $ Piece pix (unsafeReadBytes offset sz fileMap)
+  where
+    offset = fromIntegral pix * fromIntegral pieceLen
+    sz     = fromIntegral pieceLen
+
+-- | Stream storage pieces from first to the last.
+sourceStorage :: Storage -> Source IO (Piece BL.ByteString)
+sourceStorage s = go 0
+  where
+    go pix
+        | pix < totalPieces s = do
+          piece <- liftIO $ readPiece pix s
+          liftIO $ hintRead (succ pix) s
+          yield piece
+          go (succ pix)
+        |       otherwise     = return ()
+
+-- | Write stream of pieces to the storage. Fail if storage is 'ReadOnly'.
+sinkStorage :: Storage -> Sink (Piece BL.ByteString) IO ()
+sinkStorage s = do
+  awaitForever $ \ piece ->
+    liftIO $ writePiece piece s
+
+-- | This function can be used to generate 'InfoDict' from a set of
+-- opened files.
+genPieceInfo :: Storage -> IO PieceInfo
+genPieceInfo s = do
+  hashes <- sourceStorage s $= C.map hashPiece $$ C.sinkLbs
+  return $ PieceInfo (pieceLen s) (HashList (BL.toStrict hashes))
+
+-- | Verify specific piece using infodict hash list.
+verifyPiece :: Storage -> PieceInfo -> PieceIx -> IO Bool
+verifyPiece s pinfo pix = do
+  piece <- unsafeReadPiece pix s
+  return $! checkPieceLazy pinfo piece
+
+-- | Verify storage.
+--
+--   Throws 'InvalidSize' if piece info size do not match with storage
+--   piece size.
+--
+getBitfield :: Storage -> PieceInfo -> IO Bitfield
+getBitfield s @ Storage {..} pinfo @ PieceInfo {..}
+  | pieceLen /= piPieceLength = throwIO (InvalidSize piPieceLength)
+  | otherwise = M.foldM checkPiece (BF.haveNone total) [0..total - 1]
+  where
+    total = totalPieces s
+
+    checkPiece :: Bitfield -> PieceIx -> IO Bitfield
+    checkPiece bf pix = do
+      valid <- verifyPiece s pinfo pix
+      return $ if valid then BF.insert pix bf else bf
diff --git a/bittorrent/src/System/Torrent/Tree.hs b/bittorrent/src/System/Torrent/Tree.hs
new file mode 100644
index 00000000..41cfb360
--- /dev/null
+++ b/bittorrent/src/System/Torrent/Tree.hs
@@ -0,0 +1,83 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Directory tree can be used to easily manipulate file layout info.
+--
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module System.Torrent.Tree
+       ( -- * Directory tree
+         DirTree (..)
+
+         -- * Construction
+       , build
+
+         -- * Query
+       , System.Torrent.Tree.lookup
+       , lookupDir
+       , fileNumber
+       , dirNumber
+       ) where
+
+import Data.ByteString as BS
+import Data.ByteString.Char8 as BC
+import Data.Foldable
+import Data.List as L
+import Data.Map  as M
+import Data.Monoid
+
+import Data.Torrent
+
+
+-- | 'DirTree' is more convenient form of 'LayoutInfo'.
+data DirTree a = Dir  { children :: Map ByteString (DirTree a) }
+               | File { node     :: FileInfo a                 }
+                 deriving Show
+
+-- | Build directory tree from a list of files.
+build :: LayoutInfo -> DirTree ()
+build SingleFile {liFile = FileInfo {..}} = Dir
+    { children = M.singleton fiName (File fi) }
+  where
+    fi = FileInfo fiLength fiMD5Sum ()
+build MultiFile {..} = Dir $ M.singleton liDirName files
+  where
+    files = Dir $ M.fromList $ L.map mkFileEntry liFiles
+    mkFileEntry FileInfo {..} = (L.head fiName, ent) -- TODO FIXME
+      where
+        ent = File $ FileInfo fiLength fiMD5Sum ()
+
+--decompress :: DirTree () -> [FileInfo ()]
+--decompress = undefined
+
+-- TODO pretty print
+
+-- | Lookup file by path.
+lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a)
+lookup []        t      = Just t
+lookup (p : ps) (Dir m) | Just subTree <- M.lookup (BC.pack p) m
+                        = System.Torrent.Tree.lookup ps subTree
+lookup _         _      = Nothing
+
+-- | Lookup directory by path.
+lookupDir :: [FilePath] -> DirTree a -> Maybe [(ByteString, DirTree a)]
+lookupDir ps d = do
+  subTree <- System.Torrent.Tree.lookup ps d
+  case subTree of
+    File _  -> Nothing
+    Dir  es -> Just $ M.toList es
+
+-- | Get total count of files in directory and subdirectories.
+fileNumber :: DirTree a -> Sum Int
+fileNumber File {..} = Sum 1
+fileNumber Dir  {..} = foldMap fileNumber children
+
+-- | Get total count of directories in the directory and subdirectories.
+dirNumber :: DirTree a -> Sum Int
+dirNumber File {..} = Sum 0
+dirNumber Dir  {..} = Sum 1 <> foldMap dirNumber children
diff --git a/bittorrent/tests/Config.hs b/bittorrent/tests/Config.hs
new file mode 100644
index 00000000..55e30867
--- /dev/null
+++ b/bittorrent/tests/Config.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE RecordWildCards #-}
+module Config
+       ( -- * Types
+         ClientName
+       , ClientOpts (..)
+       , EnvOpts (..)
+
+         -- * For test suite driver
+       , getOpts
+
+         -- * For item specs
+       , getEnvOpts
+       , getThisOpts
+       , getMyAddr
+
+       , getRemoteOpts
+       , withRemote
+       , withRemoteAddr
+
+       , getTestTorrent
+       ) where
+
+import Control.Monad
+import Network
+import Data.Default
+import Data.IORef
+import Data.List as L
+import Data.Maybe
+import Options.Applicative
+import System.Exit
+import System.Environment
+import System.IO.Unsafe
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Address (IP, PeerAddr (PeerAddr), genPeerId)
+
+
+type ClientName = String
+
+
+#if !MIN_VERSION_network(2,6,3)
+instance Read PortNumber where
+  readsPrec = error "readsPrec"
+#endif
+
+data ClientOpts = ClientOpts
+  { peerPort   :: PortNumber  -- tcp port
+  , nodePort   :: PortNumber  -- udp port
+  }
+
+instance Default ClientOpts where
+  def = ClientOpts
+    { peerPort = 6881
+    , nodePort = 6881
+    }
+
+defRemoteOpts :: ClientOpts
+defRemoteOpts = def
+
+defThisOpts :: ClientOpts
+defThisOpts = def
+  { peerPort = 6882
+  , nodePort = 6882
+  }
+
+clientOptsParser :: Parser ClientOpts
+clientOptsParser = ClientOpts
+  <$> option auto
+    ( long    "peer-port"  <> short 'p'
+   <> value   6881         <> showDefault
+   <> metavar "NUM"
+   <> help    "port to bind the specified bittorrent client"
+    )
+  <*> option auto
+    ( long    "node-port"  <> short 'n'
+   <> value   6881         <> showDefault
+   <> metavar "NUM"
+   <> help    "port to bind node of the specified client"
+    )
+
+data EnvOpts = EnvOpts
+  { testClient   :: Maybe ClientName
+  , testTorrents :: [FilePath]
+  , remoteOpts   :: ClientOpts
+  , thisOpts     :: ClientOpts
+  }
+
+instance Default EnvOpts where
+  def = EnvOpts
+    { testClient   = Just "rtorrent"
+    , testTorrents = ["testfile.torrent"]
+    , remoteOpts   = defRemoteOpts
+    , thisOpts     = defThisOpts
+    }
+
+findConflicts :: EnvOpts -> [String]
+findConflicts EnvOpts {..}
+  | isNothing testClient = []
+  | peerPort remoteOpts == peerPort thisOpts = ["Peer port the same"]
+  | nodePort remoteOpts == nodePort thisOpts = ["Node port the same"]
+  |         otherwise        = []
+
+
+envOptsParser :: Parser EnvOpts
+envOptsParser = EnvOpts
+  <$> optional (strOption
+    ( long    "bittorrent-client"
+   <> metavar "CLIENT"
+   <> help    "torrent client to run"
+    ))
+  <*> pure []
+  <*> clientOptsParser
+  <*> clientOptsParser
+
+envOptsInfo :: ParserInfo EnvOpts
+envOptsInfo = info (helper <*> envOptsParser)
+   ( fullDesc
+  <> progDesc "The bittorrent library testsuite"
+  <> header   ""
+   )
+
+-- do not modify this while test suite is running because spec items
+-- can run in parallel
+envOptsRef :: IORef EnvOpts
+envOptsRef = unsafePerformIO (newIORef def)
+
+-- | Should be used from spec items.
+getEnvOpts :: IO EnvOpts
+getEnvOpts = readIORef envOptsRef
+
+getThisOpts :: IO ClientOpts
+getThisOpts = thisOpts <$> getEnvOpts
+
+-- | Return 'Nothing' if remote client is not running.
+getRemoteOpts :: IO (Maybe ClientOpts)
+getRemoteOpts = do
+  EnvOpts {..} <- getEnvOpts
+  return $ const remoteOpts <$> testClient
+
+withRemote :: (ClientOpts -> Expectation) -> Expectation
+withRemote action = do
+  mopts <- getRemoteOpts
+  case mopts of
+    Nothing   -> pendingWith "Remote client isn't running"
+    Just opts -> action opts
+
+withRemoteAddr :: (PeerAddr IP -> Expectation) -> Expectation
+withRemoteAddr action = do
+  withRemote $ \ ClientOpts {..} ->
+    action (PeerAddr Nothing "0.0.0.0" peerPort)
+
+getMyAddr :: IO (PeerAddr (Maybe IP))
+getMyAddr = do
+  ClientOpts {..} <- getThisOpts
+  pid <- genPeerId
+  return $ PeerAddr (Just pid) Nothing peerPort
+
+getTestTorrent :: IO Torrent
+getTestTorrent = do
+  EnvOpts {..} <- getEnvOpts
+  if L.null testTorrents
+    then error "getTestTorrent"
+    else fromFile ("res/" ++ L.head testTorrents)
+
+-- TODO fix EnvOpts parsing
+
+-- | Should be used by test suite driver.
+getOpts :: IO (EnvOpts, [String])
+getOpts = do
+  args <- getArgs
+--  case runParser SkipOpts envOptsParser args) (prefs idm) of
+  case (Right (def, args), ()) of
+    (Left   err                , _ctx) -> exitFailure
+    (Right (envOpts, hspecOpts), _ctx) -> do
+      let conflicts = findConflicts envOpts
+      unless (L.null conflicts) $ do
+        forM_ conflicts putStrLn
+        exitFailure
+
+      writeIORef envOptsRef envOpts
+      return (envOpts, hspecOpts)
diff --git a/bittorrent/tests/Data/TorrentSpec.hs b/bittorrent/tests/Data/TorrentSpec.hs
new file mode 100644
index 00000000..b4a280e4
--- /dev/null
+++ b/bittorrent/tests/Data/TorrentSpec.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Data.TorrentSpec (spec) where
+import Control.Applicative
+import Data.BEncode
+import Data.ByteString as BS
+import Data.ByteString.Lazy as BL
+import Data.Convertible
+import Data.Maybe
+import Data.Monoid
+import Data.Time
+import Network.URI
+import System.FilePath
+import System.Posix.Types
+import Test.Hspec
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
+
+import Data.Torrent
+import Network.BitTorrent.CoreSpec ()
+
+
+pico :: Gen (Maybe NominalDiffTime)
+pico = oneof
+  [ pure Nothing
+  , (Just . fromIntegral) <$> (arbitrary :: Gen Int)
+  ]
+
+instance Arbitrary COff where
+  arbitrary = fromIntegral <$> (arbitrary :: Gen Int)
+
+instance Arbitrary URIAuth where
+  arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary URI where
+  arbitrary
+    = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123"
+
+instance Arbitrary InfoHash where
+  arbitrary = do
+    bs <- BS.pack <$> vectorOf 20 arbitrary
+    pure $ either (const (error "arbitrary infohash")) id $ safeConvert bs
+
+instance Arbitrary a => Arbitrary (FileInfo a) where
+  arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary LayoutInfo where
+  arbitrary = oneof
+    [ SingleFile <$> arbitrary
+    , MultiFile  <$> arbitrary <*> arbitrary
+    ]
+
+instance Arbitrary a => Arbitrary (Piece a) where
+  arbitrary = Piece <$> arbitrary <*> arbitrary
+
+instance Arbitrary HashList where
+  arbitrary = HashList <$> arbitrary
+
+instance Arbitrary PieceInfo where
+  arbitrary = PieceInfo <$> arbitrary <*> arbitrary
+
+instance Arbitrary InfoDict where
+  arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary Torrent where
+  arbitrary = Torrent <$> arbitrary
+                 <*> arbitrary <*> arbitrary    <*> arbitrary
+                 <*> pico      <*> arbitrary    <*> arbitrary
+                 <*> arbitrary
+                 <*> arbitrary <*> pure Nothing <*> arbitrary
+
+instance Arbitrary Magnet where
+  arbitrary = Magnet <$> arbitrary <*> arbitrary
+    <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    <*> arbitrary <*> arbitrary <*> pure mempty
+
+type TestPair = (FilePath, String)
+
+-- TODO add a few more torrents here
+torrentList :: [TestPair]
+torrentList =
+  [ ( "res" </> "dapper-dvd-amd64.iso.torrent"
+    , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf")
+  ]
+
+infohashSpec :: (FilePath, String) -> Spec
+infohashSpec (filepath, expectedHash) = do
+  it ("should match " ++ filepath) $ do
+    torrent    <- fromFile filepath
+    let actualHash = show $ idInfoHash $ tInfoDict torrent
+    actualHash `shouldBe` expectedHash
+
+magnetEncoding :: Magnet -> IO ()
+magnetEncoding m = parseMagnet (renderMagnet m) `shouldBe` Just m
+
+data T a = T
+
+prop_properBEncode :: Show a => BEncode a => Eq a
+                   => T a -> a -> IO ()
+prop_properBEncode _ expected = actual `shouldBe` Right expected
+  where
+    actual = decode $ BL.toStrict $ encode expected
+
+spec :: Spec
+spec = do
+  describe "info hash" $ do
+    mapM_ infohashSpec torrentList
+
+  describe "accumPosition" $ do
+    it "" $ property $ \ p1 p2 p3 s1 s2 s3 ->
+      accumPositions [(p1, s1), (p2, s2), (p3, s3)]
+        `shouldBe`   [(p1, (0, s1)), (p2, (s1, s2)), (p3, (s1 + s2, s3))]
+
+  describe "FileInfo" $ do
+    it "properly bencoded" $ property $
+      prop_properBEncode (T :: T (FileInfo BS.ByteString))
+
+  describe "LayoutInfo" $ do
+    it "properly bencoded" $ property $
+      prop_properBEncode (T :: T LayoutInfo)
+
+  describe "Torrent" $ do
+    it "property bencoded" $ property $
+      prop_properBEncode (T :: T Torrent)
+
+  describe "Magnet" $ do
+    it "properly encoded" $ property $ magnetEncoding
+
+    it "parse base32" $ do
+      let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6"
+      let ih = "CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6"
+      parseMagnet magnet `shouldBe` Just (nullMagnet ih)
+
+    it "parse base16" $ do
+      let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567"
+      let ih = "0123456789abcdef0123456789abcdef01234567"
+      parseMagnet magnet `shouldBe` Just (nullMagnet ih)
diff --git a/bittorrent/tests/Main.hs b/bittorrent/tests/Main.hs
new file mode 100644
index 00000000..5ed953da
--- /dev/null
+++ b/bittorrent/tests/Main.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE RecordWildCards #-}
+module Main where
+import Control.Exception
+import Control.Monad
+import Data.Functor
+import Data.Maybe
+import System.Directory
+import System.Exit
+import System.Environment
+import System.FilePath
+import System.Process
+import Text.Printf
+import Test.Hspec
+
+import Config
+import qualified Spec as Generated
+
+
+type Command = String
+type Descr = (ClientName, ClientOpts -> FilePath -> Command)
+
+torrents :: [FilePath]
+torrents =
+    [ "dapper-dvd-amd64-iso.torrent"
+    , "pkg.torrent"
+    , "testfile.torrent"
+    ]
+
+rtorrentSessionDir :: String
+rtorrentSessionDir = "rtorrent-sessiondir"
+
+sessionName :: String -- screen session name
+sessionName = "bittorrent-testsuite"
+
+tmpDir :: FilePath
+tmpDir = "res"
+
+clients :: [Descr]
+clients =
+  [ ("rtorrent"
+    , \ ClientOpts {..} tfile -> printf
+     "rtorrent -p %i-%i -O dht=on -O dht_port=%i -O session=%s %s"
+     (fromEnum peerPort) (fromEnum peerPort) (fromEnum nodePort)
+      rtorrentSessionDir tfile
+    )
+  ]
+
+setupEnv :: EnvOpts -> IO (Maybe ())
+setupEnv EnvOpts {..}
+  | Just client <- testClient
+  , Just mkCmd  <- lookup client clients = do
+    _ <- printf "Setting up %s\n" client
+
+    let torrentPath = "testfile.torrent"
+    let runner = printf "screen -dm -S %s %s" sessionName
+                 (mkCmd remoteOpts torrentPath)
+
+    wd <- getCurrentDirectory
+    createDirectoryIfMissing True (wd </> tmpDir </> rtorrentSessionDir)
+    _ <- createProcess (shell runner) { cwd = Just (wd </> tmpDir) }
+
+    return (Just ())
+
+  | Just client <- testClient = do
+    _ <- printf "Bad client `%s`, use one of %s\n" client (show (fst <$> clients))
+    return Nothing
+
+  | otherwise = do
+    _ <- printf "Running without remote client\n"
+    return (Just ())
+
+terminateEnv :: IO ()
+terminateEnv = do
+  wd <- getCurrentDirectory
+  removeDirectoryRecursive (wd </> tmpDir </> rtorrentSessionDir)
+  _ <- printf "closing screen session: %s\n" sessionName
+  _ <- system (printf "screen -S %s -X quit" sessionName)
+  return ()
+
+runTestSuite :: [String] -> IO ExitCode
+runTestSuite args = do
+  _ <- printf "running hspec test suite with args: %s\n" (show args)
+  catch (withArgs args (hspec Generated.spec) >> return ExitSuccess) return
+
+withEnv :: EnvOpts -> IO a -> IO a
+withEnv opts action = bracket (setupEnv opts) terminate (const action)
+  where
+    terminate running = do
+      when (isJust running) $ do
+        terminateEnv
+
+main :: IO ()
+main = do
+  (envOpts, suiteArgs) <- getOpts
+  withEnv envOpts $ do
+    code    <- runTestSuite suiteArgs
+    exitWith code
diff --git a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
new file mode 100644
index 00000000..d51bab02
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
@@ -0,0 +1,19 @@
+module Network.BitTorrent.Client.HandleSpec (spec) where
+import Data.Default
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Client
+import Network.BitTorrent.Client.Handle
+
+data_dir :: FilePath
+data_dir = "data"
+
+spec :: Spec
+spec = do
+  describe "openMagnet" $ do
+    it "should add new infohash to index" $ do
+      simpleClient $ do
+        _ <- openMagnet data_dir (nullMagnet def)
+        _ <- getHandle def
+        return ()
diff --git a/bittorrent/tests/Network/BitTorrent/CoreSpec.hs b/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
new file mode 100644
index 00000000..5bf900b2
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
@@ -0,0 +1,305 @@
+{-# LANGUAGE FlexibleInstances    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.CoreSpec (spec) where
+import Control.Applicative
+import Data.BEncode as BE
+import Data.ByteString.Lazy as BL
+import Data.IP
+import Data.Serialize as S
+import Data.String
+import Data.Text.Encoding as T
+import Data.Word
+import Network
+import Test.Hspec
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
+
+import Network.BitTorrent.Address
+
+
+instance Arbitrary IPv4 where
+  arbitrary = do
+    a <- choose (0, 255)
+    b <- choose (0, 255)
+    c <- choose (0, 255)
+    d <- choose (0, 255)
+    return $ toIPv4 [a, b, c, d]
+
+instance Arbitrary IPv6 where
+  arbitrary = do
+    a <- choose (0, fromIntegral (maxBound :: Word16))
+    b <- choose (0, fromIntegral (maxBound :: Word16))
+    c <- choose (0, fromIntegral (maxBound :: Word16))
+    d <- choose (0, fromIntegral (maxBound :: Word16))
+    e <- choose (0, fromIntegral (maxBound :: Word16))
+    f <- choose (0, fromIntegral (maxBound :: Word16))
+    g <- choose (0, fromIntegral (maxBound :: Word16))
+    h <- choose (0, fromIntegral (maxBound :: Word16))
+    return $ toIPv6 [a, b, c, d, e, f, g, h]
+
+instance Arbitrary IP where
+  arbitrary = frequency
+    [ (1, IPv4 <$> arbitrary)
+    , (1, IPv6 <$> arbitrary)
+    ]
+
+instance Arbitrary PortNumber where
+  arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
+
+instance Arbitrary PeerId where
+  arbitrary = oneof
+    [ azureusStyle defaultClientId defaultVersionNumber
+        <$> (T.encodeUtf8 <$> arbitrary)
+    , shadowStyle  'X'             defaultVersionNumber
+        <$> (T.encodeUtf8 <$> arbitrary)
+    ]
+
+instance Arbitrary a => Arbitrary (PeerAddr a) where
+  arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary NodeId where
+  arbitrary = fromString <$> vector 20
+
+instance Arbitrary a => Arbitrary (NodeAddr a) where
+  arbitrary = NodeAddr <$> arbitrary <*> arbitrary
+
+instance Arbitrary a => Arbitrary (NodeInfo a) where
+  arbitrary = NodeInfo <$> arbitrary <*> arbitrary
+
+spec :: Spec
+spec = do
+  describe "PeerId" $ do
+    it "properly bencoded" $ do
+      BE.decode "20:01234567890123456789"
+        `shouldBe` Right ("01234567890123456789" :: PeerId)
+
+  describe "PortNumber" $ do
+    it "properly serialized" $ do
+      S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber)
+      S.encode (258 :: PortNumber) `shouldBe` "\x1\x2"
+
+    it "properly bencoded" $ do
+      BE.decode "i80e" `shouldBe` Right (80 :: PortNumber)
+
+    it "fail if port number is invalid" $ do
+      (BE.decode "i-10e" :: BE.Result PortNumber)
+        `shouldBe`
+        Left "fromBEncode: unable to decode PortNumber: -10"
+
+      (BE.decode "i70000e" :: BE.Result PortNumber)
+        `shouldBe`
+        Left "fromBEncode: unable to decode PortNumber: 70000"
+
+  describe "Peer IPv4" $ do
+    it "properly serialized" $ do
+      S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4])
+      S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
+
+    it "properly serialized (iso)" $ property $ \ ip -> do
+      S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4)
+
+    it "properly bencoded" $ do
+      BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1])
+      BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1"
+
+    it "properly bencoded (iso)" $ property $ \ ip ->
+      BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
+
+    it "fail gracefully on invalid strings" $ do
+      BE.decode "3:1.1" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4)
+
+    it "fail gracefully on invalid bencode" $ do
+      BE.decode "i10e" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: addr should be a bstring"
+         :: BE.Result IPv4)
+
+  describe "Peer IPv6" $ do
+    it "properly serialized" $ do
+      S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
+        `shouldBe`
+        Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
+
+      S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
+        `shouldBe`
+        "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
+
+    it "properly serialized (iso)" $ property $ \ ip ->
+      S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6)
+
+    it "properly bencoded" $ do
+      BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
+      BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe`
+        "23:00:00:00:00:00:00:00:01"
+
+      BE.decode "23:00:00:00:00:00:00:00:01"
+        `shouldBe`
+        Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
+
+    it "properly bencoded iso" $ property $ \ ip ->
+      BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
+
+    it "fail gracefully on invalid strings" $ do
+      BE.decode "4:g::1" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6)
+
+    it "fail gracefully on invalid bencode" $ do
+      BE.decode "i10e" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: addr should be a bstring"
+         :: BE.Result IPv6)
+
+
+  describe "Peer IP" $ do
+    it "properly serialized IPv6" $ do
+      S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
+        `shouldBe`
+        Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
+
+      S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
+        `shouldBe`
+        "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
+
+    it "properly serialized (iso) IPv6" $ property $ \ ip ->
+      S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
+
+    it "properly serialized IPv4" $ do
+      S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4])
+      S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
+
+    it "properly serialized (iso) IPv4" $ property $ \ ip -> do
+      S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
+
+    it "properly bencoded" $ do
+      BE.decode "11:168.192.0.1" `shouldBe`
+        Right (IPv4 (toIPv4 [168, 192, 0, 1]))
+
+      BE.decode "3:::1" `shouldBe` Right
+         (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
+
+      BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe`
+        "23:00:00:00:00:00:00:00:01"
+
+      BE.decode "23:00:00:00:00:00:00:00:01"
+        `shouldBe`
+        Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
+
+    it "properly bencoded iso" $ property $ \ ip ->
+      BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP)
+
+    it "fail gracefully on invalid strings" $ do
+      BE.decode "4:g::1" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP)
+
+    it "fail gracefully on invalid bencode" $ do
+      BE.decode "i10e" `shouldBe`
+        (Left "fromBEncode: unable to decode IP: addr should be a bstring"
+         :: BE.Result IP)
+
+  describe "PeerAddr" $ do
+    it "IsString" $ do
+      ("127.0.0.1:80" :: PeerAddr IP)
+        `shouldBe` PeerAddr Nothing "127.0.0.1" 80
+
+      ("127.0.0.1:80" :: PeerAddr IPv4)
+        `shouldBe` PeerAddr Nothing "127.0.0.1" 80
+
+      ("[::1]:80"     :: PeerAddr IP)
+        `shouldBe` PeerAddr Nothing "::1"       80
+
+      ("[::1]:80"     :: PeerAddr IPv6)
+        `shouldBe` PeerAddr Nothing "::1"       80
+
+    it "properly bencoded (iso)" $ property $ \ addr ->
+      BE.decode (BL.toStrict (BE.encode addr))
+        `shouldBe` Right (addr :: PeerAddr IP)
+
+
+    it "properly bencoded (ipv4)" $ do
+      BE.decode "d2:ip11:168.192.0.1\
+                 \7:peer id20:01234567890123456789\
+                 \4:porti6881e\
+                 \e"
+        `shouldBe`
+        Right (PeerAddr (Just "01234567890123456789")
+                        (IPv4 (toIPv4 [168, 192, 0, 1]))
+                        6881)
+
+    it "properly bencoded (ipv6)" $ do
+      BE.decode "d2:ip3:::1\
+                 \7:peer id20:01234567890123456789\
+                 \4:porti6881e\
+                 \e"
+        `shouldBe`
+        Right (PeerAddr (Just "01234567890123456789")
+                        (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
+                        6881)
+
+    it "peer id is optional" $ do
+      BE.decode "d2:ip11:168.192.0.1\
+                 \4:porti6881e\
+                 \e"
+        `shouldBe`
+        Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881)
+
+    it "has sock addr for both ipv4 and ipv6" $ do
+      show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80"
+      show (peerSockAddr "[::1]:8080"  ) `shouldBe` "[::1]:8080"
+
+  describe "NodeId" $ do
+    it "properly serialized" $ do
+      S.decode "mnopqrstuvwxyz123456"
+        `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId)
+
+      S.encode ("mnopqrstuvwxyz123456" :: NodeId)
+        `shouldBe` "mnopqrstuvwxyz123456"
+
+    it "properly serialized (iso)" $ property $ \ nid ->
+      S.decode (S.encode nid) `shouldBe`
+        Right (nid :: NodeId)
+
+  describe "NodeAddr" $ do
+    it "properly serialized" $ do
+      S.decode "\127\0\0\1\1\2" `shouldBe`
+        Right ("127.0.0.1:258" :: NodeAddr IPv4)
+
+    it "properly serialized (iso)" $ property $ \ nid ->
+      S.decode (S.encode nid) `shouldBe`
+        Right (nid :: NodeAddr IPv4)
+
+  describe "NodeInfo" $ do
+    it "properly serialized" $ do
+      S.decode "mnopqrstuvwxyz123456\
+               \\127\0\0\1\1\2" `shouldBe` Right
+       (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4)
+
+    it "properly serialized (iso)" $ property $ \ nid ->
+      S.decode (S.encode nid) `shouldBe`
+        Right (nid :: NodeInfo IPv4)
+
+  --  see <http://bittorrent.org/beps/bep_0020.html>
+  describe "Fingerprint" $ do
+    it "decode mainline encoded peer id" $ do
+      fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6"
+      fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8"
+
+    it "decode azureus encoded peer id" $ do
+      fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060"
+      fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0"
+
+    it "decode Shad0w style peer id" $ do
+      fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11"
+      fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11"
+
+    it "decode bitcomet style peer id" $ do
+      fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
+      fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
+      fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49"
+
+    it "decode opera style peer id" $ do
+      fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123"
+
+    it "decode ML donkey style peer id" $ do
+      fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0"
+
+-- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia,
+-- BitSpirit, Rufus, G3 Torrent, FlashGet
\ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
new file mode 100644
index 00000000..6f3c7489
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.DHT.MessageSpec (spec) where
+import Control.Monad.Reader
+import Control.Monad.Logger
+import Control.Concurrent
+import Data.BEncode as BE
+import Data.ByteString.Lazy as BL
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT.Message
+import qualified Network.KRPC as KRPC (def)
+import Network.KRPC hiding (def)
+import Network.Socket (PortNumber)
+import Test.Hspec
+import Test.QuickCheck
+import System.Timeout
+
+import Data.TorrentSpec                 ()
+import Network.BitTorrent.CoreSpec      ()
+import Network.BitTorrent.DHT.TokenSpec ()
+
+-- Arbitrary queries and responses.
+instance Arbitrary Ping where arbitrary = pure Ping
+instance Arbitrary FindNode where arbitrary = FindNode <$> arbitrary
+instance Arbitrary ip => Arbitrary (NodeFound ip) where arbitrary = NodeFound <$> arbitrary
+instance Arbitrary GetPeers where arbitrary = GetPeers <$> arbitrary
+instance Arbitrary ip => Arbitrary (GotPeers ip) where arbitrary =  GotPeers <$> arbitrary <*> arbitrary
+instance Arbitrary Announce where arbitrary = Announce <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+instance Arbitrary Announced where arbitrary = pure Announced
+instance Arbitrary x => Arbitrary (Query x) where arbitrary = Query <$> arbitrary <*> arbitrary <*> arbitrary
+instance Arbitrary x => Arbitrary (Response x) where arbitrary = Response <$> arbitrary <*> arbitrary
+
+instance MonadLogger IO where
+  monadLoggerLog _ _ _ _ = return ()
+
+remoteAddr :: SockAddr
+remoteAddr = SockAddrInet 6881 (256 * 256 * 256 + 127)
+
+thisAddr :: SockAddr
+thisAddr = SockAddrInet 60000 (256 * 256 * 256 + 127)
+
+thisPort :: PortNumber
+thisPort = 60001
+
+rpc :: ReaderT (Manager IO) IO a -> IO a
+rpc action = do
+  withManager KRPC.def thisAddr [] $ runReaderT $ do
+    listen
+    action
+
+isQueryError :: QueryFailure -> Bool
+isQueryError _ = True
+
+prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation
+prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x
+
+retry :: Int -> IO (Maybe a) -> IO (Maybe a)
+retry 0 _ = return Nothing
+retry n a = do
+  res <- a
+  case res of
+    Just _ -> return res
+    Nothing -> threadDelay (100 * 1000) >> retry (n-1) a
+
+spec :: Spec
+spec = do
+ context ("you need running DHT node at " ++ show remoteAddr) $ do
+  it "is running" $ do
+         running <- retry 5 $ timeout (100 * 1000) $ do
+                      nid <- genNodeId
+                      Response _remoteAddr Ping <-
+                          rpc (query remoteAddr (Query nid False Ping))
+                      return ()
+         running `shouldSatisfy` isJust
+
+  describe "ping" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789e"
+        `shouldBe` Right (Query "abcdefghij0123456789" False Ping)
+
+      BE.encode (Query "abcdefghij0123456789" False Ping)
+        `shouldBe` "d2:id20:abcdefghij0123456789e"
+
+      BE.decode "d2:id20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right (Response "mnopqrstuvwxyz123456" Ping)
+
+      BE.encode (Response "mnopqrstuvwxyz123456" Ping)
+        `shouldBe` "d2:id20:mnopqrstuvwxyz123456e"
+
+    it "properly bencoded (iso)" $ property $ \ nid -> do
+      prop_bencode (Query    nid False Ping)
+      prop_bencode (Response nid Ping)
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid False Ping))
+      return ()
+
+  describe "find_node" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \6:target20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right (Query "abcdefghij0123456789" False
+                      (FindNode "mnopqrstuvwxyz123456"))
+
+      BE.encode (Query "abcdefghij0123456789" False
+                 (FindNode "mnopqrstuvwxyz123456"))
+        `shouldBe`
+         "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e"
+
+      let naddr = "127.0.0.1:258" :: NodeAddr IPv4
+      let nid  = "0123456789abcdefghij"
+      let nid' = "mnopqrstuvwxyz123456"
+      BE.decode "d2:id20:0123456789abcdefghij\
+                 \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
+                \e"
+       `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr]))
+
+    it "properly bencoded (iso)" $ property $ \ nid x xs -> do
+      prop_bencode (Query    nid False (FindNode  x))
+      prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] )))
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteAddr (NodeFound xs) <- rpc $ do
+        query remoteAddr (Query nid False (FindNode nid))
+      L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0)
+
+  describe "get_peers" $ do
+    it "properly bencoded" $ do
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \9:info_hash20:mnopqrstuvwxyz123456\
+                  \e"
+         `shouldBe` Right (Query "abcdefghij0123456789" False
+                           (GetPeers "mnopqrstuvwxyz123456"))
+
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \5:token8:aoeusnth\
+                  \6:valuesl6:\127\0\0\1\1\2\&6:\192\168\1\100\1\2e\
+                 \e"
+         `shouldBe` Right (Response "abcdefghij0123456789"
+             (GotPeers (Right [ "127.0.0.1:258" :: PeerAddr IPv4
+                              , "192.168.1.100:258"
+                              ]) "aoeusnth"))
+
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
+                  \5:token8:aoeusnth\
+                 \e"
+         `shouldBe` Right (Response "abcdefghij0123456789"
+            (GotPeers
+             { peers = Left [NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258"
+                                 :: NodeInfo IPv4]
+             , grantedToken = "aoeusnth"
+             }))
+
+    it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do
+      prop_bencode (Query    nid False (GetPeers topic))
+      let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+      let nullPeerId paddr = paddr {peerId = Nothing}
+      let nullPeerIds      = either Left (Right . L.map nullPeerId)
+      prop_bencode (Response nid (GotPeers (nullPeerIds exs) token))
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteId (GotPeers {..})
+        <- rpc $ query remoteAddr (Query nid False (GetPeers def))
+      let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+      either L.length L.length peers `shouldSatisfy` (> 0)
+
+  describe "announce" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \9:info_hash20:mnopqrstuvwxyz123456\
+                 \4:porti6881e\
+                 \5:token8:aoeusnth\
+                \e" `shouldBe` Right
+        (Query "abcdefghij0123456789" False
+                   (Announce False "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
+
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \12:implied_porti1e\
+                 \9:info_hash20:mnopqrstuvwxyz123456\
+                 \4:porti6881e\
+                 \5:token8:aoeusnth\
+                \e" `shouldBe` Right
+        (Query "abcdefghij0123456789" False
+                   (Announce True "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
+
+
+      BE.decode "d2:id20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right
+        (Response "mnopqrstuvwxyz123456" Announced)
+
+    it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do
+      prop_bencode (Query    nid False (Announce flag topic Nothing port token))
+      prop_bencode (Response nid (Announced))
+
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteId Announced <- rpc $ do
+        Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
+        let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+        query remoteAddr (Query nid False (Announce False def Nothing thisPort grantedToken))
+      return ()
+
+    it "does fail on invalid token" $ do
+      nid <- genNodeId
+      (rpc $ do
+        Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
+        let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+        let invalidToken = ""
+        let q :: MonadKRPC h m => SockAddr -> Query Announce
+              -> m (Response Announced)
+            q = query
+        q remoteAddr (Query nid False (Announce False def Nothing thisPort invalidToken)))
+          `shouldThrow` isQueryError
+      return ()
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
new file mode 100644
index 00000000..93f78263
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.DHT.QuerySpec (spec) where
+import Control.Applicative
+import Control.Exception
+import Control.Monad.Reader
+import Data.Conduit as C
+import Data.Conduit.List as CL
+import Data.Default
+import Data.List as L
+import Test.Hspec
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT
+import Network.BitTorrent.DHT.Session
+import Network.BitTorrent.DHT.Query
+
+import Network.BitTorrent.DHT.TestData
+
+
+myAddr :: NodeAddr IPv4
+myAddr = "0.0.0.0:0"
+
+nullLogger :: LogFun
+nullLogger _ _ _ _ = return ()
+
+--simpleLogger :: LogFun
+--simpleLogger _ t _ _ = print t
+
+simpleDHT :: [NodeHandler IPv4] -> DHT IPv4 a -> IO a
+simpleDHT hs m =
+  bracket (newNode hs def myAddr nullLogger Nothing) closeNode $ \ node ->
+    runDHT node m
+
+getBootInfo :: IO (NodeInfo IPv4)
+getBootInfo = do
+  startAddr <- resolveHostName (L.head defaultBootstrapNodes)
+  simpleDHT [] $ fmap fst (pingQ startAddr)
+
+spec :: Spec
+spec = parallel $ do
+  describe "environment" $ do
+    describe "test node" $ do
+      it "is alive" $ do
+         _ <- getBootInfo
+         return ()
+
+  describe "handlers" $ do
+    it "" $ pendingWith "need to setup 2 DHT locally"
+
+  describe "basic queries" $ do
+    it "ping" $ do
+      _ <- getBootInfo
+      return ()
+
+    it "findNode" $ do
+      startInfo <- getBootInfo
+      _ <- simpleDHT [] $ do
+        nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+        findNodeQ nid startInfo
+      return ()
+
+    it "getPeers" $ do
+      startInfo <- getBootInfo
+      peers <- simpleDHT [] $ do
+        nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+
+        -- we should not run getPeers query on boot node, because
+        -- it may not support it
+        Right infos <- findNodeQ nid startInfo
+
+        when (L.null infos) $
+          error "boot node malfunction"
+
+        -- at least one node should reply
+        queryParallel $ do
+          getPeersQ (entryHash (L.head testTorrents)) <$> infos
+
+      peers `shouldSatisfy` (not . L.null)
+
+    it "announce" $ do
+      bootNode <- getBootInfo
+      _ <- simpleDHT [] $ do
+        let ih = entryHash (L.head testTorrents)
+        Right nodes <- findNodeQ ih bootNode
+
+        when (L.null nodes) $
+          error "boot node malfunction"
+
+        queryParallel $ do
+          announceQ ih (nodePort myAddr) <$> nodes
+
+      return ()
+
+  describe "iterative queries" $ do
+    forM_ testTorrents $ \ TestEntry {..} -> do
+      context entryName $ do
+
+        it "get at least 10 unique peers for each infohash" $ do
+          bootNode <- getBootInfo
+          peers <- simpleDHT [] $ do
+            Right startNodes <- findNodeQ entryHash bootNode
+            sourceList [startNodes] $=
+              search entryHash (getPeersQ entryHash) $=
+                CL.concat $$ CL.take 10
+          L.length peers `shouldBe` 10
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
new file mode 100644
index 00000000..07a906ba
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts    #-}
+module Network.BitTorrent.DHT.RoutingSpec (spec) where
+import Control.Applicative
+import Control.Monad.State
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT.Routing as T
+
+import Network.BitTorrent.CoreSpec hiding (spec)
+
+
+type Network ip = [NodeAddr ip]
+
+data Env ip = Env
+  { currentTime :: Timestamp
+  , network     :: Network ip
+  } deriving Show
+
+type Simulation ip = State (Env ip)
+
+runSimulation :: Eq ip => Env ip -> Routing ip a -> Maybe a
+runSimulation e m = evalState (runRouting ping closest timestamp m) e
+  where
+    ping    addr = gets (L.elem addr . network)
+    closest nid  = error "runSimulation"
+    timestamp    = gets currentTime
+
+instance Arbitrary ip => Arbitrary (Env ip) where
+  arbitrary = Env <$> arbitrary <*> (vector nodeCount)
+    where
+      nodeCount = 1000
+
+instance (Arbitrary ip, Eq ip) => Arbitrary (Table ip) where
+  arbitrary = do
+    thisId  <- arbitrary
+    bucketN <- choose (1, 20)
+    let table = nullTable thisId bucketN
+
+--    nodeN   <- (`mod` bucketN) <$> arbitrary
+--    nodes   <- vector nodeN
+
+    node    <- arbitrary
+    mt <- do
+        env <- arbitrary
+        return $ runSimulation env $ do
+            (_,t') <- T.insert (currentTime env) (TryInsert node) table
+            return t' :: Routing ip (Table ip)
+          --(foldM (flip fillTable) table nodes)
+    return (fromJust mt)
+--    where
+--     fillTable x t = do
+--       t' <- T.insert x t
+--       return $ if T.full t' then t else t'
+
+spec :: Spec
+spec = do
+  describe "size" $ do
+    it "null table is empty" $ do
+      T.size (nullTable def 2 :: Table IPv4) `shouldBe` 0
+
+    it "the same node never appear in different buckets" $ property $ \ t -> do
+      let xss = T.toList (t :: Table Int)
+      let justOnce x = L.length (L.filter (L.elem x) xss) == 1
+      L.all justOnce (L.concat xss)
+
+    it "insert is idemponent" $ property $ \ (e :: Env Int) n t -> do
+      let ins :: NodeInfo Int -> Table Int -> Routing Int (Table Int)
+          ins n t = snd <$> T.insert (currentTime e) (TryInsert n) t
+      let t1 = runSimulation e (ins n t)
+      let t2 = runSimulation e (ins n t >>= ins n)
+      t1 `shouldBe` t2
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
new file mode 100644
index 00000000..32e4c158
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Network.BitTorrent.DHT.SessionSpec (spec) where
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Reader
+import Control.Monad.Trans.Resource
+import Data.Conduit.Lazy
+import Data.Default
+import Data.List as L
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT
+import Network.BitTorrent.DHT.Message
+import Network.BitTorrent.DHT.Session
+import Network.BitTorrent.DHT.Query
+
+import Data.TorrentSpec ()
+import Network.BitTorrent.CoreSpec ()
+import Network.BitTorrent.DHT.TokenSpec ()
+
+
+myAddr :: NodeAddr IPv4
+myAddr = "127.0.0.1:60000"
+
+simpleDHT :: DHT IPv4 a -> IO a
+simpleDHT m =
+  bracket (newNode defaultHandlers def myAddr nullLogger Nothing) closeNode $ \ node ->
+    runDHT node m
+
+isRight :: Either a b -> Bool
+isRight (Left  _) = False
+isRight (Right _) = True
+
+isLeft :: Either a b -> Bool
+isLeft = not . isRight
+
+nullLogger :: LogFun
+nullLogger _ _ _ _ = return ()
+
+spec :: Spec
+spec = do
+  describe "session" $ do
+    it "is active until closeNode called" $ do
+      node <- newNode [] def myAddr nullLogger Nothing
+      runDHT node monadActive `shouldReturn` True
+      runDHT node monadActive `shouldReturn` True
+      closeNode node
+      runDHT node monadActive `shouldReturn` False
+
+  describe "tokens" $ do
+    it "should not complain about valid token" $
+      property $ \ (addrs :: [NodeAddr IPv4]) -> do
+        isOks <- simpleDHT $ do
+          forM addrs $ \ addr -> do
+            token <- grantToken addr
+            checkToken addr token
+        L.and isOks `shouldBe` True
+
+    it "should complain about invalid token" $
+      property $ \ (addr :: NodeAddr IPv4) token -> do
+        isOk <- simpleDHT (checkToken addr token)
+        isOk `shouldBe` False
+
+  describe "routing table" $
+    it "accept any node entry when table is empty" $
+      property $ \ (nid :: NodeId) -> do
+        let info = NodeInfo nid myAddr
+        closest <- simpleDHT $ do
+           _ <- insertNode info Nothing
+           liftIO $ yield
+           getClosest nid
+        closest `shouldSatisfy` L.elem info
+
+  describe "peer storage" $ do
+    it "should return nodes, if there are no peers" $ property $ \ ih -> do
+      res <- simpleDHT $ do getPeerList ih
+      res `shouldSatisfy` isLeft
+
+    it "should return peers, if any" $ property $ \ ih addr -> do
+      res <- simpleDHT $ do
+                 insertPeer ih addr
+                 getPeerList ih
+      res `shouldSatisfy` isRight
+
+  describe "topic storage" $ do
+    it "should not grow indefinitely" $ do
+      pending
+
+  describe "messaging" $ do
+    describe "queryNode" $ do
+      it "should always ping this node" $ do
+        (rid, tid) <- simpleDHT $ do
+          (remoteId, Ping) <- queryNode myAddr Ping
+          thisId <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+          return (remoteId, thisId)
+        rid `shouldBe` tid
+
+    describe "queryParallel" $ do
+      it "should handle parallel requests" $ do
+        (nid, resps) <- simpleDHT $ do
+          me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+          ( (,) me ) <$> queryParallel (L.replicate 100 $ queryNode myAddr Ping)
+        resps `shouldSatisfy` L.all (== (nid, Ping))
+
+    describe "(<@>) operator" $ do
+      it "" $
+         pending
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
new file mode 100644
index 00000000..e9473cbb
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
@@ -0,0 +1,45 @@
+module Network.BitTorrent.DHT.TestData
+       ( TestEntry (..)
+       , testTorrents
+       ) where
+
+import Data.Torrent
+
+data TestEntry = TestEntry
+  { entryName  :: String
+  , entryHash  :: InfoHash
+  , entryPeers :: Int -- ^ approximate number of peers, may change with time
+  }
+
+testTorrents :: [TestEntry]
+testTorrents =
+  [ TestEntry
+    { entryName  = "Automate with Arduino, Android..."
+    , entryHash  = "8c0433e541dc5d1cfc095799cef171cd4eb586f7"
+    , entryPeers = 300
+    }
+
+  , TestEntry
+    { entryName  = "Beginning Programming with Java For Dummies"
+    , entryHash  = "fd8967721731cc16c8b203a03e49ce839cecf184"
+    , entryPeers = 200
+    }
+
+  , TestEntry
+    { entryName  = "The C Programming Language"
+    , entryHash  = "146d13f090e50e97091dbbe5b37678dd1471cfad"
+    , entryPeers = 100
+    }
+
+  , TestEntry
+    { entryName  = "The C++ Programming Language"
+    , entryHash  = "8e8e8e6319031a22cff26d895afe050085c84a7f"
+    , entryPeers = 50
+    }
+
+  , TestEntry
+    { entryName  = "Game and Graphics Programming for iOS..."
+    , entryHash  = "703d0595b727fccbfaa3d03be25f57347ccfd6de"
+    , entryPeers = 30
+    }
+  ]
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
new file mode 100644
index 00000000..a45d2212
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.DHT.TokenSpec (spec) where
+import Control.Applicative
+import Data.List as L
+import Data.String
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.CoreSpec ()
+import Network.BitTorrent.DHT.Token as T
+
+
+instance Arbitrary Token where
+  arbitrary = fromString <$> arbitrary
+
+instance Arbitrary TokenMap where
+  arbitrary = tokens <$> arbitrary
+
+repeatN :: Int -> (a -> a) -> (a -> a)
+repeatN n f = L.foldr (.) id $ L.replicate n f
+
+spec :: Spec
+spec = do
+  describe "Token" $ do
+    return ()
+
+  describe "TokenMap" $ do
+    it "is keeping any granted token in current session" $
+      property $ \ (addr :: NodeAddr IPv4) m ->
+        T.member addr (T.lookup addr m) m
+
+    it "is keeping any granted token in next session" $
+      property $ \ (addr :: NodeAddr IPv4) m ->
+        T.member addr (T.lookup addr m) (T.update m)
+
+    -- can fail with some small probability
+    it "is rejecting any outdated tokens" $
+      property $ \ (addr :: NodeAddr IPv4) m k -> not $
+        let n = min 100 (abs k + 2) in
+        T.member addr (T.lookup addr m) (repeatN n T.update m)
\ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/DHTSpec.hs b/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
new file mode 100644
index 00000000..77160eb5
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
@@ -0,0 +1,60 @@
+module Network.BitTorrent.DHTSpec (spec) where
+import Control.Exception
+import Control.Monad
+import Data.Default
+import Data.List as L
+import Test.Hspec
+import System.Timeout
+
+import Data.Torrent
+import Network.BitTorrent.DHT
+
+
+partialBootstrapTimeout :: Int
+partialBootstrapTimeout = 10 * 1000000
+
+opts :: Options
+opts = def { optBucketCount = 1 }
+
+-- NOTE to shorten test cases run time include only "good" infohashes
+-- with many nodes
+existingInfoHashes :: [InfoHash]
+existingInfoHashes =
+  [
+  ]
+
+-- TODO use Test.Hspec.parallel
+
+spec :: Spec
+spec = do
+  describe "bootstrapping" $ do
+    it "should resolve all default bootstrap nodes" $ do
+      nodes <- forM defaultBootstrapNodes resolveHostName
+      _     <- evaluate nodes
+      return ()
+
+    it "partial bootstrapping should finish in less than 10 seconds" $ do
+      node <- resolveHostName (L.head defaultBootstrapNodes)
+      res  <- timeout partialBootstrapTimeout $ do
+                dht opts def fullLogging $ do
+                  bootstrap Nothing [node]
+                  isBootstrapped
+      res `shouldBe` Just True
+
+  describe "initialization" $ do
+    it "should be bootstrapped after restore process" $ do
+      pending
+
+  describe "lookup" $ do
+    describe "for any existing infohash" $ do
+      forM_ existingInfoHashes $ \ ih -> do
+        context (show ih) $ do
+          it "should find peers" $ do
+            pending
+
+  describe "insert" $ do
+    it "should return this peer if announced" $ do
+      pending
+
+  describe "delete" $ do
+    return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
new file mode 100644
index 00000000..1ba772f6
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS -fno-warn-orphans #-}
+module Network.BitTorrent.Exchange.BitfieldSpec (spec) where
+import Control.Applicative
+import Data.ByteString.Arbitrary
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Exchange.Bitfield
+
+instance Arbitrary Bitfield where
+  arbitrary = fromBitmap . fromABS <$> arbitrary
+
+spec :: Spec
+spec = return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
new file mode 100644
index 00000000..2dc8e0b8
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
@@ -0,0 +1,35 @@
+module Network.BitTorrent.Exchange.BlockSpec (spec) where
+import Control.Applicative
+import Control.Exception
+import Data.Maybe
+import Test.Hspec
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
+
+import Network.BitTorrent.Exchange.Block as Block
+
+
+instance Arbitrary a => Arbitrary (Block a) where
+  arbitrary = Block <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary BlockIx where
+  arbitrary = BlockIx <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary Bucket where
+  arbitrary = do
+    s      <- arbitrary `suchThat` (> 0)
+    chunks <- arbitrary
+    return $ Block.fromList s chunks
+
+isSomeException :: SomeException -> Bool
+isSomeException = const True
+
+spec :: Spec
+spec = do
+  describe "empty" $ do
+    it "should fail on bad size" $ do
+      evaluate (Block.empty (-1)) `shouldThrow` isSomeException
+
+  describe "toPiece" $ do
+    it "render to piece when it is full" $ property $ \ bkt ->
+      full bkt == isJust (toPiece bkt)
\ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
new file mode 100644
index 00000000..d654cda1
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE RecordWildCards      #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.Exchange.ConnectionSpec (spec) where
+import Control.Applicative
+import Control.Monad.Trans
+import Data.Default
+import Test.Hspec
+import Test.QuickCheck
+
+import Data.Torrent
+import Network.BitTorrent.Address
+import Network.BitTorrent.Exchange.Connection
+import Network.BitTorrent.Exchange.Message
+
+import Config
+import Network.BitTorrent.Exchange.MessageSpec ()
+
+nullSession :: InfoHash -> PeerId -> SessionLink ()
+nullSession ih pid = SessionLink ih pid Nothing Nothing ()
+
+instance Arbitrary Options where
+  arbitrary = return def
+
+instance Arbitrary ConnectionPrefs where
+  arbitrary = ConnectionPrefs <$> arbitrary <*> pure def
+                              <*> arbitrary <*> arbitrary
+
+withWire :: ConnectionPrefs -> Wire () () -> IO ()
+withWire prefs wire =
+  withRemote $ \ ClientOpts {..} -> do
+    pid <- genPeerId
+    t   <- getTestTorrent
+    let ih  = idInfoHash (tInfoDict t)
+    let cfg = ConnectionConfig prefs (nullSession ih pid) (wire)
+    let addr = PeerAddr Nothing "127.0.0.1" peerPort
+    connectWire addr cfg
+
+spec :: Spec
+spec = do
+  describe "connectWire" $ do
+    it "can establish connection with all possible preferences" $
+      property $ \ prefs -> do
+        withWire prefs (return ())
+
+    it "must not connect with invalid topic" $ do
+      pending
+
+  describe "acceptWire" $ do
+    it "" $ do
+      pending
+
+  describe "messaging" $ do
+    it "first message is bitfield" $ do
+      withWire def $ do
+        msg <- recvMessage
+        let isBitfield (Available (Bitfield _)) = True
+            isBitfield  _                       = False
+        liftIO $ msg `shouldSatisfy` isBitfield
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
new file mode 100644
index 00000000..d46f2034
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Exchange.DownloadSpec (spec) where
+import Control.Concurrent
+import Data.ByteString as BS
+import Data.ByteString.Lazy as BL
+import Test.Hspec
+import Test.QuickCheck
+
+import Data.BEncode as BE
+import Data.Torrent as Torrent
+import Network.BitTorrent.Address
+import Network.BitTorrent.Exchange.Download
+import Network.BitTorrent.Exchange.Message
+
+import Config
+import Network.BitTorrent.CoreSpec ()
+
+
+placeholderAddr :: PeerAddr IP
+placeholderAddr = "0.0.0.0:0"
+
+chunkBy :: Int -> BS.ByteString -> [BS.ByteString]
+chunkBy s bs
+  | BS.null bs = []
+  | otherwise  = BS.take s bs : chunkBy s (BS.drop s bs)
+
+withUpdates :: Updates s a -> IO a
+withUpdates m = do
+  Torrent {..} <- getTestTorrent
+  let infoDictLen = fromIntegral $ BL.length $ BE.encode tInfoDict
+  --mvar <- newMVar (nullStatus infoDictLen)
+  --runUpdates mvar placeholderAddr m
+  undefined
+
+simulateFetch :: InfoDict -> Updates s (Maybe InfoDict)
+simulateFetch dict = undefined
+
+spec :: Spec
+spec = do
+  describe "scheduleBlock" $ do
+    it "never schedule the same index twice" $ do
+      pending
+
+  describe "resetPending" $ do
+    it "" $ do
+      pending
+
+  describe "cancelPending" $ do
+    it "must not throw an exception if cancel the same piece twice" $ do
+      pending
+
+  describe "pushBlock" $ do
+    it "assemble infodict from chunks" $ do
+      Torrent {..} <- getTestTorrent
+      mdict <- withUpdates $ simulateFetch tInfoDict
+      mdict `shouldBe` Just tInfoDict
+
+    it "must throw an exception if block if not requested" $ do
+      pending
\ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
new file mode 100644
index 00000000..d615b1ff
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
@@ -0,0 +1,102 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.Exchange.MessageSpec (spec) where
+import Control.Applicative
+import Control.Exception
+import Data.ByteString as BS
+import Data.List as L
+import Data.Set as S
+import Data.Serialize as S
+import Data.String
+import Test.Hspec
+import Test.QuickCheck
+
+import Data.TorrentSpec ()
+import Network.BitTorrent.Exchange.BitfieldSpec ()
+import Network.BitTorrent.CoreSpec ()
+import Network.BitTorrent.Address ()
+import Network.BitTorrent.Exchange.BlockSpec ()
+import Network.BitTorrent.Exchange.Message
+
+instance Arbitrary Extension where
+  arbitrary = elements [minBound .. maxBound]
+
+instance Arbitrary Caps where
+  arbitrary = toCaps <$> arbitrary
+
+instance Arbitrary ExtendedExtension where
+  arbitrary = elements [minBound .. maxBound]
+
+instance Arbitrary ExtendedCaps where
+  arbitrary = toCaps <$> arbitrary
+
+instance Arbitrary ProtocolName where
+  arbitrary = fromString <$> (arbitrary `suchThat` ((200 <) . L.length))
+
+instance Arbitrary Handshake where
+  arbitrary = Handshake <$> arbitrary <*> arbitrary
+                        <*> arbitrary <*> arbitrary
+
+instance Arbitrary StatusUpdate where
+  arbitrary = frequency
+    [ (1, Choking    <$> arbitrary)
+    , (1, Interested <$> arbitrary)
+    ]
+
+instance Arbitrary Available where
+  arbitrary = frequency
+    [ (1, Have     <$> arbitrary)
+    , (1, Bitfield <$> arbitrary)
+    ]
+
+instance Arbitrary Transfer where
+  arbitrary = frequency
+    [ (1, Request <$> arbitrary)
+    , (1, Piece   <$> arbitrary)
+    , (1, Cancel  <$> arbitrary)
+    ]
+
+instance Arbitrary FastMessage where
+  arbitrary = frequency
+    [ (1, pure HaveAll)
+    , (1, pure HaveNone)
+    , (1, SuggestPiece  <$> arbitrary)
+    , (1, RejectRequest <$> arbitrary)
+    , (1, AllowedFast   <$> arbitrary)
+    ]
+
+instance Arbitrary Message where
+  arbitrary = frequency
+    [ (1, pure KeepAlive)
+    , (1, Status    <$> arbitrary)
+    , (1, Available <$> arbitrary)
+    , (1, Transfer  <$> arbitrary)
+    , (1, Fast      <$> arbitrary)
+    ]
+
+-- TODO test extension protocol
+
+spec :: Spec
+spec = do
+  describe "Caps" $ do
+    it "set-like container" $ property $ \ exts ->
+      L.all (`allowed` (toCaps exts :: Caps)) exts
+
+    it "preserve items" $ property $ \ extSet ->
+      S.fromList (fromCaps (toCaps (S.toList extSet) :: Caps))
+        `shouldBe` extSet
+
+  describe "ByteStats" $ do
+    it "preserve size" $ property $ \ msg ->
+      byteLength (stats msg) `shouldBe`
+        fromIntegral (BS.length (S.encode (msg :: Message)))
+
+  describe "ProtocolName" $ do
+    it "fail to construct invalid string" $ do
+      let str = L.replicate 500 'x'
+      evaluate (fromString str :: ProtocolName)
+        `shouldThrow`
+        errorCall ("fromString: ProtocolName too long: " ++ str)
+
+  describe "Handshake" $ do
+    it "properly serialized" $ property $ \ hs ->
+      S.decode (S.encode hs ) `shouldBe` Right (hs :: Handshake)
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
new file mode 100644
index 00000000..bf5b95a1
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Exchange.SessionSpec (spec) where
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Address
+import Network.BitTorrent.Exchange.Session
+
+import Config
+
+
+nullLogger :: LogFun
+nullLogger _ _ x _ = print x
+
+simpleSession :: InfoDict -> (Session -> IO ()) -> IO ()
+simpleSession dict action = do
+  withRemoteAddr $ \ addr -> do
+    myAddr <- getMyAddr
+    ses  <- newSession nullLogger myAddr "" (Right dict)
+    connect addr ses
+    action ses
+    closeSession ses
+
+spec :: Spec
+spec = do
+  describe "construction" $ do
+    describe "newSession" $ do
+      it "" $ do
+        pending
+
+    describe "closeSession" $ do
+      it "" $ do
+        pending
+
+  describe "connection set" $ do
+    describe "connect" $ do
+      it "" $ do
+        pending
+
+    describe "establish" $ do
+      it "" $ do
+        pending
+
+  describe "exchange" $ do
+    describe "metadata" $ do
+      it "should fetch info dictionary" $ do
+        Torrent {..} <- getTestTorrent
+        simpleSession tInfoDict $ \ ses -> do
+          dict <- waitMetadata ses
+          dict `shouldBe` tInfoDict
+
+      it "should serve info dictionary" $ do
+        pending
+
+    describe "content" $ do
+      it "should fetch torrent content" $ do
+        Torrent {..} <- getTestTorrent
+        simpleSession tInfoDict $ \ ses -> do
+          pending
+--        st <- waitData ses
+--        verifyStorage st (idPieceInfo tInfoDict)
+
+      it "should serve torrent content" $ do
+        pending
diff --git a/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
new file mode 100644
index 00000000..337e7add
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
@@ -0,0 +1,7 @@
+module Network.BitTorrent.Internal.CacheSpec (spec) where
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "Cached" $ do
+    return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
new file mode 100644
index 00000000..acbfd84c
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS -fno-warn-orphans #-}
+module Network.BitTorrent.Internal.ProgressSpec (spec) where
+import Control.Applicative
+import Test.Hspec
+import Test.QuickCheck
+import Network.BitTorrent.Internal.Progress
+
+
+instance Arbitrary Progress where
+  arbitrary = Progress <$> arbitrary <*> arbitrary <*> arbitrary
+
+spec :: Spec
+spec = return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
new file mode 100644
index 00000000..bba9d0e2
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
@@ -0,0 +1,40 @@
+module Network.BitTorrent.Tracker.ListSpec (spec) where
+import Control.Exception
+import Data.Default
+import Data.Foldable as F
+import Data.List as L
+import Data.Maybe
+import Network.URI
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Tracker.List
+import Network.BitTorrent.Tracker.RPC
+
+
+uris :: [URI]
+uris = fmap (fromJust . parseURI . renderURI) [1..10 :: Int]
+  where
+    renderURI n = "http://" ++ show n ++ ".org"
+
+list :: TrackerList ()
+list = trackerList def { tAnnounceList = Just [uris] }
+
+spec :: Spec
+spec = do
+  describe "TrackerList" $ do
+    it "shuffleTiers (may fail with very small probability)" $ do
+      list' <- shuffleTiers list
+      list' `shouldSatisfy` (/= list)
+
+    it "traverseAll" $ do
+      xs <- traverseAll (\ (uri, _) -> if uri == L.last uris
+               then throwIO (GenericException "")
+               else return ()) list
+      return ()
+
+    it "traverseTiers" $ do
+      xs' <- traverseTiers (\ (uri, _) -> if uri == L.last uris then return ()
+                              else throwIO (GenericException "")) list
+
+      return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
new file mode 100644
index 00000000..29854d58
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS -fno-warn-orphans  #-}
+module Network.BitTorrent.Tracker.MessageSpec
+       ( spec
+       , arbitrarySample
+       ) where
+
+import Control.Applicative
+import Control.Exception
+import Data.BEncode as BE
+import Data.ByteString.Lazy as BL
+import Data.List as L
+import Data.Maybe
+import Test.Hspec
+import Test.QuickCheck
+
+import Data.TorrentSpec ()
+import Network.BitTorrent.Internal.ProgressSpec ()
+import Network.BitTorrent.Address ()
+import Network.BitTorrent.Address ()
+
+import Network.BitTorrent.Tracker.Message as Message
+import Network.BitTorrent.Address
+
+
+--prop_bencode :: Eq a => BEncode a => a -> Bool
+--prop_bencode a = BE.decode (BL.toStrict (BE.encode a)) == return a
+
+--prop_urlencode :: Eq a => URLDecoded a => URLEncoded a => a -> Bool
+--prop_urlencode a = urlDecode (T.pack (urlEncode a)) == a
+
+instance Arbitrary AnnounceEvent where
+  arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary AnnounceQuery where
+  arbitrary = AnnounceQuery
+    <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary (PeerList IP) where
+  arbitrary = frequency
+    [ (1,        (PeerList . maybeToList) <$> arbitrary)
+    , (1, (CompactPeerList . maybeToList . fmap zeroPeerId) <$> arbitrary)
+    ]
+
+  shrink (       PeerList xs) =        PeerList <$> shrink xs
+  shrink (CompactPeerList xs) = CompactPeerList <$> shrink xs
+
+instance Arbitrary AnnounceInfo where
+  arbitrary = AnnounceInfo
+    <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    <*> arbitrary <*> arbitrary
+
+arbitrarySample :: Arbitrary a => IO a
+arbitrarySample = L.head <$> sample' arbitrary
+
+zeroPeerId :: PeerAddr a -> PeerAddr a
+zeroPeerId addr = addr { peerId = Nothing }
+
+spec :: Spec
+spec = do
+  describe "AnnounceQuery" $ do
+    it "properly url encoded" $ property $ \ q ->
+      parseAnnounceQuery (renderAnnounceQuery q)
+        `shouldBe` Right q
+
+  describe "PeerList" $ do
+    context "Non compact" $ do
+      it "properly encoded (both ipv4 and ipv6)" $ do
+        BE.decode "ld2:ip7:1.2.3.44:porti80eed2:ip3:::14:porti8080eee"
+          `shouldBe` Right
+          (PeerList ["1.2.3.4:80", "[::1]:8080"] :: PeerList IPv4)
+
+      it "properly encoded (iso)" $ property $ \ xs ->
+        BE.decode (BL.toStrict (BE.encode (PeerList xs :: PeerList IPv4)))
+          `shouldBe` Right (PeerList xs :: PeerList IPv4)
+
+    context "Compact" $ do
+      it "properly encodes (ipv4)" $ do
+        BE.decode "12:\x1\x2\x3\x4\x1\x2\x9\x8\x7\x6\x1\x2"
+          `shouldBe` Right
+          (CompactPeerList ["1.2.3.4:258", "9.8.7.6:258"] :: PeerList IPv4)
+
+      it "properly encodes (ipv6)" $ do
+        BE.decode "18:\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2"
+          `shouldBe` Right
+          (CompactPeerList ["[102:304:506:708:102:304:506:708]:258"]
+           :: PeerList IPv6)
+
+      it "properly encoded (ipv4, iso)" $
+        property $ \ (fmap zeroPeerId -> xs) ->
+          BE.decode (BL.toStrict (BE.encode (CompactPeerList xs)))
+            `shouldBe` Right (CompactPeerList xs :: PeerList IPv4)
+
+      it "properly encoded (ipv6, iso)" $
+        property $ \ (fmap zeroPeerId -> xs) ->
+          BE.decode (BL.toStrict (BE.encode (CompactPeerList xs)))
+            `shouldBe` Right (CompactPeerList xs :: PeerList IPv6)
+
+  describe "AnnounceInfo" $ do
+    it "parses minimal sample" $ do
+      "d8:intervali0e5:peerslee"
+        `shouldBe`
+        AnnounceInfo Nothing Nothing 0 Nothing (PeerList []) Nothing
+
+    it "parses optional fields" $ do
+      "d8:completei1e\
+       \10:incompletei2e\
+       \8:intervali3e\
+       \12:min intervali4e\
+       \5:peersle\
+       \15:warning message3:str\
+       \e"
+        `shouldBe`
+        AnnounceInfo (Just 1) (Just 2) 3 (Just 4) (PeerList []) (Just "str")
+
+    it "parses failed response" $ do
+      "d14:failure reason10:any reasone"
+                 `shouldBe`
+        Message.Failure "any reason"
+
+    it "fail if no peer list present" $ do
+      evaluate ("d8:intervali0ee" :: AnnounceInfo)
+        `shouldThrow`
+         errorCall "fromString: unable to decode AnnounceInfo: \
+                   \required field `peers' not found"
+
+    it "parses `peer' list" $ do -- TODO
+      "d8:intervali0e\
+       \5:peersl\
+               \d2:ip7:1.2.3.4\
+                \4:porti80e\
+               \e\
+               \d2:ip3:::1\
+                \4:porti80e\
+               \e\
+              \e\
+       \e" `shouldBe`
+        let xs = PeerList ["1.2.3.4:80", "[::1]:80"] in
+        AnnounceInfo Nothing Nothing 0 Nothing xs Nothing
+
+    it "parses `peers6' list" $ do
+      "d8:intervali0e\
+       \5:peers0:\
+       \6:peers60:\
+      \e" `shouldBe`
+        AnnounceInfo Nothing Nothing 0 Nothing (CompactPeerList []) Nothing
+
+    it "fails on invalid combinations of the peer lists" $ do
+      BE.decode "d8:intervali0e\
+                 \5:peers0:\
+                 \6:peers6le\
+                \e"
+        `shouldBe` (Left
+        "PeerList: the `peers6' field value should contain \
+                  \*compact* peer list" :: BE.Result AnnounceInfo)
+
+      BE.decode "d8:intervali0e\
+                 \5:peersle\
+                 \6:peers60:\
+                \e"
+        `shouldBe` (Left
+        "PeerList: non-compact peer list provided, \
+                  \but the `peers6' field present" :: BE.Result AnnounceInfo)
+
+    it "properly bencoded (iso)" $ property $ \ info ->
+      BE.decode (BL.toStrict (BE.encode info))
+        `shouldBe` Right (info :: AnnounceInfo)
+
+  describe "Scrape" $ do
+    return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
new file mode 100644
index 00000000..e928f917
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Tracker.RPC.HTTPSpec (spec) where
+import Control.Monad
+import Data.Default
+import Data.List as L
+import Test.Hspec
+
+import Network.BitTorrent.Internal.Progress
+import Network.BitTorrent.Tracker.Message as Message
+import Network.BitTorrent.Tracker.RPC.HTTP
+
+import Network.BitTorrent.Tracker.TestData
+import Network.BitTorrent.Tracker.MessageSpec hiding (spec)
+
+
+validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
+validateInfo _ (Message.Failure reason) = do
+  error $ "validateInfo: " ++ show reason
+validateInfo AnnounceQuery {..}  AnnounceInfo {..} = do
+  return ()
+--  case respComplete <|> respIncomplete of
+--    Nothing -> return ()
+--    Just n  -> n  `shouldBe` L.length (getPeerList respPeers)
+
+isUnrecognizedScheme :: RpcException -> Bool
+isUnrecognizedScheme (RequestFailed _) = True
+isUnrecognizedScheme  _                = False
+
+isNotResponding :: RpcException -> Bool
+isNotResponding (RequestFailed _) = True
+isNotResponding  _                = False
+
+spec :: Spec
+spec = parallel $ do
+  describe "Manager" $ do
+    describe "newManager" $ do
+      it "" $ pending
+
+    describe "closeManager" $ do
+      it "" $ pending
+
+    describe "withManager" $ do
+      it "" $ pending
+
+  describe "RPC" $ do
+    describe "announce" $ do
+      it "must fail on bad uri scheme" $ do
+        withManager def $ \ mgr -> do
+          q    <- arbitrarySample
+          announce mgr "magnet://foo.bar" q
+            `shouldThrow` isUnrecognizedScheme
+
+    describe "scrape" $ do
+      it "must fail on bad uri scheme" $ do
+        withManager def $ \ mgr -> do
+          scrape mgr "magnet://foo.bar" []
+            `shouldThrow` isUnrecognizedScheme
+
+    forM_ (L.filter isHttpTracker trackers) $ \ TrackerEntry {..} ->
+      context trackerName $ do
+
+        describe "announce" $ do
+          if tryAnnounce
+            then do
+              it "have valid response" $ do
+                withManager def $ \ mgr -> do
+--                  q    <- arbitrarySample
+                  let ih = maybe def L.head hashList
+                  let q = AnnounceQuery ih "-HS0003-203534.37420" 6000
+                          (Progress 0 0 0) Nothing Nothing (Just Started)
+                  info <- announce mgr trackerURI q
+                  validateInfo q info
+            else do
+              it "should fail with RequestFailed" $ do
+                withManager def $ \ mgr -> do
+                  q <- arbitrarySample
+                  announce mgr trackerURI q
+                    `shouldThrow` isNotResponding
+
+        describe "scrape" $ do
+          if tryScraping
+            then do
+              it "have valid response" $ do
+                withManager def $ \ mgr -> do
+                  xs <- scrape mgr trackerURI [def]
+                  L.length xs `shouldSatisfy` (>= 1)
+            else do
+              it "should fail with ScrapelessTracker" $ do
+                pending
+
+          when (not tryAnnounce) $ do
+            it "should fail with RequestFailed" $ do
+              withManager def $ \ mgr -> do
+                scrape mgr trackerURI [def]
+                  `shouldThrow` isNotResponding
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
new file mode 100644
index 00000000..73acb3fa
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Tracker.RPC.UDPSpec (spec, rpcOpts) where
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Exception
+import Control.Monad
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Test.Hspec
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.Tracker.Message as Message
+
+import Network.BitTorrent.Tracker.TestData
+import Network.BitTorrent.Tracker.MessageSpec hiding (spec)
+import Network.BitTorrent.Tracker.RPC.UDP
+
+
+validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
+validateInfo _ Message.Failure {} = error "validateInfo: failure"
+validateInfo AnnounceQuery {..}  AnnounceInfo {..} = do
+    respComplete    `shouldSatisfy` isJust
+    respIncomplete  `shouldSatisfy` isJust
+    respMinInterval `shouldSatisfy` isNothing
+    respWarning     `shouldSatisfy` isNothing
+    peerList `shouldSatisfy` L.all (isNothing . peerId)
+  where
+    peerList = getPeerList respPeers
+
+-- | Number of concurrent calls.
+rpcCount :: Int
+rpcCount = 100
+
+rpcOpts :: Options
+rpcOpts = def
+  { optMinTimeout = 1
+  , optMaxTimeout = 10
+  }
+
+isTimeoutExpired :: RpcException -> Bool
+isTimeoutExpired (TimeoutExpired _) = True
+isTimeoutExpired  _                 = False
+
+isSomeException :: SomeException -> Bool
+isSomeException _ = True
+
+isIOException :: IOException -> Bool
+isIOException _ = True
+
+spec :: Spec
+spec = parallel $ do
+  describe "newManager" $ do
+    it "should throw exception on zero optMaxPacketSize" $ do
+      let opts = def { optMaxPacketSize = 0 }
+      newManager opts `shouldThrow` isSomeException
+
+    it "should throw exception on zero optMinTimout" $ do
+      let opts = def { optMinTimeout = 0 }
+      newManager opts `shouldThrow` isSomeException
+
+    it "should throw exception on zero optMaxTimeout" $ do
+      let opts = def { optMaxTimeout = 0 }
+      newManager opts `shouldThrow` isSomeException
+
+    it "should throw exception on maxTimeout < minTimeout" $ do
+      let opts = def { optMinTimeout = 2, optMaxTimeout = 1 }
+      newManager opts `shouldThrow` isSomeException
+
+    it "should throw exception on zero optMultiplier" $ do
+      let opts = def { optMultiplier = 0 }
+      newManager opts `shouldThrow` isSomeException
+
+  describe "closeManager" $ do
+    it "unblock rpc calls" $ do
+      mgr <- newManager rpcOpts
+      _   <- forkIO $ do
+        threadDelay 10000000
+        closeManager mgr
+      q <- arbitrarySample
+      announce mgr (trackerURI badTracker) q `shouldThrow` (== ManagerClosed)
+
+    it "announce throw exception after manager closed" $ do
+      mgr <- newManager rpcOpts
+      closeManager mgr
+      q <- arbitrarySample
+      announce mgr (trackerURI badTracker) q `shouldThrow` isIOException
+
+    it "scrape throw exception after manager closed" $ do
+      mgr <- newManager rpcOpts
+      closeManager mgr
+      scrape mgr (trackerURI badTracker) [def] `shouldThrow` isIOException
+
+  describe "withManager" $ do
+    it "closesManager at exit" $ do
+      mgr <- withManager rpcOpts return
+      scrape mgr (trackerURI badTracker) [def] `shouldThrow` isSomeException
+
+  describe "RPC" $ do
+    describe "announce" $ do
+      it "must fail on bad scheme" $ do
+        withManager rpcOpts $ \ mgr -> do
+          q <- arbitrarySample
+          announce mgr "magnet://a.com" q
+            `shouldThrow` (== UnrecognizedScheme "magnet:")
+
+    describe "scrape" $ do
+      it "must fail on bad scheme" $ do
+        withManager rpcOpts $ \ mgr -> do
+          scrape mgr "magnet://a.com" []
+            `shouldThrow` (== UnrecognizedScheme "magnet:")
+
+    forM_ (L.filter isUdpTracker trackers) $ \ TrackerEntry {..} ->
+      context trackerName $ do
+
+        describe "announce" $ do
+          if tryAnnounce then do
+            it "have valid response" $ do
+              withManager rpcOpts $ \ mgr -> do
+                q <- arbitrarySample
+                announce mgr trackerURI q >>= validateInfo q
+          else do
+            it "should throw TimeoutExpired" $ do
+              withManager rpcOpts $ \ mgr -> do
+                q <- arbitrarySample
+                announce mgr trackerURI q `shouldThrow` isTimeoutExpired
+
+        describe "scrape" $ do
+          if tryScraping then do
+            it "have valid response" $ do
+              withManager rpcOpts $ \ mgr -> do
+                xs <- scrape mgr trackerURI [def]
+                L.length xs `shouldSatisfy` (>= 1)
+          else do
+            it "should throw TimeoutExpired" $ do
+              withManager rpcOpts $ \ mgr -> do
+                scrape mgr trackerURI [def] `shouldThrow` isTimeoutExpired
+
+        describe "Manager" $ do
+          when tryScraping $ do
+            it "should handle arbitrary intermixed concurrent queries" $ do
+              withManager rpcOpts $ \ mgr -> do
+                _ <- mapConcurrently (\ _ -> scrape mgr trackerURI [def]) [1..rpcCount]
+                return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
new file mode 100644
index 00000000..dfc13a1e
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.Tracker.RPCSpec (spec) where
+import Control.Applicative
+import Control.Monad
+import Data.Default
+import Data.List as L
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Tracker.RPC as RPC
+
+import           Network.BitTorrent.Tracker.TestData
+import           Network.BitTorrent.Tracker.MessageSpec hiding (spec)
+import qualified Network.BitTorrent.Tracker.RPC.UDPSpec as UDP (rpcOpts)
+
+
+instance Arbitrary SAnnounceQuery where
+  arbitrary = SAnnounceQuery <$> arbitrary <*> arbitrary
+                             <*> arbitrary <*> arbitrary
+
+rpcOpts :: Options
+rpcOpts = def
+  { optUdpRPC = UDP.rpcOpts
+  }
+
+matchUnrecognizedScheme :: String -> RpcException -> Bool
+matchUnrecognizedScheme x (UnrecognizedScheme scheme) = x == scheme
+matchUnrecognizedScheme _  _                          = False
+
+spec :: Spec
+spec = parallel $ do
+  describe "Manager" $ do
+    describe "newManager" $ do
+      it "" $ pending
+
+    describe "closeManager" $ do
+      it "" $ pending
+
+    describe "withManager" $ do
+      it "" $ pending
+
+  describe "RPC" $ do
+    describe "announce" $ do
+      it "must fail on bad uri scheme" $ do
+        withManager rpcOpts def $ \ mgr -> do
+          q    <- arbitrarySample
+          announce mgr "magnet://foo.bar" q
+            `shouldThrow` matchUnrecognizedScheme "magnet:"
+
+    describe "scrape" $ do
+      it "must fail on bad uri scheme" $ do
+        withManager rpcOpts def $ \ mgr -> do
+          scrape mgr "magnet://foo.bar" []
+            `shouldThrow` matchUnrecognizedScheme "magnet:"
+
+    forM_ trackers $ \ TrackerEntry {..} ->
+      context trackerName $ do
+
+        describe "announce" $ do
+          if tryAnnounce then do
+            it "have valid response" $ do
+              withManager rpcOpts def $ \ mgr -> do
+                q    <- arbitrarySample
+                _    <- announce mgr trackerURI q
+                return ()
+          else do
+            it "should throw exception" $ do
+              pending
+
+        describe "scrape" $ do
+          if tryScraping then do
+            it "have valid response" $ do
+              withManager rpcOpts def $ \ mgr -> do
+                xs <- scrape mgr trackerURI [def]
+                L.length xs `shouldSatisfy` (>= 1)
+          else do
+            it "should throw exception" $ do
+              pending
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
new file mode 100644
index 00000000..72936ee7
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
@@ -0,0 +1,61 @@
+module Network.BitTorrent.Tracker.SessionSpec (spec) where
+import Control.Monad
+import Data.Default
+import Data.List as L
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Tracker.Message
+import Network.BitTorrent.Tracker.List
+import Network.BitTorrent.Tracker.RPC
+import Network.BitTorrent.Tracker.Session
+
+import Config
+
+testSession :: Bool -> (Manager -> Session -> IO ()) -> IO ()
+testSession runEmpty action = do
+  t <- getTestTorrent
+  withManager def def $ \ m -> do
+    withSession m (idInfoHash (tInfoDict t)) (trackerList t) $ \ s ->
+      action m s
+
+    when runEmpty $ do
+      withSession m (idInfoHash (tInfoDict t)) def $ \ s ->
+        action m s
+
+spec :: Spec
+spec = do
+  describe "Session" $ do
+    it "start new session in paused state" $ do
+      testSession True $ \ _ s -> do
+        status <- getStatus s
+        status `shouldBe` Paused
+
+  describe "Query" $ do
+    it "change status after notify" $ do
+      testSession True $ \ m s -> do
+        notify m s Started
+        status <- getStatus s
+        status `shouldBe` Running
+
+        notify m s Stopped
+        stopped <- getStatus s
+        stopped `shouldBe` Paused
+
+    it "completed event do not change status" $ do
+      testSession True $ \ m s -> do
+        notify m s Completed
+        status <- getStatus s
+        status `shouldBe` Paused
+
+      testSession True $ \ m s -> do
+        notify m s Started
+        notify m s Completed
+        status <- getStatus s
+        status `shouldBe` Running
+
+    it "return non-empty list of peers" $ do
+      testSession False $ \ m s -> do
+        notify m s Started
+        peers <- askPeers m s
+        peers `shouldSatisfy` (not . L.null)
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs b/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
new file mode 100644
index 00000000..b95e2df4
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.Tracker.TestData
+       ( TrackerEntry (..)
+       , isUdpTracker
+       , isHttpTracker
+       , trackers
+       , badTracker
+       ) where
+
+import Data.Maybe
+import Data.String
+import Network.URI
+
+import Data.Torrent
+
+
+data TrackerEntry = TrackerEntry
+  { -- | May be used to show tracker name in test suite report.
+    trackerName :: String
+
+    -- | Announce uri of the tracker.
+  , trackerURI  :: URI
+
+    -- | Some trackers abadoned, so don't even try to announce.
+  , tryAnnounce :: Bool
+
+    -- | Some trackers do not support scraping, so we should not even
+    -- try to scrape them.
+  , tryScraping :: Bool
+
+    -- | Some trackers allow
+  , hashList    :: Maybe [InfoHash]
+  }
+
+isUdpTracker :: TrackerEntry -> Bool
+isUdpTracker TrackerEntry {..} = uriScheme trackerURI == "udp:"
+
+isHttpTracker :: TrackerEntry -> Bool
+isHttpTracker TrackerEntry {..} = uriScheme trackerURI == "http:"
+                               || uriScheme trackerURI == "https:"
+
+instance IsString URI where
+  fromString str = fromMaybe err $ parseURI str
+    where
+      err = error $ "fromString: bad URI " ++ show str
+
+trackerEntry :: URI -> TrackerEntry
+trackerEntry uri = TrackerEntry
+  { trackerName = maybe "<unknown>" uriRegName (uriAuthority uri)
+  , trackerURI  = uri
+  , tryAnnounce = False
+  , tryScraping = False
+  , hashList    = Nothing
+  }
+
+announceOnly :: String -> URI -> TrackerEntry
+announceOnly name uri = (trackerEntry uri)
+  { trackerName = name
+  , tryAnnounce = True
+  }
+
+announceScrape :: String -> URI -> TrackerEntry
+announceScrape name uri = (announceOnly name uri)
+  { tryScraping = True
+  }
+
+notWorking :: String -> URI -> TrackerEntry
+notWorking name uri = (trackerEntry uri)
+  { trackerName = name
+  }
+
+trackers :: [TrackerEntry]
+trackers =
+  [ (announceOnly "LinuxTracker"
+    "http://linuxtracker.org:2710/00000000000000000000000000000000/announce")
+    { hashList = Just ["1c82a95b9e02bf3db4183da072ad3ef656aacf0e"] -- debian 7
+    }
+
+  , (announceScrape "Arch" "http://tracker.archlinux.org:6969/announce")
+    { hashList = Just ["bc9ae647a3e6c3636de58535dd3f6360ce9f4621"]
+    }
+
+  , notWorking     "rarbg" "udp://9.rarbg.com:2710/announce"
+
+  , announceScrape "OpenBitTorrent" "udp://tracker.openbittorrent.com:80/announce"
+  , announceScrape "PublicBT"       "udp://tracker.publicbt.com:80/announce"
+  , notWorking     "OpenBitTorrent" "http://tracker.openbittorrent.com:80/announce"
+  , notWorking     "PublicBT"       "http://tracker.publicbt.com:80/announce"
+  ]
+
+badTracker :: TrackerEntry
+badTracker = notWorking "rarbg" "udp://9.rarbg.com:2710/announce"
\ No newline at end of file
diff --git a/bittorrent/tests/Network/KRPC/MessageSpec.hs b/bittorrent/tests/Network/KRPC/MessageSpec.hs
new file mode 100644
index 00000000..498ef679
--- /dev/null
+++ b/bittorrent/tests/Network/KRPC/MessageSpec.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.KRPC.MessageSpec (spec) where
+import Control.Applicative
+import Data.ByteString.Lazy as BL
+import Test.Hspec
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
+
+import Data.BEncode as BE
+import Network.KRPC.Message
+
+instance Arbitrary ErrorCode where
+  arbitrary = arbitraryBoundedEnum
+
+instance Arbitrary KError where
+  arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary KQuery where
+  arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary
+
+instance Arbitrary KResponse where
+  -- TODO: Abitrary instance for ReflectedIP
+  arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing
+
+instance Arbitrary KMessage where
+  arbitrary = frequency
+    [ (1, Q <$> arbitrary)
+    , (1, R <$> arbitrary)
+    , (1, E <$> arbitrary)
+    ]
+
+spec :: Spec
+spec = do
+  describe "error message" $ do
+    it "properly bencoded (iso)" $ property $ \ ke ->
+      BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError)
+
+    it "properly bencoded" $ do
+      BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee"
+        `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa")
+
+      BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee"
+        `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb")
+
+      BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee"
+        `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc")
+
+      BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee"
+        `shouldBe` Right
+          (KError MethodUnknown "Attempt to call unknown method" "dd")
+
+  describe "query message" $ do
+    it "properly bencoded (iso)" $ property $ \ kq ->
+      BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery)
+
+    it "properly bencoded" $ do
+      BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe`
+        Right (KQuery (BList []) "ping" "aa")
+
+
+  describe "response message" $ do
+    it "properly bencoded (iso)" $ property $ \ kr ->
+      BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse)
+
+    it "properly bencoded" $ do
+      BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe`
+        Right (KResponse (BList []) "aa" Nothing)
+
+  describe "generic message" $ do
+    it "properly bencoded (iso)" $ property $ \ km ->
+      BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage)
diff --git a/bittorrent/tests/Network/KRPC/MethodSpec.hs b/bittorrent/tests/Network/KRPC/MethodSpec.hs
new file mode 100644
index 00000000..c1c58282
--- /dev/null
+++ b/bittorrent/tests/Network/KRPC/MethodSpec.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+module Network.KRPC.MethodSpec where
+import Control.Applicative
+import Data.BEncode
+import Data.ByteString as BS
+import Data.Typeable
+import Network.KRPC
+import Test.Hspec
+
+
+data Ping = Ping
+  deriving (Show, Eq, Typeable)
+
+instance BEncode Ping where
+  toBEncode Ping = toBEncode ()
+  fromBEncode b  = Ping <$ (fromBEncode b :: Result ())
+
+instance KRPC Ping Ping
+
+ping :: Monad h => Handler h
+ping = handler $ \ _ Ping -> return Ping
+
+newtype Echo a = Echo a
+  deriving (Show, Eq, BEncode, Typeable)
+
+echo :: Monad h => Handler h
+echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString))
+
+instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a)
+
+spec :: Spec
+spec = do
+  describe "ping method" $ do
+    it "name is ping" $ do
+      (method :: Method Ping Ping) `shouldBe` "ping"
+
+    it "has pretty Show instance" $ do
+      show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping"
+
+  describe "echo method" $ do
+    it "is overloadable" $ do
+      (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int"
+      (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool"
+
+    it "has pretty Show instance" $ do
+      show (method :: Method (Echo Int) (Echo Int))
+        `shouldBe` "echo int :: Echo Int -> Echo Int"
\ No newline at end of file
diff --git a/bittorrent/tests/Network/KRPCSpec.hs b/bittorrent/tests/Network/KRPCSpec.hs
new file mode 100644
index 00000000..eabcc817
--- /dev/null
+++ b/bittorrent/tests/Network/KRPCSpec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.KRPCSpec (spec) where
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Network.KRPC
+import Network.KRPC.MethodSpec hiding (spec)
+import Test.Hspec
+
+servAddr :: SockAddr
+servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127)
+
+handlers :: [Handler IO]
+handlers =
+ [ handler $ \ _ Ping     -> return Ping
+ , handler $ \ _ (Echo a) -> return (Echo (a :: Bool))
+ , handler $ \ _ (Echo a) -> return (Echo (a :: Int))
+ ]
+
+instance MonadLogger IO where
+  monadLoggerLog _ _ _ _ = return ()
+
+opts :: Options
+opts = def { optQueryTimeout = 1 }
+
+spec :: Spec
+spec = do
+  let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int)
+      qr = query
+
+  describe "manager" $ do
+    it "is active until closeManager called" $ do
+      m <- newManager opts servAddr []
+      isActive m `shouldReturn` True
+      closeManager m
+      isActive m `shouldReturn` False
+
+  describe "query" $ do
+    it "run handlers" $ do
+      let int = 0xabcd :: Int
+      (withManager opts servAddr handlers $ runReaderT $ do
+         listen
+         query servAddr (Echo int))
+       `shouldReturn` Echo int
+
+    it "count transactions properly" $ do
+      (withManager opts servAddr handlers $ runReaderT $ do
+         listen
+         _ <- qr servAddr (Echo 0xabcd)
+         _ <- qr servAddr (Echo 0xabcd)
+         getQueryCount
+       )
+        `shouldReturn` 2
+
+    it "throw timeout exception" $ do
+      (withManager opts servAddr handlers $ runReaderT $ do
+         qr servAddr (Echo 0xabcd)
+       )
+        `shouldThrow` (== TimeoutExpired)
diff --git a/bittorrent/tests/Readme.md b/bittorrent/tests/Readme.md
new file mode 100644
index 00000000..7a9d8914
--- /dev/null
+++ b/bittorrent/tests/Readme.md
@@ -0,0 +1,4 @@
+Prerequisites
+=============
+
+To run test suite you need rtorrent and screen installed.
diff --git a/bittorrent/tests/Spec.hs b/bittorrent/tests/Spec.hs
new file mode 100644
index 00000000..b4e92e75
--- /dev/null
+++ b/bittorrent/tests/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
diff --git a/bittorrent/tests/System/Torrent/FileMapSpec.hs b/bittorrent/tests/System/Torrent/FileMapSpec.hs
new file mode 100644
index 00000000..29252925
--- /dev/null
+++ b/bittorrent/tests/System/Torrent/FileMapSpec.hs
@@ -0,0 +1,116 @@
+-- this is test string used in the 'spec' --- don't touch me!
+module System.Torrent.FileMapSpec (spec) where
+
+import Control.Monad.Loops
+import Data.List as L
+import Data.ByteString.Lazy as BL
+import System.Directory
+import System.FilePath
+import System.IO.Temp
+import Test.Hspec
+
+import Data.Torrent
+import System.Torrent.FileMap as FM
+
+
+withLayout :: (FileLayout FileSize -> IO ()) -> IO ()
+withLayout f = do
+  tmp <- getTemporaryDirectory
+  withTempDirectory tmp "bittorrentTestDir" $ \dir ->
+    f [ (dir </> "a", 2)
+      , (dir </> "b", 3)
+      , (dir </> "c", 2)
+      ] `seq` return ()
+
+spec :: Spec
+spec = do
+  describe "mmapFiles" $ do
+    it "creates new files" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadWriteEx layout
+      unmapFiles m
+
+      (doesFileExist . fst) `allM` layout
+        `shouldReturn` True
+
+  describe "size" $ do
+    it "is equal to the layout size" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadOnly layout
+      FM.size m `shouldBe` L.sum (L.map snd layout)
+      unmapFiles m
+
+  describe "readBytes" $ do
+    it "read from files" $ do
+      let thisFile = [("tests/System/Torrent/FileMapSpec.hs", 15)]
+      m <- mmapFiles ReadOnly thisFile
+      readBytes 3 15 m `shouldReturn` "this is test"
+      unmapFiles m
+
+    it "ignore underflow reads" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadOnly layout
+      readBytes (-1) 1  m `shouldReturn` ""
+      readBytes (-5) 12 m `shouldReturn` ""
+      unmapFiles m
+
+    it "crop overflow reads" $ withLayout $ \layout -> do
+      _m <- mmapFiles ReadWrite layout
+      writeBytes 5 "cc" _m
+      unmapFiles _m
+
+      m <- mmapFiles ReadOnly layout
+      readBytes 5 10 m `shouldReturn` "cc"
+      unmapFiles m
+
+  describe "writeBytes" $ do
+    it "writes to files" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadWriteEx layout
+      writeBytes 0 "a"   m
+      readBytes  0 1 m `shouldReturn` "a"
+      writeBytes 1 "ab"  m
+      readBytes  1 2 m `shouldReturn` "ab"
+      writeBytes 3 "b"   m
+      readBytes  3 1 m `shouldReturn` "b"
+      writeBytes 4 "bc"  m
+      readBytes  4 2 m `shouldReturn` "bc"
+      writeBytes 6 "c"   m
+      readBytes  6 1 m `shouldReturn` "c"
+      readBytes  0 7 m `shouldReturn` "aabbbcc"
+      unmapFiles m
+
+      BL.readFile (fst (layout !! 0)) `shouldReturn` "aa"
+      BL.readFile (fst (layout !! 1)) `shouldReturn` "bbb"
+      BL.readFile (fst (layout !! 2)) `shouldReturn` "cc"
+
+    let max_page_size = 4 * 1024 * 1024
+    let long_bs = BL.replicate (fromIntegral max_page_size) 0
+
+    it "no buffer underflow errors" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadWrite layout
+      writeBytes (1 - max_page_size) long_bs m
+      unmapFiles m
+
+    it "no buffer overflow errors" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadWrite layout
+      writeBytes 5 long_bs m
+      unmapFiles m
+
+    it "ignore underflow writes" $ withLayout $ \layout -> do
+      _m <- mmapFiles ReadWrite layout
+      writeBytes 0 "aa" _m
+      unmapFiles _m
+
+      m <- mmapFiles ReadWrite layout
+      writeBytes (-1) "hhh" m
+      unmapFiles m
+      BL.readFile (fst (layout !! 0)) `shouldReturn` "aa"
+
+    it "crop overflow writes" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadWrite layout
+      writeBytes 5 "ddddddddd" m
+      unmapFiles m
+      BL.readFile (fst (layout !! 2)) `shouldReturn` "dd"
+
+  describe "from/to lazy bytestring" $ do
+    it "isomorphic to lazy bytestring" $ withLayout $ \layout -> do
+      m <- mmapFiles ReadOnly layout
+      fromLazyByteString (toLazyByteString m) `shouldBe` m
+      unmapFiles m
diff --git a/bittorrent/tests/System/Torrent/StorageSpec.hs b/bittorrent/tests/System/Torrent/StorageSpec.hs
new file mode 100644
index 00000000..b5e49078
--- /dev/null
+++ b/bittorrent/tests/System/Torrent/StorageSpec.hs
@@ -0,0 +1,91 @@
+module System.Torrent.StorageSpec (spec) where
+import Data.ByteString.Lazy as BL
+import Data.Conduit as C
+import Data.Conduit.List as C
+import System.FilePath
+import System.Directory
+import System.IO.Unsafe
+import Test.Hspec
+
+import Data.Torrent
+import Network.BitTorrent.Exchange.Bitfield as BF
+import System.Torrent.Storage
+
+
+layout :: FileLayout FileSize
+layout =
+  [ (dir </> "_a", 20)
+  , (dir </> "_b", 50)
+  , (dir </> "_c", 100)
+  , (dir </> "_d", 5)
+  ]
+  where
+    dir = unsafePerformIO $ getTemporaryDirectory
+
+createLayout :: IO ()
+createLayout = withStorage ReadWriteEx 1 layout (const (return ()))
+
+psize :: PieceSize
+psize = 16
+
+pcount :: PieceCount
+pcount = 11
+
+spec :: Spec
+spec = before createLayout $ do
+  describe "writePiece" $ do
+    it "should fail gracefully on write operation in RO mode" $ do
+      withStorage ReadOnly 1 layout $ \ s ->
+        writePiece (Piece 0 "a") s `shouldThrow` (== StorageIsRO)
+
+    it "should fail if piece size do not match" $ do
+      withStorage ReadWrite 1 layout $ \ s ->
+        writePiece (Piece 0 "") s `shouldThrow` (== InvalidSize 0)
+
+    it "should fail on negative index" $ do
+      withStorage ReadWrite 1 layout $ \ s ->
+        writePiece (Piece (-1) "") s `shouldThrow` (== InvalidIndex (-1))
+
+    it "should fail on out of upper bound index" $ do
+      withStorage ReadWrite 100 layout $ \ s -> do
+        let bs = BL.replicate 100 0
+        writePiece (Piece 0 bs) s
+
+        let bs' = BL.replicate 75 0
+        writePiece (Piece 1 bs') s
+
+        writePiece (Piece 2 bs') s `shouldThrow` (== InvalidIndex 2)
+
+  describe "readPiece" $ do
+    it "should fail on negative index" $
+      withStorage ReadOnly 1 layout $ \ s ->
+        readPiece (-1) s `shouldThrow` (== InvalidIndex (-1))
+
+    it "should fail on out of upper bound index" $ do
+      withStorage ReadOnly 100 layout $ \ s -> do
+        _ <- readPiece 1 s
+        readPiece 2 s `shouldThrow` (== InvalidIndex 2)
+
+  describe "sourceStorage" $ do
+    it "should source all chunks" $ do
+      withStorage ReadOnly psize layout $ \ s -> do
+        n <- sourceStorage s $$ C.fold (\ n _ -> succ n) 0
+        n `shouldBe` pcount
+
+  -- this test should fail if 'sourceStorage' test fail
+  describe "sinkStorage" $ do
+    it "should write all chunks" $ do
+      let byteVal       = 0
+      let bzeroPiece  p = p { pieceData = BL.replicate (BL.length (pieceData p)) byteVal }
+      let isZeroPiece p = (== byteVal) `BL.all` pieceData p
+
+      withStorage ReadWrite psize layout $ \ s -> do
+        sourceStorage s $= C.map bzeroPiece $$ sinkStorage s
+        b <- sourceStorage s $$ C.fold (\ b p -> b && isZeroPiece p) True
+        b `shouldBe` True
+
+  describe "genPieceInfo" $ do
+    it "" $ do
+      withStorage ReadWrite psize layout $ \ s -> do
+        bf <- genPieceInfo s >>= getBitfield s
+        bf `shouldSatisfy` BF.full
\ No newline at end of file
diff --git a/c b/c
new file mode 100755
index 00000000..ed905d3d
--- /dev/null
+++ b/c
@@ -0,0 +1,8 @@
+#!/bin/sh
+compile=ghc
+defs="-DBENCODE_AESON -DTHREAD_DEBUG"
+hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
+cbits="cbits/*.c"
+# -Wno-typed-holes
+includes="-isrc -icryptonite-backport"
+$compile -Wmissing-signatures -fdefer-typed-holes -freverse-errors $hide $includes -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
diff --git a/cbits/cryptonite_bitfn.h b/cbits/cryptonite_bitfn.h
new file mode 100644
index 00000000..3a00dd8a
--- /dev/null
+++ b/cbits/cryptonite_bitfn.h
@@ -0,0 +1,253 @@
+/*
+ * Copyright (C) 2006-2014 Vincent Hanquez <vincent@snarc.org>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#ifndef BITFN_H
+#define BITFN_H
+#include <stdint.h>
+
+#ifndef NO_INLINE_ASM
+/**********************************************************/
+# if (defined(__i386__))
+#  define ARCH_HAS_SWAP32
+static inline uint32_t bitfn_swap32(uint32_t a)
+{
+        asm ("bswap %0" : "=r" (a) : "0" (a));
+        return a;
+}
+/**********************************************************/
+# elif (defined(__arm__))
+#  define ARCH_HAS_SWAP32
+static inline uint32_t bitfn_swap32(uint32_t a)
+{
+        uint32_t tmp = a;
+        asm volatile ("eor %1, %0, %0, ror #16\n"
+                      "bic %1, %1, #0xff0000\n"
+                      "mov %0, %0, ror #8\n"
+                      "eor %0, %0, %1, lsr #8\n"
+                     : "=r" (a), "=r" (tmp) : "0" (a), "1" (tmp));
+        return a;
+}
+/**********************************************************/
+# elif defined(__x86_64__)
+#  define ARCH_HAS_SWAP32
+#  define ARCH_HAS_SWAP64
+static inline uint32_t bitfn_swap32(uint32_t a)
+{
+        asm ("bswap %0" : "=r" (a) : "0" (a));
+        return a;
+}
+
+static inline uint64_t bitfn_swap64(uint64_t a)
+{
+        asm ("bswap %0" : "=r" (a) : "0" (a));
+        return a;
+}
+
+# endif
+#endif /* NO_INLINE_ASM */
+/**********************************************************/
+
+#ifndef ARCH_HAS_ROL32
+static inline uint32_t rol32(uint32_t word, uint32_t shift)
+{
+        return (word << shift) | (word >> (32 - shift));
+}
+#endif
+
+#ifndef ARCH_HAS_ROR32
+static inline uint32_t ror32(uint32_t word, uint32_t shift)
+{
+        return (word >> shift) | (word << (32 - shift));
+}
+#endif
+
+#ifndef ARCH_HAS_ROL64
+static inline uint64_t rol64(uint64_t word, uint32_t shift)
+{
+        return (word << shift) | (word >> (64 - shift));
+}
+#endif
+
+#ifndef ARCH_HAS_ROR64
+static inline uint64_t ror64(uint64_t word, uint32_t shift)
+{
+        return (word >> shift) | (word << (64 - shift));
+}
+#endif
+
+#ifndef ARCH_HAS_SWAP32
+static inline uint32_t bitfn_swap32(uint32_t a)
+{
+        return (a << 24) | ((a & 0xff00) << 8) | ((a >> 8) & 0xff00) | (a >> 24);
+}
+#endif
+
+#ifndef ARCH_HAS_ARRAY_SWAP32
+static inline void array_swap32(uint32_t *d, uint32_t *s, uint32_t nb)
+{
+        while (nb--)
+                *d++ = bitfn_swap32(*s++);
+}
+#endif
+
+#ifndef ARCH_HAS_SWAP64
+static inline uint64_t bitfn_swap64(uint64_t a)
+{
+        return ((uint64_t) bitfn_swap32((uint32_t) (a >> 32))) |
+               (((uint64_t) bitfn_swap32((uint32_t) a)) << 32);
+}
+#endif
+
+#ifndef ARCH_HAS_ARRAY_SWAP64
+static inline void array_swap64(uint64_t *d, uint64_t *s, uint32_t nb)
+{
+        while (nb--)
+                *d++ = bitfn_swap64(*s++);
+}
+#endif
+
+#ifndef ARCH_HAS_MEMORY_ZERO
+static inline void memory_zero(void *ptr, uint32_t len)
+{
+        uint32_t *ptr32 = ptr;
+        uint8_t *ptr8;
+        int i;
+
+        for (i = 0; i < len / 4; i++)
+                *ptr32++ = 0;
+        if (len % 4) {
+                ptr8 = (uint8_t *) ptr32;
+                for (i = len % 4; i >= 0; i--)
+                        ptr8[i] = 0;
+        }
+}
+#endif
+
+#ifndef ARCH_HAS_ARRAY_COPY32
+static inline void array_copy32(uint32_t *d, uint32_t *s, uint32_t nb)
+{
+        while (nb--) *d++ = *s++;
+}
+#endif
+
+#ifndef ARCH_HAS_ARRAY_XOR32
+static inline void array_xor32(uint32_t *d, uint32_t *s, uint32_t nb)
+{
+        while (nb--) *d++ ^= *s++;
+}
+#endif
+
+#ifndef ARCH_HAS_ARRAY_COPY64
+static inline void array_copy64(uint64_t *d, uint64_t *s, uint32_t nb)
+{
+        while (nb--) *d++ = *s++;
+}
+#endif
+
+#ifdef __GNUC__
+#define bitfn_ntz(n) __builtin_ctz(n)
+#else
+#error "define ntz for your platform"
+#endif
+
+#ifdef __MINGW32__
+  # define LITTLE_ENDIAN 1234
+  # define BYTE_ORDER    LITTLE_ENDIAN
+#elif defined(__FreeBSD__) || defined(__DragonFly__) || defined(__NetBSD__)
+  # include <sys/endian.h>
+#elif defined(__OpenBSD__) || defined(__SVR4)
+  # include <sys/types.h>
+#elif defined(__APPLE__)
+  # include <machine/endian.h>
+#elif defined( BSD ) && ( BSD >= 199103 )
+  # include <machine/endian.h>
+#elif defined( __QNXNTO__ ) && defined( __LITTLEENDIAN__ )
+  # define LITTLE_ENDIAN 1234
+  # define BYTE_ORDER    LITTLE_ENDIAN
+#elif defined( __QNXNTO__ ) && defined( __BIGENDIAN__ )
+  # define BIG_ENDIAN 1234
+  # define BYTE_ORDER    BIG_ENDIAN
+#elif defined( _AIX )
+  # include <sys/machine.h>
+#else
+  # include <endian.h>
+#endif
+/* big endian to cpu */
+#if LITTLE_ENDIAN == BYTE_ORDER
+
+# define be32_to_cpu(a) bitfn_swap32(a)
+# define cpu_to_be32(a) bitfn_swap32(a)
+# define le32_to_cpu(a) (a)
+# define cpu_to_le32(a) (a)
+# define be64_to_cpu(a) bitfn_swap64(a)
+# define cpu_to_be64(a) bitfn_swap64(a)
+# define le64_to_cpu(a) (a)
+# define cpu_to_le64(a) (a)
+
+# define cpu_to_le32_array(d, s, l) array_copy32(d, s, l)
+# define le32_to_cpu_array(d, s, l) array_copy32(d, s, l)
+# define cpu_to_be32_array(d, s, l) array_swap32(d, s, l)
+# define be32_to_cpu_array(d, s, l) array_swap32(d, s, l)
+
+# define cpu_to_le64_array(d, s, l) array_copy64(d, s, l)
+# define le64_to_cpu_array(d, s, l) array_copy64(d, s, l)
+# define cpu_to_be64_array(d, s, l) array_swap64(d, s, l)
+# define be64_to_cpu_array(d, s, l) array_swap64(d, s, l)
+
+# define ror32_be(a, s) rol32(a, s)
+# define rol32_be(a, s) ror32(a, s)
+
+# define ARCH_IS_LITTLE_ENDIAN
+
+#elif BIG_ENDIAN == BYTE_ORDER
+
+# define be32_to_cpu(a) (a)
+# define cpu_to_be32(a) (a)
+# define be64_to_cpu(a) (a)
+# define cpu_to_be64(a) (a)
+# define le64_to_cpu(a) bitfn_swap64(a)
+# define cpu_to_le64(a) bitfn_swap64(a)
+# define le32_to_cpu(a) bitfn_swap32(a)
+# define cpu_to_le32(a) bitfn_swap32(a)
+
+# define cpu_to_le32_array(d, s, l) array_swap32(d, s, l)
+# define le32_to_cpu_array(d, s, l) array_swap32(d, s, l)
+# define cpu_to_be32_array(d, s, l) array_copy32(d, s, l)
+# define be32_to_cpu_array(d, s, l) array_copy32(d, s, l)
+
+# define cpu_to_le64_array(d, s, l) array_swap64(d, s, l)
+# define le64_to_cpu_array(d, s, l) array_swap64(d, s, l)
+# define cpu_to_be64_array(d, s, l) array_copy64(d, s, l)
+# define be64_to_cpu_array(d, s, l) array_copy64(d, s, l)
+
+# define ror32_be(a, s) ror32(a, s)
+# define rol32_be(a, s) rol32(a, s)
+
+# define ARCH_IS_BIG_ENDIAN
+
+#else
+# error "endian not supported"
+#endif
+
+#endif /* !BITFN_H */
diff --git a/cbits/cryptonite_salsa.c b/cbits/cryptonite_salsa.c
new file mode 100644
index 00000000..0bd96607
--- /dev/null
+++ b/cbits/cryptonite_salsa.c
@@ -0,0 +1,297 @@
+/*
+ * Copyright (c) 2014-2015 Vincent Hanquez <vincent@snarc.org>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. Neither the name of the author nor the names of his contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.
+ */
+
+#include <stdint.h>
+#include <string.h>
+#include <stdio.h>
+#include "cryptonite_salsa.h"
+#include "cryptonite_bitfn.h"
+
+static const uint8_t sigma[16] = "expand 32-byte k";
+static const uint8_t tau[16] = "expand 16-byte k";
+
+#define QR(a,b,c,d) \
+        b ^= rol32(a+d, 7); \
+        c ^= rol32(b+a, 9); \
+        d ^= rol32(c+b, 13); \
+        a ^= rol32(d+c, 18);
+
+#define ALIGNED64(PTR) \
+        (((uintptr_t)(const void *)(PTR)) % 8 == 0)
+
+#define SALSA_CORE_LOOP \
+        for (i = rounds; i > 0; i -= 2) { \
+                QR (x0,x4,x8,x12); \
+                QR (x5,x9,x13,x1); \
+                QR (x10,x14,x2,x6); \
+                QR (x15,x3,x7,x11); \
+                QR (x0,x1,x2,x3); \
+                QR (x5,x6,x7,x4); \
+                QR (x10,x11,x8,x9); \
+                QR (x15,x12,x13,x14); \
+        }
+
+static inline uint32_t load32(const uint8_t *p)
+{
+        return le32_to_cpu(*((uint32_t *) p));
+}
+
+static void salsa_core(int rounds, block *out, const cryptonite_salsa_state *in)
+{
+        uint32_t x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15;
+        int i;
+
+        x0 = in->d[0]; x1 = in->d[1]; x2 = in->d[2]; x3 = in->d[3];
+        x4 = in->d[4]; x5 = in->d[5]; x6 = in->d[6]; x7 = in->d[7];
+        x8 = in->d[8]; x9 = in->d[9]; x10 = in->d[10]; x11 = in->d[11];
+        x12 = in->d[12]; x13 = in->d[13]; x14 = in->d[14]; x15 = in->d[15];
+
+        SALSA_CORE_LOOP;
+
+        x0 += in->d[0]; x1 += in->d[1]; x2 += in->d[2]; x3 += in->d[3];
+        x4 += in->d[4]; x5 += in->d[5]; x6 += in->d[6]; x7 += in->d[7];
+        x8 += in->d[8]; x9 += in->d[9]; x10 += in->d[10]; x11 += in->d[11];
+        x12 += in->d[12]; x13 += in->d[13]; x14 += in->d[14]; x15 += in->d[15];
+
+        out->d[0] = cpu_to_le32(x0);
+        out->d[1] = cpu_to_le32(x1);
+        out->d[2] = cpu_to_le32(x2);
+        out->d[3] = cpu_to_le32(x3);
+        out->d[4] = cpu_to_le32(x4);
+        out->d[5] = cpu_to_le32(x5);
+        out->d[6] = cpu_to_le32(x6);
+        out->d[7] = cpu_to_le32(x7);
+        out->d[8] = cpu_to_le32(x8);
+        out->d[9] = cpu_to_le32(x9);
+        out->d[10] = cpu_to_le32(x10);
+        out->d[11] = cpu_to_le32(x11);
+        out->d[12] = cpu_to_le32(x12);
+        out->d[13] = cpu_to_le32(x13);
+        out->d[14] = cpu_to_le32(x14);
+        out->d[15] = cpu_to_le32(x15);
+}
+
+void cryptonite_salsa_core_xor(int rounds, block *out, block *in)
+{
+        uint32_t x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15;
+        int i;
+
+#define LOAD(i) (out->d[i] ^= in->d[i])
+        x0 = LOAD(0); x1 = LOAD(1); x2 = LOAD(2); x3 = LOAD(3);
+        x4 = LOAD(4); x5 = LOAD(5); x6 = LOAD(6); x7 = LOAD(7);
+        x8 = LOAD(8); x9 = LOAD(9); x10 = LOAD(10); x11 = LOAD(11);
+        x12 = LOAD(12); x13 = LOAD(13); x14 = LOAD(14); x15 = LOAD(15);
+#undef LOAD
+
+        SALSA_CORE_LOOP;
+
+        out->d[0] += x0; out->d[1] += x1; out->d[2] += x2; out->d[3] += x3;
+        out->d[4] += x4; out->d[5] += x5; out->d[6] += x6; out->d[7] += x7;
+        out->d[8] += x8; out->d[9] += x9; out->d[10] += x10; out->d[11] += x11;
+        out->d[12] += x12; out->d[13] += x13; out->d[14] += x14; out->d[15] += x15;
+}
+
+/* only 2 valid values for keylen are 256 (32) and 128 (16) */
+void cryptonite_salsa_init_core(cryptonite_salsa_state *st,
+                                uint32_t keylen, const uint8_t *key,
+                                uint32_t ivlen, const uint8_t *iv)
+{
+        const uint8_t *constants = (keylen == 32) ? sigma : tau;
+        int i;
+
+        st->d[0] = load32(constants + 0);
+        st->d[5] = load32(constants + 4);
+        st->d[10] = load32(constants + 8);
+        st->d[15] = load32(constants + 12);
+
+        st->d[1] = load32(key + 0);
+        st->d[2] = load32(key + 4);
+        st->d[3] = load32(key + 8);
+        st->d[4] = load32(key + 12);
+        /* we repeat the key on 128 bits */
+        if (keylen == 32)
+                key += 16;
+        st->d[11] = load32(key + 0);
+        st->d[12] = load32(key + 4);
+        st->d[13] = load32(key + 8);
+        st->d[14] = load32(key + 12);
+
+        st->d[9] = 0;
+        switch (ivlen) {
+        case 8:
+                st->d[6] = load32(iv + 0);
+                st->d[7] = load32(iv + 4);
+                st->d[8] = 0;
+                break;
+        case 12:
+                st->d[6] = load32(iv + 0);
+                st->d[7] = load32(iv + 4);
+                st->d[8] = load32(iv + 8);
+        default:
+                return;
+        }
+}
+
+void cryptonite_salsa_init(cryptonite_salsa_context *ctx, uint8_t nb_rounds,
+                           uint32_t keylen, const uint8_t *key,
+                           uint32_t ivlen, const uint8_t *iv)
+{
+        memset(ctx, 0, sizeof(*ctx));
+        ctx->nb_rounds = nb_rounds;
+        cryptonite_salsa_init_core(&ctx->st, keylen, key, ivlen, iv);
+}
+
+void cryptonite_salsa_combine(uint8_t *dst, cryptonite_salsa_context *ctx, const uint8_t *src, uint32_t bytes)
+{
+        block out;
+        cryptonite_salsa_state *st;
+        int i;
+
+        if (!bytes)
+                return;
+
+        /* xor the previous buffer first (if any) */
+        if (ctx->prev_len > 0) {
+                int to_copy = (ctx->prev_len < bytes) ? ctx->prev_len : bytes;
+                for (i = 0; i < to_copy; i++)
+                        dst[i] = src[i] ^ ctx->prev[ctx->prev_ofs+i];
+                memset(ctx->prev + ctx->prev_ofs, 0, to_copy);
+                ctx->prev_len -= to_copy;
+                ctx->prev_ofs += to_copy;
+                src += to_copy;
+                dst += to_copy;
+                bytes -= to_copy;
+        }
+
+        if (bytes == 0)
+                return;
+
+        st = &ctx->st;
+
+        /* xor new 64-bytes chunks and store the left over if any */
+        for (; bytes >= 64; bytes -= 64, src += 64, dst += 64) {
+                /* generate new chunk and update state */
+                salsa_core(ctx->nb_rounds, &out, st);
+                st->d[8] += 1;
+                if (st->d[8] == 0)
+                        st->d[9] += 1;
+
+                for (i = 0; i < 64; ++i)
+                        dst[i] = src[i] ^ out.b[i];
+        }
+
+        if (bytes > 0) {
+                /* generate new chunk and update state */
+                salsa_core(ctx->nb_rounds, &out, st);
+                st->d[8] += 1;
+                if (st->d[8] == 0)
+                        st->d[9] += 1;
+
+                /* xor as much as needed */
+                for (i = 0; i < bytes; i++)
+                        dst[i] = src[i] ^ out.b[i];
+                
+                /* copy the left over in the buffer */
+                ctx->prev_len = 64 - bytes;
+                ctx->prev_ofs = i;
+                for (; i < 64; i++) {
+                        ctx->prev[i] = out.b[i];
+                }
+        }
+}
+
+void cryptonite_salsa_generate(uint8_t *dst, cryptonite_salsa_context *ctx, uint32_t bytes)
+{
+        cryptonite_salsa_state *st;
+        block out;
+        int i;
+
+        if (!bytes)
+                return;
+
+        /* xor the previous buffer first (if any) */
+        if (ctx->prev_len > 0) {
+                int to_copy = (ctx->prev_len < bytes) ? ctx->prev_len : bytes;
+                for (i = 0; i < to_copy; i++)
+                        dst[i] = ctx->prev[ctx->prev_ofs+i];
+                memset(ctx->prev + ctx->prev_ofs, 0, to_copy);
+                ctx->prev_len -= to_copy;
+                ctx->prev_ofs += to_copy;
+                dst += to_copy;
+                bytes -= to_copy;
+        }
+
+        if (bytes == 0)
+                return;
+
+        st = &ctx->st;
+
+        if (ALIGNED64(dst)) {
+                /* xor new 64-bytes chunks and store the left over if any */
+                for (; bytes >= 64; bytes -= 64, dst += 64) {
+                        /* generate new chunk and update state */
+                        salsa_core(ctx->nb_rounds, (block *) dst, st);
+                        st->d[8] += 1;
+                        if (st->d[8] == 0)
+                                st->d[9] += 1;
+                }
+        } else {
+                /* xor new 64-bytes chunks and store the left over if any */
+                for (; bytes >= 64; bytes -= 64, dst += 64) {
+                        /* generate new chunk and update state */
+                        salsa_core(ctx->nb_rounds, &out, st);
+                        st->d[8] += 1;
+                        if (st->d[8] == 0)
+                                st->d[9] += 1;
+
+                        for (i = 0; i < 64; ++i)
+                                dst[i] = out.b[i];
+                }
+        }
+
+        if (bytes > 0) {
+                /* generate new chunk and update state */
+                salsa_core(ctx->nb_rounds, &out, st);
+                st->d[8] += 1;
+                if (st->d[8] == 0)
+                        st->d[9] += 1;
+
+                /* xor as much as needed */
+                for (i = 0; i < bytes; i++)
+                        dst[i] = out.b[i];
+                
+                /* copy the left over in the buffer */
+                ctx->prev_len = 64 - bytes;
+                ctx->prev_ofs = i;
+                for (; i < 64; i++)
+                        ctx->prev[i] = out.b[i];
+        }
+}
+
diff --git a/cbits/cryptonite_salsa.h b/cbits/cryptonite_salsa.h
new file mode 100644
index 00000000..33e9cda9
--- /dev/null
+++ b/cbits/cryptonite_salsa.h
@@ -0,0 +1,57 @@
+/*
+ * Copyright (c) 2014 Vincent Hanquez <vincent@snarc.org>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. Neither the name of the author nor the names of his contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.
+ */
+#ifndef CRYPTONITE_SALSA
+#define CRYPTONITE_SALSA
+
+typedef union {
+        uint64_t q[8];
+        uint32_t d[16];
+        uint8_t  b[64];
+} block;
+
+typedef block cryptonite_salsa_state;
+
+typedef struct {
+        cryptonite_salsa_state st;
+        uint8_t prev[64];
+        uint8_t prev_ofs;
+        uint8_t prev_len;
+        uint8_t nb_rounds;
+} cryptonite_salsa_context;
+
+/* for scrypt */
+void cryptonite_salsa_core_xor(int rounds, block *out, block *in);
+
+void cryptonite_salsa_init_core(cryptonite_salsa_state *st, uint32_t keylen, const uint8_t *key, uint32_t ivlen, const uint8_t *iv);
+void cryptonite_salsa_init(cryptonite_salsa_context *ctx, uint8_t nb_rounds, uint32_t keylen, const uint8_t *key, uint32_t ivlen, const uint8_t *iv);
+void cryptonite_salsa_combine(uint8_t *dst, cryptonite_salsa_context *st, const uint8_t *src, uint32_t bytes);
+void cryptonite_salsa_generate(uint8_t *dst, cryptonite_salsa_context *st, uint32_t bytes);
+
+#endif
diff --git a/cbits/cryptonite_xsalsa.c b/cbits/cryptonite_xsalsa.c
new file mode 100644
index 00000000..6718cd7d
--- /dev/null
+++ b/cbits/cryptonite_xsalsa.c
@@ -0,0 +1,80 @@
+/*
+ * Copyright (c) 2016 Brandon Hamilton <brandon.hamilton@gmail.com>
+ * 
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. Neither the name of the author nor the names of his contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.
+ */
+#include <stdint.h>
+#include <string.h>
+#include "cryptonite_xsalsa.h"
+#include "cryptonite_bitfn.h"
+
+static inline uint32_t load32(const uint8_t *p)
+{
+  return le32_to_cpu(*((uint32_t *) p));
+}
+
+/* XSalsa20 algorithm as described in https://cr.yp.to/snuffle/xsalsa-20081128.pdf */
+void cryptonite_xsalsa_init(cryptonite_salsa_context *ctx, uint8_t nb_rounds,
+                            uint32_t keylen, const uint8_t *key,
+                            uint32_t ivlen, const uint8_t *iv)
+{
+  memset(ctx, 0, sizeof(*ctx));
+  ctx->nb_rounds = nb_rounds;
+
+  /* Create initial 512-bit input block:
+       (x0, x5, x10, x15) is the Salsa20 constant
+       (x1, x2, x3, x4, x11, x12, x13, x14) is a 256-bit key
+       (x6, x7, x8, x9) is the first 128 bits of a 192-bit nonce
+  */
+  cryptonite_salsa_init_core(&ctx->st, keylen, key, 8, iv);
+  ctx->st.d[ 8] = load32(iv + 8);
+  ctx->st.d[ 9] = load32(iv + 12);
+
+  /* Compute (z0, z1, . . . , z15) = doubleround ^(r/2) (x0, x1, . . . , x15) */
+  block hSalsa;
+  memset(&hSalsa, 0, sizeof(block));
+  cryptonite_salsa_core_xor(nb_rounds, &hSalsa, &ctx->st);
+ 
+  /* Build a new 512-bit input block (x′0, x′1, . . . , x′15):
+       (x′0, x′5, x′10, x′15) is the Salsa20 constant
+       (x′1,x′2,x′3,x′4,x′11,x′12,x′13,x′14) = (z0,z5,z10,z15,z6,z7,z8,z9)
+       (x′6,x′7) is the last 64 bits of the 192-bit nonce
+       (x′8, x′9) is a 64-bit block counter.
+  */
+  ctx->st.d[ 1] = hSalsa.d[ 0] - ctx->st.d[ 0];
+  ctx->st.d[ 2] = hSalsa.d[ 5] - ctx->st.d[ 5];
+  ctx->st.d[ 3] = hSalsa.d[10] - ctx->st.d[10];
+  ctx->st.d[ 4] = hSalsa.d[15] - ctx->st.d[15];
+  ctx->st.d[11] = hSalsa.d[ 6] - ctx->st.d[ 6];
+  ctx->st.d[12] = hSalsa.d[ 7] - ctx->st.d[ 7];
+  ctx->st.d[13] = hSalsa.d[ 8] - ctx->st.d[ 8];
+  ctx->st.d[14] = hSalsa.d[ 9] - ctx->st.d[ 9];
+  ctx->st.d[ 6] = load32(iv + 16);
+  ctx->st.d[ 7] = load32(iv + 20);
+  ctx->st.d[ 8] = 0;
+  ctx->st.d[ 9] = 0;
+}
\ No newline at end of file
diff --git a/cbits/cryptonite_xsalsa.h b/cbits/cryptonite_xsalsa.h
new file mode 100644
index 00000000..73233cee
--- /dev/null
+++ b/cbits/cryptonite_xsalsa.h
@@ -0,0 +1,37 @@
+/*
+ * Copyright (c) 2016 Brandon Hamilton <brandon.hamilton@gmail.com>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. Neither the name of the author nor the names of his contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.
+ */
+#ifndef CRYPTONITE_XSALSA
+#define CRYPTONITE_XSALSA
+
+#include "cryptonite_salsa.h"
+
+void cryptonite_xsalsa_init(cryptonite_salsa_context *ctx, uint8_t nb_rounds, uint32_t keylen, const uint8_t *key, uint32_t ivlen, const uint8_t *iv);
+
+#endif
diff --git a/ci b/ci
new file mode 100755
index 00000000..52e7c6b7
--- /dev/null
+++ b/ci
@@ -0,0 +1,7 @@
+#!/bin/sh
+compile=ghci
+defs="-DBENCODE_AESON -DTHREAD_DEBUG"
+hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
+# cbits="cbits/*.c"
+includes="-isrc -icryptonite-backport"
+$compile -Wmissing-signatures -fdefer-typed-holes -freverse-errors $hide $includes -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
diff --git a/cryptonite-backport/Crypto/Cipher/Salsa.hs b/cryptonite-backport/Crypto/Cipher/Salsa.hs
new file mode 100644
index 00000000..b6b188b1
--- /dev/null
+++ b/cryptonite-backport/Crypto/Cipher/Salsa.hs
@@ -0,0 +1,83 @@
+-- |
+-- Module      : Crypto.Cipher.Salsa
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.Salsa
+    ( initialize
+    , combine
+    , generate
+    , State(..)
+    ) where
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Foreign.Ptr
+import           Foreign.C.Types
+
+-- | Salsa context
+newtype State = State ScrubbedBytes
+    deriving (NFData)
+
+-- | Initialize a new Salsa context with the number of rounds,
+-- the key and the nonce associated.
+initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
+           => Int    -- ^ number of rounds (8,12,20)
+           -> key    -- ^ the key (128 or 256 bits)
+           -> nonce  -- ^ the nonce (64 or 96 bits)
+           -> State  -- ^ the initial Salsa state
+initialize nbRounds key nonce
+    | not (kLen `elem` [16,32])       = error "Salsa: key length should be 128 or 256 bits"
+    | not (nonceLen `elem` [8,12])    = error "Salsa: nonce length should be 64 or 96 bits"
+    | not (nbRounds `elem` [8,12,20]) = error "Salsa: rounds should be 8, 12 or 20"
+    | otherwise = unsafeDoIO $ do
+        stPtr <- B.alloc 132 $ \stPtr ->
+            B.withByteArray nonce $ \noncePtr  ->
+            B.withByteArray key   $ \keyPtr ->
+                ccryptonite_salsa_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
+        return $ State stPtr
+  where kLen     = B.length key
+        nonceLen = B.length nonce
+
+-- | Combine the salsa output and an arbitrary message with a xor,
+-- and return the combined output and the new state.
+combine :: ByteArray ba
+        => State      -- ^ the current Salsa state
+        -> ba         -- ^ the source to xor with the generator
+        -> (ba, State)
+combine prevSt@(State prevStMem) src
+    | B.null src = (B.empty, prevSt)
+    | otherwise  = unsafeDoIO $ do
+        (out, st) <- B.copyRet prevStMem $ \ctx ->
+            B.alloc (B.length src) $ \dstPtr ->
+            B.withByteArray src    $ \srcPtr -> do
+                ccryptonite_salsa_combine dstPtr ctx srcPtr (fromIntegral $ B.length src)
+        return (out, State st)
+
+-- | Generate a number of bytes from the Salsa output directly
+generate :: ByteArray ba
+         => State -- ^ the current Salsa state
+         -> Int   -- ^ the length of data to generate
+         -> (ba, State)
+generate prevSt@(State prevStMem) len
+    | len <= 0  = (B.empty, prevSt)
+    | otherwise = unsafeDoIO $ do
+        (out, st) <- B.copyRet prevStMem $ \ctx ->
+            B.alloc len $ \dstPtr ->
+                ccryptonite_salsa_generate dstPtr ctx (fromIntegral len)
+        return (out, State st)
+
+foreign import ccall "cryptonite_salsa_init"
+    ccryptonite_salsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
+
+foreign import ccall "cryptonite_salsa_combine"
+    ccryptonite_salsa_combine :: Ptr Word8 -> Ptr State -> Ptr Word8 -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_salsa_generate"
+    ccryptonite_salsa_generate :: Ptr Word8 -> Ptr State -> CUInt -> IO ()
diff --git a/cryptonite-backport/Crypto/Cipher/XSalsa.hs b/cryptonite-backport/Crypto/Cipher/XSalsa.hs
new file mode 100644
index 00000000..494760e2
--- /dev/null
+++ b/cryptonite-backport/Crypto/Cipher/XSalsa.hs
@@ -0,0 +1,50 @@
+-- |
+-- Module      : Crypto.Cipher.XSalsa
+-- License     : BSD-style
+-- Maintainer  : Brandon Hamilton <brandon.hamilton@gmail.com>
+-- Stability   : stable
+-- Portability : good
+--
+-- Implementation of XSalsa20 algorithm
+-- <https://cr.yp.to/snuffle/xsalsa-20081128.pdf>
+-- Based on the Salsa20 algorithm with 256 bit key extended with 192 bit nonce
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Crypto.Cipher.XSalsa
+    ( initialize
+    , combine
+    , generate
+    , State
+    ) where
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Foreign.Ptr
+import           Foreign.Storable
+import           Foreign.C.Types
+import           Crypto.Cipher.Salsa hiding (initialize)
+
+-- | Initialize a new XSalsa context with the number of rounds,
+-- the key and the nonce associated.
+initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
+           => Int    -- ^ number of rounds (8,12,20)
+           -> key    -- ^ the key (256 bits)
+           -> nonce  -- ^ the nonce (192 bits)
+           -> State  -- ^ the initial XSalsa state
+initialize nbRounds key nonce
+    | kLen /= 32                      = error "XSalsa: key length should be 256 bits"
+    | nonceLen /= 24                  = error "XSalsa: nonce length should be 192 bits"
+    | not (nbRounds `elem` [8,12,20]) = error "XSalsa: rounds should be 8, 12 or 20"
+    | otherwise = unsafeDoIO $ do
+        stPtr <- B.alloc 132 $ \stPtr ->
+            B.withByteArray nonce $ \noncePtr  ->
+            B.withByteArray key   $ \keyPtr ->
+                ccryptonite_xsalsa_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
+        return $ State stPtr
+  where kLen     = B.length key
+        nonceLen = B.length nonce
+
+foreign import ccall "cryptonite_xsalsa_init"
+    ccryptonite_xsalsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
diff --git a/cryptonite-backport/Crypto/ECC/Class.hs b/cryptonite-backport/Crypto/ECC/Class.hs
new file mode 100644
index 00000000..16b2cc15
--- /dev/null
+++ b/cryptonite-backport/Crypto/ECC/Class.hs
@@ -0,0 +1,127 @@
+-- |
+-- Module      : Crypto.ECC.Class
+-- License     : BSD-style
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Elliptic Curve Cryptography
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.ECC.Class
+    ( Curve_X25519(..)
+    , EllipticCurve(..)
+    , EllipticCurveDH(..)
+    , EllipticCurveArith(..)
+    , KeyPair(..)
+    , SharedSecret(..)
+    ) where
+
+import qualified Crypto.ECC.Simple.Types as Simple
+import qualified Crypto.ECC.Simple.Prim as Simple
+import           Crypto.Random
+-- import Crypto.Error
+import Crypto.Error.Types
+-- import           Crypto.Internal.Proxy
+import Data.Typeable
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Number.Serialize (i2ospOf_, os2ip)
+import qualified Crypto.PubKey.Curve25519 as X25519
+import           Data.ByteArray (convert)
+
+-- | An elliptic curve key pair composed of the private part (a scalar), and
+-- the associated point.
+data KeyPair curve = KeyPair
+    { keypairGetPublic  :: !(Point curve)
+    , keypairGetPrivate :: !(Scalar curve)
+    }
+
+newtype SharedSecret = SharedSecret ScrubbedBytes
+    deriving (Eq, ByteArrayAccess)
+
+class EllipticCurve curve where
+    -- | Point on an Elliptic Curve
+    type Point curve  :: *
+
+    -- | Scalar in the Elliptic Curve domain
+    type Scalar curve :: *
+
+    -- | Generate a new random scalar on the curve.
+    -- The scalar will represent a number between 1 and the order of the curve non included
+    curveGenerateScalar :: MonadRandom randomly => proxy curve -> randomly (Scalar curve)
+
+    -- | Generate a new random keypair
+    curveGenerateKeyPair :: MonadRandom randomly => proxy curve -> randomly (KeyPair curve)
+
+    -- | Get the curve size in bits
+    curveSizeBits :: proxy curve -> Int
+
+    -- | Encode a elliptic curve point into binary form
+    encodePoint :: ByteArray bs => proxy curve -> Point curve -> bs
+
+    -- | Try to decode the binary form of an elliptic curve point
+    decodePoint :: ByteArray bs => proxy curve -> bs -> CryptoFailable (Point curve)
+
+class EllipticCurve curve => EllipticCurveDH curve where
+    -- | Generate a Diffie hellman secret value.
+    --
+    -- This is generally just the .x coordinate of the resulting point, that
+    -- is not hashed.
+    --
+    -- use `pointSmul` to keep the result in Point format.
+    ecdh :: proxy curve -> Scalar curve -> Point curve -> SharedSecret
+
+class EllipticCurve curve => EllipticCurveArith curve where
+    -- | Add points on a curve
+    pointAdd :: proxy curve -> Point curve -> Point curve -> Point curve
+
+    -- | Scalar Multiplication on a curve
+    pointSmul :: proxy curve -> Scalar curve -> Point curve -> Point curve
+
+--   -- | Scalar Inverse
+--   scalarInverse :: Scalar curve -> Scalar curve
+
+data Curve_X25519 = Curve_X25519
+
+instance EllipticCurve Curve_X25519 where
+    type Point Curve_X25519 = X25519.PublicKey
+    type Scalar Curve_X25519 = X25519.SecretKey
+    curveSizeBits _ = 255
+    curveGenerateScalar _ = X25519.generateSecretKey
+    curveGenerateKeyPair _ = do
+        s <- X25519.generateSecretKey
+        return $ KeyPair (X25519.toPublic s) s
+    encodePoint _ p = B.convert p
+    decodePoint _ bs = X25519.publicKey bs
+
+instance EllipticCurveDH Curve_X25519 where
+    ecdh _ s p = SharedSecret $ convert secret
+      where secret = X25519.dh p s
+
+encodeECPoint :: forall curve bs . (Simple.Curve curve, ByteArray bs) => Simple.Point curve -> bs
+encodeECPoint Simple.PointO      = error "encodeECPoint: cannot serialize point at infinity"
+encodeECPoint (Simple.Point x y) = B.concat [uncompressed,xb,yb]
+  where
+    size = Simple.curveSizeBytes (Proxy :: Proxy curve)
+    uncompressed, xb, yb :: bs
+    uncompressed = B.singleton 4
+    xb = i2ospOf_ size x
+    yb = i2ospOf_ size y
+
+decodeECPoint :: (Simple.Curve curve, ByteArray bs) => bs -> CryptoFailable (Simple.Point curve)
+decodeECPoint mxy = case B.uncons mxy of
+    Nothing     -> CryptoFailed $ CryptoError_PointSizeInvalid
+    Just (m,xy)
+        -- uncompressed
+        | m == 4 ->
+            let siz = B.length xy `div` 2
+                (xb,yb) = B.splitAt siz xy
+                x = os2ip xb
+                y = os2ip yb
+             in Simple.pointFromIntegers (x,y)
+        | otherwise -> CryptoFailed $ CryptoError_PointFormatInvalid
+
+curveSizeBytes :: EllipticCurve c => Proxy c -> Int
+curveSizeBytes proxy = (curveSizeBits proxy + 7) `div` 8
diff --git a/cryptonite-backport/Crypto/ECC/Simple/Prim.hs b/cryptonite-backport/Crypto/ECC/Simple/Prim.hs
new file mode 100644
index 00000000..117988f2
--- /dev/null
+++ b/cryptonite-backport/Crypto/ECC/Simple/Prim.hs
@@ -0,0 +1,208 @@
+-- | Elliptic Curve Arithmetic.
+--
+-- /WARNING:/ These functions are vulnerable to timing attacks.
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.ECC.Simple.Prim
+    ( scalarGenerate
+    , scalarFromInteger
+    , pointAdd
+    , pointDouble
+    , pointBaseMul
+    , pointMul
+    , pointAddTwoMuls
+    , pointFromIntegers
+    , isPointAtInfinity
+    , isPointValid
+    ) where
+
+import Data.Maybe
+import Data.Typeable
+import Crypto.Internal.Imports
+import Crypto.Number.ModArithmetic
+import Crypto.Number.F2m
+import Crypto.Number.Generate (generateBetween)
+import Crypto.ECC.Simple.Types
+-- import Crypto.Error
+import Crypto.Error.Types
+import Crypto.Random
+
+-- | Generate a valid scalar for a specific Curve
+scalarGenerate :: forall randomly curve . (MonadRandom randomly, Curve curve) => randomly (Scalar curve)
+scalarGenerate =
+    Scalar <$> generateBetween 1 (n - 1)
+  where
+    n = curveEccN $ curveParameters (Proxy :: Proxy curve)
+
+scalarFromInteger :: forall curve . Curve curve => Integer -> CryptoFailable (Scalar curve)
+scalarFromInteger n
+    | n < 0  || n >= mx = CryptoFailed $ CryptoError_EcScalarOutOfBounds
+    | otherwise         = CryptoPassed $ Scalar n
+  where
+    mx = case curveType (Proxy :: Proxy curve) of
+            CurveBinary (CurveBinaryParam b) -> b
+            CurvePrime (CurvePrimeParam p)   -> p
+
+--TODO: Extract helper function for `fromMaybe PointO...`
+
+-- | Elliptic Curve point negation:
+-- @pointNegate p@ returns point @q@ such that @pointAdd p q == PointO@.
+pointNegate :: Curve curve => Point curve -> Point curve
+pointNegate        PointO     = PointO
+pointNegate point@(Point x y) =
+    case curveType point of
+        CurvePrime {}  -> Point x (-y)
+        CurveBinary {} -> Point x (x `addF2m` y)
+
+-- | Elliptic Curve point addition.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointAdd :: Curve curve => Point curve -> Point curve -> Point curve
+pointAdd PointO PointO = PointO
+pointAdd PointO q = q
+pointAdd p PointO = p
+pointAdd p q
+  | p == q             = pointDouble p
+  | p == pointNegate q = PointO
+pointAdd point@(Point xp yp) (Point xq yq) =
+    case ty of
+        CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
+            s <- divmod (yp - yq) (xp - xq) pr
+            let xr = (s ^ (2::Int) - xp - xq) `mod` pr
+                yr = (s * (xp - xr) - yp) `mod` pr
+            return $ Point xr yr
+        CurveBinary (CurveBinaryParam fx) -> fromMaybe PointO $ do
+            s <- divF2m fx (yp `addF2m` yq) (xp `addF2m` xq)
+            let xr = mulF2m fx s s `addF2m` s `addF2m` xp `addF2m` xq `addF2m` a
+                yr = mulF2m fx s (xp `addF2m` xr) `addF2m` xr `addF2m` yp
+            return $ Point xr yr
+  where
+    ty = curveType point
+    cc = curveParameters point
+    a  = curveEccA cc
+
+-- | Elliptic Curve point doubling.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+--
+-- This perform the following calculation:
+-- > lambda = (3 * xp ^ 2 + a) / 2 yp
+-- > xr = lambda ^ 2 - 2 xp
+-- > yr = lambda (xp - xr) - yp
+--
+-- With binary curve:
+-- > xp == 0   => P = O
+-- > otherwise =>
+-- >    s = xp + (yp / xp)
+-- >    xr = s ^ 2 + s + a
+-- >    yr = xp ^ 2 + (s+1) * xr
+--
+pointDouble :: Curve curve => Point curve -> Point curve
+pointDouble PointO = PointO
+pointDouble point@(Point xp yp) =
+    case ty of
+        CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
+            lambda <- divmod (3 * xp ^ (2::Int) + a) (2 * yp) pr
+            let xr = (lambda ^ (2::Int) - 2 * xp) `mod` pr
+                yr = (lambda * (xp - xr) - yp) `mod` pr
+            return $ Point xr yr
+        CurveBinary (CurveBinaryParam fx)
+            | xp == 0    -> PointO
+            | otherwise  -> fromMaybe PointO $ do
+                s <- return . addF2m xp =<< divF2m fx yp xp
+                let xr = mulF2m fx s s `addF2m` s `addF2m` a
+                    yr = mulF2m fx xp xp `addF2m` mulF2m fx xr (s `addF2m` 1)
+                return $ Point xr yr
+  where
+    ty = curveType point
+    cc = curveParameters point
+    a  = curveEccA cc
+
+-- | Elliptic curve point multiplication using the base
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointBaseMul :: Curve curve => Scalar curve -> Point curve
+pointBaseMul n = pointMul n (curveEccG $ curveParameters (Proxy :: Proxy curve))
+
+-- | Elliptic curve point multiplication (double and add algorithm).
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointMul :: Curve curve => Scalar curve -> Point curve -> Point curve
+pointMul _ PointO = PointO
+pointMul (Scalar n) p
+    | n == 0    = PointO
+    | n == 1    = p
+    | odd n     = pointAdd p (pointMul (Scalar (n - 1)) p)
+    | otherwise = pointMul (Scalar (n `div` 2)) (pointDouble p)
+
+-- | Elliptic curve double-scalar multiplication (uses Shamir's trick).
+--
+-- > pointAddTwoMuls n1 p1 n2 p2 == pointAdd (pointMul n1 p1)
+-- >                                         (pointMul n2 p2)
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointAddTwoMuls :: Curve curve => Scalar curve -> Point curve -> Scalar curve -> Point curve -> Point curve
+pointAddTwoMuls _  PointO _  PointO = PointO
+pointAddTwoMuls _  PointO n2 p2     = pointMul n2 p2
+pointAddTwoMuls n1 p1     _  PointO = pointMul n1 p1
+pointAddTwoMuls (Scalar n1) p1 (Scalar n2) p2 = go (n1, n2)
+  where
+    p0 = pointAdd p1 p2
+
+    go (0,  0 ) = PointO
+    go (k1, k2) =
+        let q = pointDouble $ go (k1 `div` 2, k2 `div` 2)
+        in case (odd k1, odd k2) of
+            (True  , True  ) -> pointAdd p0 q
+            (True  , False ) -> pointAdd p1 q
+            (False , True  ) -> pointAdd p2 q
+            (False , False ) -> q
+
+-- | Check if a point is the point at infinity.
+isPointAtInfinity :: Point curve -> Bool
+isPointAtInfinity PointO = True
+isPointAtInfinity _      = False
+
+-- | Make a point on a curve from integer (x,y) coordinate
+--
+-- if the point is not valid related to the curve then an error is
+-- returned instead of a point
+pointFromIntegers :: forall curve . Curve curve => (Integer, Integer) -> CryptoFailable (Point curve)
+pointFromIntegers (x,y)
+    | isPointValid (Proxy :: Proxy curve) x y = CryptoPassed $ Point x y
+    | otherwise                               = CryptoFailed $ CryptoError_PointCoordinatesInvalid
+
+-- | check if a point is on specific curve
+--
+-- This perform three checks:
+--
+-- * x is not out of range
+-- * y is not out of range
+-- * the equation @y^2 = x^3 + a*x + b (mod p)@ holds
+isPointValid :: Curve curve => proxy curve -> Integer -> Integer -> Bool
+isPointValid proxy x y =
+    case ty of
+        CurvePrime (CurvePrimeParam p) ->
+            let a  = curveEccA cc
+                b  = curveEccB cc
+                eqModP z1 z2 = (z1 `mod` p) == (z2 `mod` p)
+                isValid e = e >= 0 && e < p
+             in isValid x && isValid y && (y ^ (2 :: Int)) `eqModP` (x ^ (3 :: Int) + a * x + b)
+        CurveBinary (CurveBinaryParam fx) ->
+            let a  = curveEccA cc
+                b  = curveEccB cc
+                add = addF2m
+                mul = mulF2m fx
+                isValid e = modF2m fx e == e
+             in and [ isValid x
+                    , isValid y
+                    , ((((x `add` a) `mul` x `add` y) `mul` x) `add` b `add` (squareF2m fx y)) == 0
+                    ]
+  where
+    ty = curveType proxy
+    cc = curveParameters proxy
+
+-- | div and mod
+divmod :: Integer -> Integer -> Integer -> Maybe Integer
+divmod y x m = do
+    i <- inverse (x `mod` m) m
+    return $ y * i `mod` m
diff --git a/cryptonite-backport/Crypto/ECC/Simple/Types.hs b/cryptonite-backport/Crypto/ECC/Simple/Types.hs
new file mode 100644
index 00000000..c97daa29
--- /dev/null
+++ b/cryptonite-backport/Crypto/ECC/Simple/Types.hs
@@ -0,0 +1,615 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-- |
+-- Module      : Crypto.ECC.Simple.Types
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : Experimental
+-- Portability : Excellent
+--
+-- references:
+--   <https://tools.ietf.org/html/rfc5915>
+--
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module Crypto.ECC.Simple.Types
+    ( Curve(..)
+    , Point(..)
+    , Scalar(..)
+    , CurveType(..)
+    , CurveBinaryParam(..)
+    , CurvePrimeParam(..)
+    , curveSizeBits
+    , curveSizeBytes
+    , CurveParameters(..)
+    -- * specific curves definition
+    , SEC_p112r1(..)
+    , SEC_p112r2(..)
+    , SEC_p128r1(..)
+    , SEC_p128r2(..)
+    , SEC_p160k1(..)
+    , SEC_p160r1(..)
+    , SEC_p160r2(..)
+    , SEC_p192k1(..)
+    , SEC_p192r1(..) -- aka prime192v1
+    , SEC_p224k1(..)
+    , SEC_p224r1(..)
+    , SEC_p256k1(..)
+    , SEC_p256r1(..) -- aka prime256v1
+    , SEC_p384r1(..)
+    , SEC_p521r1(..)
+    , SEC_t113r1(..)
+    , SEC_t113r2(..)
+    , SEC_t131r1(..)
+    , SEC_t131r2(..)
+    , SEC_t163k1(..)
+    , SEC_t163r1(..)
+    , SEC_t163r2(..)
+    , SEC_t193r1(..)
+    , SEC_t193r2(..)
+    , SEC_t233k1(..) -- aka NIST K-233
+    , SEC_t233r1(..)
+    , SEC_t239k1(..)
+    , SEC_t283k1(..)
+    , SEC_t283r1(..)
+    , SEC_t409k1(..)
+    , SEC_t409r1(..)
+    , SEC_t571k1(..)
+    , SEC_t571r1(..)
+    ) where
+
+import           Data.Data
+import           Crypto.Internal.Imports
+import           Crypto.Number.Basic (numBits)
+
+class Curve curve where
+    curveParameters :: proxy curve -> CurveParameters curve
+    curveType :: proxy curve -> CurveType
+
+-- | get the size of the curve in bits
+curveSizeBits :: Curve curve => proxy curve -> Int
+curveSizeBits proxy =
+    case curveType proxy of
+        CurvePrime (CurvePrimeParam p)   -> numBits p
+        CurveBinary (CurveBinaryParam c) -> numBits c - 1
+
+-- | get the size of the curve in bytes
+curveSizeBytes :: Curve curve => proxy curve -> Int
+curveSizeBytes proxy = (curveSizeBits proxy + 7) `div` 8
+
+-- | Define common parameters in a curve definition
+-- of the form: y^2 = x^3 + ax + b.
+data CurveParameters curve = CurveParameters
+    { curveEccA :: Integer     -- ^ curve parameter a
+    , curveEccB :: Integer     -- ^ curve parameter b
+    , curveEccG :: Point curve -- ^ base point
+    , curveEccN :: Integer     -- ^ order of G
+    , curveEccH :: Integer     -- ^ cofactor
+    } deriving (Show,Eq,Data,Typeable)
+
+newtype CurveBinaryParam = CurveBinaryParam Integer
+    deriving (Show,Read,Eq,Data,Typeable)
+
+newtype CurvePrimeParam = CurvePrimeParam Integer
+    deriving (Show,Read,Eq,Data,Typeable)
+
+data CurveType =
+      CurveBinary CurveBinaryParam
+    | CurvePrime CurvePrimeParam
+    deriving (Show,Read,Eq,Data,Typeable)
+
+-- | ECC Private Number
+newtype Scalar curve = Scalar Integer
+    deriving (Show,Read,Eq,Data,Typeable)
+
+-- | Define a point on a curve.
+data Point curve =
+      Point Integer Integer
+    | PointO -- ^ Point at Infinity
+    deriving (Show,Read,Eq,Data,Typeable)
+
+instance NFData (Point curve) where
+    rnf (Point x y) = x `seq` y `seq` ()
+    rnf PointO = ()
+
+data SEC_p112r1 = SEC_p112r1 deriving (Show,Read,Eq)
+data SEC_p112r2 = SEC_p112r2 deriving (Show,Read,Eq)
+data SEC_p128r1 = SEC_p128r1 deriving (Show,Read,Eq)
+data SEC_p128r2 = SEC_p128r2 deriving (Show,Read,Eq)
+data SEC_p160k1 = SEC_p160k1 deriving (Show,Read,Eq)
+data SEC_p160r1 = SEC_p160r1 deriving (Show,Read,Eq)
+data SEC_p160r2 = SEC_p160r2 deriving (Show,Read,Eq)
+data SEC_p192k1 = SEC_p192k1 deriving (Show,Read,Eq)
+data SEC_p192r1 = SEC_p192r1 deriving (Show,Read,Eq)
+data SEC_p224k1 = SEC_p224k1 deriving (Show,Read,Eq)
+data SEC_p224r1 = SEC_p224r1 deriving (Show,Read,Eq)
+data SEC_p256k1 = SEC_p256k1 deriving (Show,Read,Eq)
+data SEC_p256r1 = SEC_p256r1 deriving (Show,Read,Eq)
+data SEC_p384r1 = SEC_p384r1 deriving (Show,Read,Eq)
+data SEC_p521r1 = SEC_p521r1 deriving (Show,Read,Eq)
+data SEC_t113r1 = SEC_t113r1 deriving (Show,Read,Eq)
+data SEC_t113r2 = SEC_t113r2 deriving (Show,Read,Eq)
+data SEC_t131r1 = SEC_t131r1 deriving (Show,Read,Eq)
+data SEC_t131r2 = SEC_t131r2 deriving (Show,Read,Eq)
+data SEC_t163k1 = SEC_t163k1 deriving (Show,Read,Eq)
+data SEC_t163r1 = SEC_t163r1 deriving (Show,Read,Eq)
+data SEC_t163r2 = SEC_t163r2 deriving (Show,Read,Eq)
+data SEC_t193r1 = SEC_t193r1 deriving (Show,Read,Eq)
+data SEC_t193r2 = SEC_t193r2 deriving (Show,Read,Eq)
+data SEC_t233k1 = SEC_t233k1 deriving (Show,Read,Eq)
+data SEC_t233r1 = SEC_t233r1 deriving (Show,Read,Eq)
+data SEC_t239k1 = SEC_t239k1 deriving (Show,Read,Eq)
+data SEC_t283k1 = SEC_t283k1 deriving (Show,Read,Eq)
+data SEC_t283r1 = SEC_t283r1 deriving (Show,Read,Eq)
+data SEC_t409k1 = SEC_t409k1 deriving (Show,Read,Eq)
+data SEC_t409r1 = SEC_t409r1 deriving (Show,Read,Eq)
+data SEC_t571k1 = SEC_t571k1 deriving (Show,Read,Eq)
+data SEC_t571r1 = SEC_t571r1 deriving (Show,Read,Eq)
+
+-- | Define names for known recommended curves.
+instance Curve SEC_p112r1 where
+    curveType _ = typeSEC_p112r1
+    curveParameters _ = paramSEC_p112r1
+
+instance Curve SEC_p112r2 where
+    curveType _ = typeSEC_p112r2
+    curveParameters _ = paramSEC_p112r2
+
+instance Curve SEC_p128r1 where
+    curveType _ = typeSEC_p128r1
+    curveParameters _ = paramSEC_p128r1
+
+instance Curve SEC_p128r2 where
+    curveType _ = typeSEC_p128r2
+    curveParameters _ = paramSEC_p128r2
+
+instance Curve SEC_p160k1 where
+    curveType _ = typeSEC_p160k1
+    curveParameters _ = paramSEC_p160k1
+
+instance Curve SEC_p160r1 where
+    curveType _ = typeSEC_p160r1
+    curveParameters _ = paramSEC_p160r1
+
+instance Curve SEC_p160r2 where
+    curveType _ = typeSEC_p160r2
+    curveParameters _ = paramSEC_p160r2
+
+instance Curve SEC_p192k1 where
+    curveType _ = typeSEC_p192k1
+    curveParameters _ = paramSEC_p192k1
+
+instance Curve SEC_p192r1 where
+    curveType _ = typeSEC_p192r1
+    curveParameters _ = paramSEC_p192r1
+
+instance Curve SEC_p224k1 where
+    curveType _ = typeSEC_p224k1
+    curveParameters _ = paramSEC_p224k1
+
+instance Curve SEC_p224r1 where
+    curveType _ = typeSEC_p224r1
+    curveParameters _ = paramSEC_p224r1
+
+instance Curve SEC_p256k1 where
+    curveType _ = typeSEC_p256k1
+    curveParameters _ = paramSEC_p256k1
+
+instance Curve SEC_p256r1 where
+    curveType _ = typeSEC_p256r1
+    curveParameters _ = paramSEC_p256r1
+
+instance Curve SEC_p384r1 where
+    curveType _ = typeSEC_p384r1
+    curveParameters _ = paramSEC_p384r1
+
+instance Curve SEC_p521r1 where
+    curveType _ = typeSEC_p521r1
+    curveParameters _ = paramSEC_p521r1
+
+instance Curve SEC_t113r1 where
+    curveType _ = typeSEC_t113r1
+    curveParameters _ = paramSEC_t113r1
+
+instance Curve SEC_t113r2 where
+    curveType _ = typeSEC_t113r2
+    curveParameters _ = paramSEC_t113r2
+
+instance Curve SEC_t131r1 where
+    curveType _ = typeSEC_t131r1
+    curveParameters _ = paramSEC_t131r1
+
+instance Curve SEC_t131r2 where
+    curveType _ = typeSEC_t131r2
+    curveParameters _ = paramSEC_t131r2
+
+instance Curve SEC_t163k1 where
+    curveType _ = typeSEC_t163k1
+    curveParameters _ = paramSEC_t163k1
+
+instance Curve SEC_t163r1 where
+    curveType _ = typeSEC_t163r1
+    curveParameters _ = paramSEC_t163r1
+
+instance Curve SEC_t163r2 where
+    curveType _ = typeSEC_t163r2
+    curveParameters _ = paramSEC_t163r2
+
+instance Curve SEC_t193r1 where
+    curveType _ = typeSEC_t193r1
+    curveParameters _ = paramSEC_t193r1
+
+instance Curve SEC_t193r2 where
+    curveType _ = typeSEC_t193r2
+    curveParameters _ = paramSEC_t193r2
+
+instance Curve SEC_t233k1 where
+    curveType _ = typeSEC_t233k1
+    curveParameters _ = paramSEC_t233k1
+
+instance Curve SEC_t233r1 where
+    curveType _ = typeSEC_t233r1
+    curveParameters _ = paramSEC_t233r1
+
+instance Curve SEC_t239k1 where
+    curveType _ = typeSEC_t239k1
+    curveParameters _ = paramSEC_t239k1
+
+instance Curve SEC_t283k1 where
+    curveType _ = typeSEC_t283k1
+    curveParameters _ = paramSEC_t283k1
+
+instance Curve SEC_t283r1 where
+    curveType _ = typeSEC_t283r1
+    curveParameters _ = paramSEC_t283r1
+
+instance Curve SEC_t409k1 where
+    curveType _ = typeSEC_t409k1
+    curveParameters _ = paramSEC_t409k1
+
+instance Curve SEC_t409r1 where
+    curveType _ = typeSEC_t409r1
+    curveParameters _ = paramSEC_t409r1
+
+instance Curve SEC_t571k1 where
+    curveType _ = typeSEC_t571k1
+    curveParameters _ = paramSEC_t571k1
+
+instance Curve SEC_t571r1 where
+    curveType _ = typeSEC_t571r1
+    curveParameters _ = paramSEC_t571r1
+
+{-
+curvesOIDs :: [ (CurveName, [Integer]) ]
+curvesOIDs =
+    [ (SEC_p112r1, [1,3,132,0,6])
+    , (SEC_p112r2, [1,3,132,0,7])
+    , (SEC_p128r1, [1,3,132,0,28])
+    , (SEC_p128r2, [1,3,132,0,29])
+    , (SEC_p160k1, [1,3,132,0,9])
+    , (SEC_p160r1, [1,3,132,0,8])
+    , (SEC_p160r2, [1,3,132,0,30])
+    , (SEC_p192k1, [1,3,132,0,31])
+    , (SEC_p192r1, [1,2,840,10045,3,1,1])
+    , (SEC_p224k1, [1,3,132,0,32])
+    , (SEC_p224r1, [1,3,132,0,33])
+    , (SEC_p256k1, [1,3,132,0,10])
+    , (SEC_p256r1, [1,2,840,10045,3,1,7])
+    , (SEC_p384r1, [1,3,132,0,34])
+    , (SEC_p521r1, [1,3,132,0,35])
+    , (SEC_t113r1, [1,3,132,0,4])
+    , (SEC_t113r2, [1,3,132,0,5])
+    , (SEC_t131r1, [1,3,132,0,22])
+    , (SEC_t131r2, [1,3,132,0,23])
+    , (SEC_t163k1, [1,3,132,0,1])
+    , (SEC_t163r1, [1,3,132,0,2])
+    , (SEC_t163r2, [1,3,132,0,15])
+    , (SEC_t193r1, [1,3,132,0,24])
+    , (SEC_t193r2, [1,3,132,0,25])
+    , (SEC_t233k1, [1,3,132,0,26])
+    , (SEC_t233r1, [1,3,132,0,27])
+    , (SEC_t239k1, [1,3,132,0,3])
+    , (SEC_t283k1, [1,3,132,0,16])
+    , (SEC_t283r1, [1,3,132,0,17])
+    , (SEC_t409k1, [1,3,132,0,36])
+    , (SEC_t409r1, [1,3,132,0,37])
+    , (SEC_t571k1, [1,3,132,0,38])
+    , (SEC_t571r1, [1,3,132,0,39])
+    ]
+-}
+
+typeSEC_p112r1 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
+paramSEC_p112r1 = CurveParameters
+    { curveEccA = 0xdb7c2abf62e35e668076bead2088
+    , curveEccB = 0x659ef8ba043916eede8911702b22
+    , curveEccG = Point 0x09487239995a5ee76b55f9c2f098
+                    0xa89ce5af8724c0a23e0e0ff77500
+    , curveEccN = 0xdb7c2abf62e35e7628dfac6561c5
+    , curveEccH = 1
+    }
+typeSEC_p112r2 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
+paramSEC_p112r2 = CurveParameters
+    { curveEccA = 0x6127c24c05f38a0aaaf65c0ef02c
+    , curveEccB = 0x51def1815db5ed74fcc34c85d709
+    , curveEccG = Point 0x4ba30ab5e892b4e1649dd0928643
+                    0xadcd46f5882e3747def36e956e97
+    , curveEccN = 0x36df0aafd8b8d7597ca10520d04b
+    , curveEccH = 4
+    }
+typeSEC_p128r1 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
+paramSEC_p128r1 = CurveParameters
+    { curveEccA = 0xfffffffdfffffffffffffffffffffffc
+    , curveEccB = 0xe87579c11079f43dd824993c2cee5ed3
+    , curveEccG = Point 0x161ff7528b899b2d0c28607ca52c5b86
+                    0xcf5ac8395bafeb13c02da292dded7a83
+    , curveEccN = 0xfffffffe0000000075a30d1b9038a115
+    , curveEccH = 1
+    }
+typeSEC_p128r2 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
+paramSEC_p128r2 = CurveParameters
+    { curveEccA = 0xd6031998d1b3bbfebf59cc9bbff9aee1
+    , curveEccB = 0x5eeefca380d02919dc2c6558bb6d8a5d
+    , curveEccG = Point 0x7b6aa5d85e572983e6fb32a7cdebc140
+                    0x27b6916a894d3aee7106fe805fc34b44
+    , curveEccN = 0x3fffffff7fffffffbe0024720613b5a3
+    , curveEccH = 4
+    }
+typeSEC_p160k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
+paramSEC_p160k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000007
+    , curveEccG = Point 0x003b4c382ce37aa192a4019e763036f4f5dd4d7ebb
+                    0x00938cf935318fdced6bc28286531733c3f03c4fee
+    , curveEccN = 0x0100000000000000000001b8fa16dfab9aca16b6b3
+    , curveEccH = 1
+    }
+typeSEC_p160r1 = CurvePrime $ CurvePrimeParam 0x00ffffffffffffffffffffffffffffffff7fffffff
+paramSEC_p160r1 = CurveParameters
+    { curveEccA = 0x00ffffffffffffffffffffffffffffffff7ffffffc
+    , curveEccB = 0x001c97befc54bd7a8b65acf89f81d4d4adc565fa45
+    , curveEccG = Point 0x004a96b5688ef573284664698968c38bb913cbfc82
+                    0x0023a628553168947d59dcc912042351377ac5fb32
+    , curveEccN = 0x0100000000000000000001f4c8f927aed3ca752257
+    , curveEccH = 1
+    }
+typeSEC_p160r2 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
+paramSEC_p160r2 = CurveParameters
+    { curveEccA = 0x00fffffffffffffffffffffffffffffffeffffac70
+    , curveEccB = 0x00b4e134d3fb59eb8bab57274904664d5af50388ba
+    , curveEccG = Point 0x0052dcb034293a117e1f4ff11b30f7199d3144ce6d
+                    0x00feaffef2e331f296e071fa0df9982cfea7d43f2e
+    , curveEccN = 0x0100000000000000000000351ee786a818f3a1a16b
+    , curveEccH = 1
+    }
+typeSEC_p192k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffeffffee37
+paramSEC_p192k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000003
+    , curveEccG = Point 0xdb4ff10ec057e9ae26b07d0280b7f4341da5d1b1eae06c7d
+                    0x9b2f2f6d9c5628a7844163d015be86344082aa88d95e2f9d
+    , curveEccN = 0xfffffffffffffffffffffffe26f2fc170f69466a74defd8d
+    , curveEccH = 1
+    }
+typeSEC_p192r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffeffffffffffffffff
+paramSEC_p192r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffc
+    , curveEccB = 0x64210519e59c80e70fa7e9ab72243049feb8deecc146b9b1
+    , curveEccG = Point 0x188da80eb03090f67cbf20eb43a18800f4ff0afd82ff1012
+                    0x07192b95ffc8da78631011ed6b24cdd573f977a11e794811
+    , curveEccN = 0xffffffffffffffffffffffff99def836146bc9b1b4d22831
+    , curveEccH = 1
+    }
+typeSEC_p224k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffffffffffffffffffeffffe56d
+paramSEC_p224k1 = CurveParameters
+    { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x0000000000000000000000000000000000000000000000000000000005
+    , curveEccG = Point 0x00a1455b334df099df30fc28a169a467e9e47075a90f7e650eb6b7a45c
+                    0x007e089fed7fba344282cafbd6f7e319f7c0b0bd59e2ca4bdb556d61a5
+    , curveEccN = 0x010000000000000000000000000001dce8d2ec6184caf0a971769fb1f7
+    , curveEccH = 1
+    }
+typeSEC_p224r1 = CurvePrime $ CurvePrimeParam 0xffffffffffffffffffffffffffffffff000000000000000000000001
+paramSEC_p224r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffffffffffe
+    , curveEccB = 0xb4050a850c04b3abf54132565044b0b7d7bfd8ba270b39432355ffb4
+    , curveEccG = Point 0xb70e0cbd6bb4bf7f321390b94a03c1d356c21122343280d6115c1d21
+                    0xbd376388b5f723fb4c22dfe6cd4375a05a07476444d5819985007e34
+    , curveEccN = 0xffffffffffffffffffffffffffff16a2e0b8f03e13dd29455c5c2a3d
+    , curveEccH = 1
+    }
+typeSEC_p256k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f
+paramSEC_p256k1 = CurveParameters
+    { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x0000000000000000000000000000000000000000000000000000000000000007
+    , curveEccG = Point 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798
+                    0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8
+    , curveEccN = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141
+    , curveEccH = 1
+    }
+typeSEC_p256r1 = CurvePrime $ CurvePrimeParam 0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff
+paramSEC_p256r1 = CurveParameters
+    { curveEccA = 0xffffffff00000001000000000000000000000000fffffffffffffffffffffffc
+    , curveEccB = 0x5ac635d8aa3a93e7b3ebbd55769886bc651d06b0cc53b0f63bce3c3e27d2604b
+    , curveEccG = Point 0x6b17d1f2e12c4247f8bce6e563a440f277037d812deb33a0f4a13945d898c296
+                    0x4fe342e2fe1a7f9b8ee7eb4a7c0f9e162bce33576b315ececbb6406837bf51f5
+    , curveEccN = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551
+    , curveEccH = 1
+    }
+typeSEC_p384r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000ffffffff
+paramSEC_p384r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000fffffffc
+    , curveEccB = 0xb3312fa7e23ee7e4988e056be3f82d19181d9c6efe8141120314088f5013875ac656398d8a2ed19d2a85c8edd3ec2aef
+    , curveEccG = Point 0xaa87ca22be8b05378eb1c71ef320ad746e1d3b628ba79b9859f741e082542a385502f25dbf55296c3a545e3872760ab7
+                    0x3617de4a96262c6f5d9e98bf9292dc29f8f41dbd289a147ce9da3113b5f0b8c00a60b1ce1d7e819d7a431d7c90ea0e5f
+    , curveEccN = 0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973
+    , curveEccH = 1
+    }
+typeSEC_p521r1 = CurvePrime $ CurvePrimeParam 0x01ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+paramSEC_p521r1 = CurveParameters
+    { curveEccA = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc
+    , curveEccB = 0x0051953eb9618e1c9a1f929a21a0b68540eea2da725b99b315f3b8b489918ef109e156193951ec7e937b1652c0bd3bb1bf073573df883d2c34f1ef451fd46b503f00
+    , curveEccG = Point 0x00c6858e06b70404e9cd9e3ecb662395b4429c648139053fb521f828af606b4d3dbaa14b5e77efe75928fe1dc127a2ffa8de3348b3c1856a429bf97e7e31c2e5bd66
+                    0x011839296a789a3bc0045c8a5fb42c7d1bd998f54449579b446817afbd17273e662c97ee72995ef42640c550b9013fad0761353c7086a272c24088be94769fd16650
+    , curveEccN = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa51868783bf2f966b7fcc0148f709a5d03bb5c9b8899c47aebb6fb71e91386409
+    , curveEccH = 1
+    }
+typeSEC_t113r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
+paramSEC_t113r1 = CurveParameters
+    { curveEccA = 0x003088250ca6e7c7fe649ce85820f7
+    , curveEccB = 0x00e8bee4d3e2260744188be0e9c723
+    , curveEccG = Point 0x009d73616f35f4ab1407d73562c10f
+                    0x00a52830277958ee84d1315ed31886
+    , curveEccN = 0x0100000000000000d9ccec8a39e56f
+    , curveEccH = 2
+    }
+typeSEC_t113r2 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
+paramSEC_t113r2 = CurveParameters
+    { curveEccA = 0x00689918dbec7e5a0dd6dfc0aa55c7
+    , curveEccB = 0x0095e9a9ec9b297bd4bf36e059184f
+    , curveEccG = Point 0x01a57a6a7b26ca5ef52fcdb8164797
+                    0x00b3adc94ed1fe674c06e695baba1d
+    , curveEccN = 0x010000000000000108789b2496af93
+    , curveEccH = 2
+    }
+typeSEC_t131r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
+paramSEC_t131r1 = CurveParameters
+    { curveEccA = 0x07a11b09a76b562144418ff3ff8c2570b8
+    , curveEccB = 0x0217c05610884b63b9c6c7291678f9d341
+    , curveEccG = Point 0x0081baf91fdf9833c40f9c181343638399
+                    0x078c6e7ea38c001f73c8134b1b4ef9e150
+    , curveEccN = 0x0400000000000000023123953a9464b54d
+    , curveEccH = 2
+    }
+typeSEC_t131r2 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
+paramSEC_t131r2 = CurveParameters
+    { curveEccA = 0x03e5a88919d7cafcbf415f07c2176573b2
+    , curveEccB = 0x04b8266a46c55657ac734ce38f018f2192
+    , curveEccG = Point 0x0356dcd8f2f95031ad652d23951bb366a8
+                    0x0648f06d867940a5366d9e265de9eb240f
+    , curveEccN = 0x0400000000000000016954a233049ba98f
+    , curveEccH = 2
+    }
+typeSEC_t163k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000001
+    , curveEccB = 0x000000000000000000000000000000000000000001
+    , curveEccG = Point 0x02fe13c0537bbc11acaa07d793de4e6d5e5c94eee8
+                    0x0289070fb05d38ff58321f2e800536d538ccdaa3d9
+    , curveEccN = 0x04000000000000000000020108a2e0cc0d99f8a5ef
+    , curveEccH = 2
+    }
+typeSEC_t163r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163r1 = CurveParameters
+    { curveEccA = 0x07b6882caaefa84f9554ff8428bd88e246d2782ae2
+    , curveEccB = 0x0713612dcddcb40aab946bda29ca91f73af958afd9
+    , curveEccG = Point 0x0369979697ab43897789566789567f787a7876a654
+                    0x00435edb42efafb2989d51fefce3c80988f41ff883
+    , curveEccN = 0x03ffffffffffffffffffff48aab689c29ca710279b
+    , curveEccH = 2
+    }
+typeSEC_t163r2 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163r2 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000001
+    , curveEccB = 0x020a601907b8c953ca1481eb10512f78744a3205fd
+    , curveEccG = Point 0x03f0eba16286a2d57ea0991168d4994637e8343e36
+                    0x00d51fbc6c71a0094fa2cdd545b11c5c0c797324f1
+    , curveEccN = 0x040000000000000000000292fe77e70c12a4234c33
+    , curveEccH = 2
+    }
+typeSEC_t193r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
+paramSEC_t193r1 = CurveParameters
+    { curveEccA = 0x0017858feb7a98975169e171f77b4087de098ac8a911df7b01
+    , curveEccB = 0x00fdfb49bfe6c3a89facadaa7a1e5bbc7cc1c2e5d831478814
+    , curveEccG = Point 0x01f481bc5f0ff84a74ad6cdf6fdef4bf6179625372d8c0c5e1
+                    0x0025e399f2903712ccf3ea9e3a1ad17fb0b3201b6af7ce1b05
+    , curveEccN = 0x01000000000000000000000000c7f34a778f443acc920eba49
+    , curveEccH = 2
+    }
+typeSEC_t193r2 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
+paramSEC_t193r2 = CurveParameters
+    { curveEccA = 0x0163f35a5137c2ce3ea6ed8667190b0bc43ecd69977702709b
+    , curveEccB = 0x00c9bb9e8927d4d64c377e2ab2856a5b16e3efb7f61d4316ae
+    , curveEccG = Point 0x00d9b67d192e0367c803f39e1a7e82ca14a651350aae617e8f
+                    0x01ce94335607c304ac29e7defbd9ca01f596f927224cdecf6c
+    , curveEccN = 0x010000000000000000000000015aab561b005413ccd4ee99d5
+    , curveEccH = 2
+    }
+typeSEC_t233k1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
+paramSEC_t233k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x017232ba853a7e731af129f22ff4149563a419c26bf50a4c9d6eefad6126
+                    0x01db537dece819b7f70f555a67c427a8cd9bf18aeb9b56e0c11056fae6a3
+    , curveEccN = 0x008000000000000000000000000000069d5bb915bcd46efb1ad5f173abdf
+    , curveEccH = 4
+    }
+typeSEC_t233r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
+paramSEC_t233r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x0066647ede6c332c7f8c0923bb58213b333b20e9ce4281fe115f7d8f90ad
+    , curveEccG = Point 0x00fac9dfcbac8313bb2139f1bb755fef65bc391f8b36f8f8eb7371fd558b
+                    0x01006a08a41903350678e58528bebf8a0beff867a7ca36716f7e01f81052
+    , curveEccN = 0x01000000000000000000000000000013e974e72f8a6922031d2603cfe0d7
+    , curveEccH = 2
+    }
+typeSEC_t239k1 = CurveBinary $ CurveBinaryParam 0x800000000000000000004000000000000000000000000000000000000001
+paramSEC_t239k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x29a0b6a887a983e9730988a68727a8b2d126c44cc2cc7b2a6555193035dc
+                    0x76310804f12e549bdb011c103089e73510acb275fc312a5dc6b76553f0ca
+    , curveEccN = 0x2000000000000000000000000000005a79fec67cb6e91f1c1da800e478a5
+    , curveEccH = 4
+    }
+typeSEC_t283k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
+paramSEC_t283k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x0503213f78ca44883f1a3b8162f188e553cd265f23c1567a16876913b0c2ac2458492836
+                    0x01ccda380f1c9e318d90f95d07e5426fe87e45c0e8184698e45962364e34116177dd2259
+    , curveEccN = 0x01ffffffffffffffffffffffffffffffffffe9ae2ed07577265dff7f94451e061e163c61
+    , curveEccH = 4
+    }
+typeSEC_t283r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
+paramSEC_t283r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x027b680ac8b8596da5a4af8a19a0303fca97fd7645309fa2a581485af6263e313b79a2f5
+    , curveEccG = Point 0x05f939258db7dd90e1934f8c70b0dfec2eed25b8557eac9c80e2e198f8cdbecd86b12053
+                    0x03676854fe24141cb98fe6d4b20d02b4516ff702350eddb0826779c813f0df45be8112f4
+    , curveEccN = 0x03ffffffffffffffffffffffffffffffffffef90399660fc938a90165b042a7cefadb307
+    , curveEccH = 2
+    }
+typeSEC_t409k1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
+paramSEC_t409k1 = CurveParameters
+    { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x0060f05f658f49c1ad3ab1890f7184210efd0987e307c84c27accfb8f9f67cc2c460189eb5aaaa62ee222eb1b35540cfe9023746
+                    0x01e369050b7c4e42acba1dacbf04299c3460782f918ea427e6325165e9ea10e3da5f6c42e9c55215aa9ca27a5863ec48d8e0286b
+    , curveEccN = 0x007ffffffffffffffffffffffffffffffffffffffffffffffffffe5f83b2d4ea20400ec4557d5ed3e3e7ca5b4b5c83b8e01e5fcf
+    , curveEccH = 4
+    }
+typeSEC_t409r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
+paramSEC_t409r1 = CurveParameters
+    { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x0021a5c2c8ee9feb5c4b9a753b7b476b7fd6422ef1f3dd674761fa99d6ac27c8a9a197b272822f6cd57a55aa4f50ae317b13545f
+    , curveEccG = Point 0x015d4860d088ddb3496b0c6064756260441cde4af1771d4db01ffe5b34e59703dc255a868a1180515603aeab60794e54bb7996a7
+                    0x0061b1cfab6be5f32bbfa78324ed106a7636b9c5a7bd198d0158aa4f5488d08f38514f1fdf4b4f40d2181b3681c364ba0273c706
+    , curveEccN = 0x010000000000000000000000000000000000000000000000000001e2aad6a612f33307be5fa47c3c9e052f838164cd37d9a21173
+    , curveEccH = 2
+    }
+typeSEC_t571k1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
+paramSEC_t571k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x026eb7a859923fbc82189631f8103fe4ac9ca2970012d5d46024804801841ca44370958493b205e647da304db4ceb08cbbd1ba39494776fb988b47174dca88c7e2945283a01c8972
+                    0x0349dc807f4fbf374f4aeade3bca95314dd58cec9f307a54ffc61efc006d8a2c9d4979c0ac44aea74fbebbb9f772aedcb620b01a7ba7af1b320430c8591984f601cd4c143ef1c7a3
+    , curveEccN = 0x020000000000000000000000000000000000000000000000000000000000000000000000131850e1f19a63e4b391a8db917f4138b630d84be5d639381e91deb45cfe778f637c1001
+    , curveEccH = 4
+    }
+typeSEC_t571r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
+paramSEC_t571r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x02f40e7e2221f295de297117b7f3d62f5c6a97ffcb8ceff1cd6ba8ce4a9a18ad84ffabbd8efa59332be7ad6756a66e294afd185a78ff12aa520e4de739baca0c7ffeff7f2955727a
+    , curveEccG = Point 0x0303001d34b856296c16c0d40d3cd7750a93d1d2955fa80aa5f40fc8db7b2abdbde53950f4c0d293cdd711a35b67fb1499ae60038614f1394abfa3b4c850d927e1e7769c8eec2d19
+                    0x037bf27342da639b6dccfffeb73d69d78c6c27a6009cbbca1980f8533921e8a684423e43bab08a576291af8f461bb2a8b3531d2f0485c19b16e2f1516e23dd3c1a4827af1b8ac15b
+    , curveEccN = 0x03ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe661ce18ff55987308059b186823851ec7dd9ca1161de93d5174d66e8382e9bb2fe84e47
+    , curveEccH = 2
+    }
diff --git a/cryptonite-backport/Crypto/Error/Types.hs b/cryptonite-backport/Crypto/Error/Types.hs
new file mode 100644
index 00000000..4aaf4e04
--- /dev/null
+++ b/cryptonite-backport/Crypto/Error/Types.hs
@@ -0,0 +1,106 @@
+-- |
+-- Module      : Crypto.Error.Types
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+-- Cryptographic Error enumeration and handling
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Crypto.Error.Types
+    ( CryptoError(..)
+    , CryptoFailable(..)
+    , throwCryptoErrorIO
+    , throwCryptoError
+    , onCryptoFailure
+    , eitherCryptoError
+    , maybeCryptoError
+    ) where
+
+import qualified Control.Exception as E
+import           Data.Data
+
+import           Crypto.Internal.Imports
+
+-- | Enumeration of all possible errors that can be found in this library
+data CryptoError =
+    -- symmetric cipher errors
+      CryptoError_KeySizeInvalid
+    | CryptoError_IvSizeInvalid
+    | CryptoError_AEADModeNotSupported
+    -- public key cryptography error
+    | CryptoError_SecretKeySizeInvalid
+    | CryptoError_SecretKeyStructureInvalid
+    | CryptoError_PublicKeySizeInvalid
+    | CryptoError_SharedSecretSizeInvalid
+    -- elliptic cryptography error
+    | CryptoError_EcScalarOutOfBounds
+    | CryptoError_PointSizeInvalid
+    | CryptoError_PointFormatInvalid
+    | CryptoError_PointFormatUnsupported
+    | CryptoError_PointCoordinatesInvalid
+    -- Message authentification error
+    | CryptoError_MacKeyInvalid
+    | CryptoError_AuthenticationTagSizeInvalid
+    deriving (Show,Eq,Enum,Data,Typeable)
+
+instance E.Exception CryptoError
+
+-- | A simple Either like type to represent a computation that can fail
+--
+-- 2 possibles values are:
+--
+-- * 'CryptoPassed' : The computation succeeded, and contains the result of the computation
+--
+-- * 'CryptoFailed' : The computation failed, and contains the cryptographic error associated
+--
+data CryptoFailable a =
+      CryptoPassed a
+    | CryptoFailed CryptoError
+    deriving (Show)
+
+instance Eq a => Eq (CryptoFailable a) where
+    (==) (CryptoPassed a)  (CryptoPassed b)  = a == b
+    (==) (CryptoFailed e1) (CryptoFailed e2) = e1 == e2
+    (==) _                 _                 = False
+
+instance Functor CryptoFailable where
+    fmap f (CryptoPassed a) = CryptoPassed (f a)
+    fmap _ (CryptoFailed r) = CryptoFailed r
+
+instance Applicative CryptoFailable where
+    pure a     = CryptoPassed a
+    (<*>) fm m = fm >>= \p -> m >>= \r2 -> return (p r2)
+instance Monad CryptoFailable where
+    return a = CryptoPassed a
+    (>>=) m1 m2 = do
+        case m1 of
+            CryptoPassed a -> m2 a
+            CryptoFailed e -> CryptoFailed e
+
+-- | Throw an CryptoError as exception on CryptoFailed result,
+-- otherwise return the computed value
+throwCryptoErrorIO :: CryptoFailable a -> IO a
+throwCryptoErrorIO (CryptoFailed e) = E.throwIO e
+throwCryptoErrorIO (CryptoPassed r) = return r
+
+-- | Same as 'throwCryptoErrorIO' but throw the error asynchronously.
+throwCryptoError :: CryptoFailable a -> a
+throwCryptoError (CryptoFailed e) = E.throw e
+throwCryptoError (CryptoPassed r) = r
+
+-- | Simple 'either' like combinator for CryptoFailable type
+onCryptoFailure :: (CryptoError -> r) -> (a -> r) -> CryptoFailable a -> r
+onCryptoFailure onError _         (CryptoFailed e) = onError e
+onCryptoFailure _       onSuccess (CryptoPassed r) = onSuccess r
+
+-- | Transform a CryptoFailable to an Either
+eitherCryptoError :: CryptoFailable a -> Either CryptoError a
+eitherCryptoError (CryptoFailed e) = Left e
+eitherCryptoError (CryptoPassed a) = Right a
+
+-- | Transform a CryptoFailable to a Maybe
+maybeCryptoError :: CryptoFailable a -> Maybe a
+maybeCryptoError (CryptoFailed _) = Nothing
+maybeCryptoError (CryptoPassed r) = Just r
diff --git a/cryptonite-backport/Crypto/Internal/ByteArray.hs b/cryptonite-backport/Crypto/Internal/ByteArray.hs
new file mode 100644
index 00000000..3a23152d
--- /dev/null
+++ b/cryptonite-backport/Crypto/Internal/ByteArray.hs
@@ -0,0 +1,19 @@
+-- |
+-- Module      : Crypto.Internal.ByteArray
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+-- Simple and efficient byte array types
+--
+{-# OPTIONS_HADDOCK hide #-}
+module Crypto.Internal.ByteArray
+    ( module Data.ByteArray
+    , module Data.ByteArray.Mapping
+    , module Data.ByteArray.Encoding
+    ) where
+
+import Data.ByteArray
+import Data.ByteArray.Mapping
+import Data.ByteArray.Encoding
diff --git a/cryptonite-backport/Crypto/Internal/Compat.hs b/cryptonite-backport/Crypto/Internal/Compat.hs
new file mode 100644
index 00000000..a3712a7c
--- /dev/null
+++ b/cryptonite-backport/Crypto/Internal/Compat.hs
@@ -0,0 +1,48 @@
+-- |
+-- Module      : Crypto.Internal.Compat
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : Good
+--
+-- This module try to keep all the difference between versions of base
+-- or other needed packages, so that modules don't need to use CPP
+--
+{-# LANGUAGE CPP #-}
+module Crypto.Internal.Compat
+    ( unsafeDoIO
+    , popCount
+    , byteSwap64
+    ) where
+
+import System.IO.Unsafe
+import Data.Word
+import Data.Bits
+
+-- | perform io for hashes that do allocation and ffi.
+-- unsafeDupablePerformIO is used when possible as the
+-- computation is pure and the output is directly linked
+-- to the input. we also do not modify anything after it has
+-- been returned to the user.
+unsafeDoIO :: IO a -> a
+#if __GLASGOW_HASKELL__ > 704
+unsafeDoIO = unsafeDupablePerformIO
+#else
+unsafeDoIO = unsafePerformIO
+#endif
+
+#if !(MIN_VERSION_base(4,5,0))
+popCount :: Word64 -> Int
+popCount n = loop 0 n
+  where loop c 0 = c
+        loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1)
+#endif
+
+#if !(MIN_VERSION_base(4,7,0))
+byteSwap64 :: Word64 -> Word64
+byteSwap64 w =
+        (w `shiftR` 56)                  .|. (w `shiftL` 56)
+    .|. ((w `shiftR` 40) .&. 0xff00)     .|. ((w .&. 0xff00) `shiftL` 40)
+    .|. ((w `shiftR` 24) .&. 0xff0000)   .|. ((w .&. 0xff0000) `shiftL` 24)
+    .|. ((w `shiftR` 8)  .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)
+#endif
diff --git a/cryptonite-backport/Crypto/Internal/DeepSeq.hs b/cryptonite-backport/Crypto/Internal/DeepSeq.hs
new file mode 100644
index 00000000..9da79881
--- /dev/null
+++ b/cryptonite-backport/Crypto/Internal/DeepSeq.hs
@@ -0,0 +1,33 @@
+-- |
+-- Module      : Crypto.Internal.DeepSeq
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Simple abstraction module to allow compilation without deepseq
+-- by defining our own NFData class if not compiling with deepseq
+-- support.
+--
+{-# LANGUAGE CPP #-}
+module Crypto.Internal.DeepSeq
+    ( NFData(..)
+    ) where
+
+#ifdef WITH_DEEPSEQ_SUPPORT
+import Control.DeepSeq
+#else
+import Data.Word
+import Data.ByteArray
+
+class NFData a where rnf :: a -> ()
+
+instance NFData Word8 where rnf w = w `seq` ()
+instance NFData Word16 where rnf w = w `seq` ()
+instance NFData Word32 where rnf w = w `seq` ()
+instance NFData Word64 where rnf w = w `seq` ()
+
+instance NFData Bytes where rnf b = b `seq` ()
+instance NFData ScrubbedBytes where rnf b = b `seq` ()
+
+#endif
diff --git a/cryptonite-backport/Crypto/Internal/Imports.hs b/cryptonite-backport/Crypto/Internal/Imports.hs
new file mode 100644
index 00000000..4ed44e16
--- /dev/null
+++ b/cryptonite-backport/Crypto/Internal/Imports.hs
@@ -0,0 +1,16 @@
+-- |
+-- Module      : Crypto.Internal.Imports
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+module Crypto.Internal.Imports
+    ( module X
+    ) where
+
+import Data.Word               as X
+import Control.Applicative     as X
+import Control.Monad           as X (forM, forM_, void)
+import Control.Arrow           as X (first, second)
+import Crypto.Internal.DeepSeq as X
diff --git a/cryptonite-backport/Crypto/PubKey/Curve25519.hs b/cryptonite-backport/Crypto/PubKey/Curve25519.hs
new file mode 100644
index 00000000..42878691
--- /dev/null
+++ b/cryptonite-backport/Crypto/PubKey/Curve25519.hs
@@ -0,0 +1,131 @@
+-- |
+-- Module      : Crypto.PubKey.Curve25519
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Curve25519 support
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.PubKey.Curve25519
+    ( SecretKey
+    , PublicKey
+    , DhSecret
+    -- * Smart constructors
+    , dhSecret
+    , publicKey
+    , secretKey
+    -- * methods
+    , dh
+    , toPublic
+    , generateSecretKey
+    ) where
+
+import           Data.Bits
+import           Data.Word
+import           Foreign.Ptr
+import           Foreign.Storable
+import           GHC.Ptr
+
+-- import           Crypto.Error
+import           Crypto.Error.Types
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes, Bytes, withByteArray)
+import qualified Crypto.Internal.ByteArray as B
+-- import           Crypto.Error (CryptoFailable(..))
+import           Crypto.Random
+
+-- | A Curve25519 Secret key
+newtype SecretKey = SecretKey ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | A Curve25519 public key
+newtype PublicKey = PublicKey Bytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | A Curve25519 Diffie Hellman secret related to a
+-- public key and a secret key.
+newtype DhSecret = DhSecret ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | Try to build a public key from a bytearray
+publicKey :: ByteArrayAccess bs => bs -> CryptoFailable PublicKey
+publicKey bs
+    | B.length bs == 32 = CryptoPassed $ PublicKey $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise         = CryptoFailed CryptoError_PublicKeySizeInvalid
+
+-- | Try to build a secret key from a bytearray
+secretKey :: ByteArrayAccess bs => bs -> CryptoFailable SecretKey
+secretKey bs
+    | B.length bs == 32 = unsafeDoIO $ do
+        withByteArray bs $ \inp -> do
+            valid <- isValidPtr inp
+            if valid
+                then (CryptoPassed . SecretKey) <$> B.copy bs (\_ -> return ())
+                else return $ CryptoFailed CryptoError_SecretKeyStructureInvalid
+    | otherwise = CryptoFailed CryptoError_SecretKeySizeInvalid
+  where
+        --  e[0] &= 0xf8;
+        --  e[31] &= 0x7f;
+        --  e[31] |= 40;
+        isValidPtr :: Ptr Word8 -> IO Bool
+        isValidPtr _ = do
+            --b0  <- peekElemOff inp 0
+            --b31 <- peekElemOff inp 31
+            return True
+{-
+            return $ and [ testBit b0  0 == False
+                         , testBit b0  1 == False
+                         , testBit b0  2 == False
+                         , testBit b31 7 == False
+                         , testBit b31 6 == True
+                         ]
+-}
+{-# NOINLINE secretKey #-}
+
+-- | Create a DhSecret from a bytearray object
+dhSecret :: ByteArrayAccess b => b -> CryptoFailable DhSecret
+dhSecret bs
+    | B.length bs == 32 = CryptoPassed $ DhSecret $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise         = CryptoFailed CryptoError_SharedSecretSizeInvalid
+
+-- | Compute the Diffie Hellman secret from a public key and a secret key
+dh :: PublicKey -> SecretKey -> DhSecret
+dh (PublicKey pub) (SecretKey sec) = DhSecret <$>
+    B.allocAndFreeze 32        $ \result ->
+    withByteArray sec          $ \psec   ->
+    withByteArray pub          $ \ppub   ->
+        ccryptonite_curve25519 result psec ppub
+{-# NOINLINE dh #-}
+
+-- | Create a public key from a secret key
+toPublic :: SecretKey -> PublicKey
+toPublic (SecretKey sec) = PublicKey <$>
+    B.allocAndFreeze 32     $ \result ->
+    withByteArray sec       $ \psec   ->
+        ccryptonite_curve25519 result psec basePoint
+  where
+        basePoint = Ptr "\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+{-# NOINLINE toPublic #-}
+
+-- | Generate a secret key.
+generateSecretKey :: MonadRandom m => m SecretKey
+generateSecretKey = tweakToSecretKey <$> getRandomBytes 32
+  where
+    tweakToSecretKey :: ScrubbedBytes -> SecretKey
+    tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
+        modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
+        modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
+
+    modifyByte :: Ptr Word8 -> Int -> (Word8 -> Word8) -> IO ()
+    modifyByte p n f = peekByteOff p n >>= pokeByteOff p n . f
+
+foreign import ccall "cryptonite_curve25519_donna"
+    ccryptonite_curve25519 :: Ptr Word8 -- ^ public
+                           -> Ptr Word8 -- ^ secret
+                           -> Ptr Word8 -- ^ basepoint
+                           -> IO ()
diff --git a/dht-client.cabal b/dht-client.cabal
new file mode 100644
index 00000000..7c3dcdc3
--- /dev/null
+++ b/dht-client.cabal
@@ -0,0 +1,213 @@
+name:                  dht-client
+version:               0.0.0.4
+license:               BSD3
+license-file:          LICENSE
+author:                Joe Crayne
+maintainer:            Joe Crayne
+copyright:             (c) 2017 Joe Crayne, (c) 2013, Sam Truzjan
+category:              Network
+build-type:            Custom
+cabal-version:         >= 1.10
+tested-with:           GHC == 8.0.2, GHC == 7.10.3
+homepage:              https://github.com/cobit/bittorrent
+bug-reports:           https://github.com/cobit/bittorrent/issues
+synopsis:              BitTorrent DHT protocol implementation.
+description:
+
+  A library for making Haskell bittorrent applications easy.
+  .
+  For more information see:
+  <https://github.com/cobit/bittorrent/blob/master/README.md>
+
+extra-source-files:    res/dapper-dvd-amd64.iso.torrent
+                       res/pkg.torrent
+                       README.md
+                       ChangeLog
+                       cbits/*.h
+
+
+source-repository head
+  type:                git
+  location:            git://github.com/cobit/bittorrent.git
+
+source-repository this
+  type:                git
+  location:            git://github.com/cobit/bittorrent.git
+  branch:              master
+  tag:                 v0.0.0.4
+
+flag network-uri
+  description:         Use network-uri package.
+  default:             True
+
+flag builder
+  description: Use older bytestring package and bytestring-builder.
+  default: False
+
+-- flag aeson
+--   description: Use aeson for pretty-printing bencoded data.
+--   default: True
+
+flag thread-debug
+  description: Add instrumentation to threads.
+  default: True
+
+library
+  default-language:    Haskell2010
+  default-extensions:  PatternGuards
+                     , OverloadedStrings
+                     , RecordWildCards
+                     , NondecreasingIndentation
+  hs-source-dirs:      src, cryptonite-backport, .
+  exposed-modules:  Network.SocketLike
+                    Data.Digest.CRC32C
+                    Data.Bits.ByteString
+                    Data.Wrapper.PSQ
+                    Data.Wrapper.PSQInt
+                    Data.MinMaxPSQ
+                    Network.Address
+                    Network.Kademlia.Bootstrap
+                    Network.Kademlia.Routing
+                    Data.Torrent
+                    Network.BitTorrent.DHT.ContactInfo
+                    Network.BitTorrent.DHT.Token
+                    Network.Kademlia.Search
+                    Network.QueryResponse
+                    Network.StreamServer
+                    Data.BEncode.Pretty
+                    Control.Concurrent.Tasks
+                    Network.Kademlia
+                    Network.BitTorrent.MainlineDHT
+                    Network.BitTorrent.MainlineDHT.Symbols
+                    System.Global6
+                    Data.Word64Map
+                    OnionRouter
+                    Network.Tox
+                    Network.Tox.Transport
+                    Network.Tox.Crypto.Transport
+                    Network.Tox.Crypto.Handlers
+                    Network.Tox.Onion.Handlers
+                    Network.Tox.Onion.Transport
+                    Network.Tox.DHT.Handlers
+                    Network.Tox.DHT.Transport
+                    Network.Tox.NodeId
+                    Network.UPNP
+                    Control.TriadCommittee
+                    Crypto.Tox
+                    Text.XXD
+                    Roster
+                    Announcer
+                    InterruptibleDelay
+
+  build-depends:      base
+                    , containers
+                    , array
+                    , hashable
+                    , iproute
+                    , stm
+                    , base16-bytestring
+                    , base32-bytestring
+                    , base64-bytestring
+                    , psqueues
+                    , reflection
+                    , deepseq
+                    , text
+                    , filepath
+                    , directory
+                    , bencoding
+                    , contravariant
+
+                    , cryptonite
+                    , memory
+                    , time
+                    , random
+                    , entropy
+                    , cpu
+
+                    , cereal
+                    , http-types
+
+                    , process
+                    , split
+                    , pretty
+                    , convertible
+                    , data-default
+
+                    , bifunctors
+                    , lens
+                    , lifted-async
+                    , lifted-base
+                    , monad-control
+                    , transformers-base
+                    , mtl
+                    , ghc-prim
+
+  if impl(ghc < 8)
+      Build-depends:  transformers
+
+  if flag(network-uri)
+      Build-depends:  network      >= 2.6
+                    , network-uri  >= 2.6
+  else
+      Build-depends:  network      >= 2.4 && < 2.6
+
+
+  other-modules:       Paths_dht_client
+                       Crypto.Cipher.Salsa
+                       Crypto.Cipher.XSalsa
+                       Crypto.ECC.Class
+                       Crypto.ECC.Simple.Prim
+                       Crypto.ECC.Simple.Types
+                       Crypto.Error.Types
+                       Crypto.Internal.ByteArray
+                       Crypto.Internal.Compat
+                       Crypto.Internal.DeepSeq
+                       Crypto.Internal.Imports
+                       Crypto.PubKey.Curve25519
+
+  C-sources:           cbits/cryptonite_xsalsa.c, cbits/cryptonite_salsa.c
+
+  -- if flag(aeson)
+  build-depends: aeson, aeson-pretty, unordered-containers, vector
+  cpp-options:   -DBENCODE_AESON
+  if flag(thread-debug)
+    exposed-modules: Control.Concurrent.Lifted.Instrument
+                     Control.Concurrent.Async.Lifted.Instrument
+    cpp-options:   -DTHREAD_DEBUG
+
+  if flag(builder)
+    build-depends: bytestring >= 0.9, bytestring-builder
+  else
+    build-depends: bytestring >= 0.10
+  ghc-options:         -fwarn-missing-signatures -fdefer-typed-holes
+  ghc-prof-options:
+
+
+executable dht
+  hs-source-dirs:      examples
+  main-is:             dht.hs
+  default-language:    Haskell2010
+  build-depends:       base, haskeline, network, bytestring, transformers
+
+executable dhtd
+  hs-source-dirs:      examples
+  main-is:             dhtd.hs
+  default-language:    Haskell2010
+  build-depends:       base, network, bytestring, hashable, deepseq
+                     , aeson
+                     , pretty
+                     , dht-client
+                     , unix
+                     , containers
+                     , stm
+                     , cereal
+                     , bencoding
+                     , unordered-containers
+                     , vector
+                     , text
+
+  if flag(thread-debug)
+    build-depends: time
+    cpp-options:   -DTHREAD_DEBUG
+  ghc-options:         -rtsopts  -fdefer-typed-holes
+
diff --git a/examples/dht.hs b/examples/dht.hs
new file mode 100644
index 00000000..3e1b1656
--- /dev/null
+++ b/examples/dht.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+import Control.Applicative
+import Control.Monad
+import Data.Function
+import Control.Monad.IO.Class
+import Data.Char
+import Data.List
+import Network.Socket as Socket
+import System.Console.Haskeline
+import System.Environment
+import System.Exit
+import System.IO
+import System.IO.Unsafe
+import qualified Data.ByteString as B
+
+-- | Reads one character.  If it is not a digit,
+-- then it is discarded and 'Nothing' is returned.
+hReadDigit :: Handle -> IO (Maybe Char)
+hReadDigit h = do c <- hGetChar h
+                  return $ guard (isDigit c) >> pure c
+
+-- | Expected input: "nnn:..."
+-- Here we read the digit sequence "nnn" and drop the colon
+-- as it is the first non-digit.
+hReadInt :: Handle -> IO Int
+hReadInt h = do
+        nstr <- fix $ \readDigits ->
+                        maybe (return []) -- dropped non-digit character
+                              (($ unsafeInterleaveIO readDigits) . fmap . (:))
+                             =<< hReadDigit h
+        readIO nstr :: IO Int
+
+
+-- | Read a length prefixed string from a handle.
+-- The format is "nnn:..." where /nnn/ is an ascii-encoded character count
+-- and /.../ is the sequence of characters
+--
+-- Note: The first byte after the count is ignored and discarded.
+readResponse :: Handle -> IO (Char, String)
+readResponse h = do
+    c <- hGetChar h
+    n <- hReadInt h
+    s <- sequence $ replicate n (hGetChar h)
+    return (c,s)
+
+-- | Send a command to the dhtd daemon and then print the response.
+sendCommand :: Handle -> String -> InputT IO ()
+sendCommand h cmd = do liftIO $ hPutStrLn h cmd
+                       fix $ \again -> do
+                           (c, resp) <- liftIO $ readResponse h
+                           if c /= '.'
+                            then outputStr resp >> again
+                            else outputStrLn resp
+
+-- | Get one line of input and send it to the daemon, then run the
+-- passed continuation if it wasn't "quit".
+interactiveMode :: Handle -> InputT IO () -> InputT IO ()
+interactiveMode h repl = do
+    minput <- getInputLine "dht> "
+    case minput of
+       Nothing     -> return ()
+       Just "quit" -> sendCommand h "quit" >> return ()
+       Just cmd    -> sendCommand h cmd >> repl
+
+main :: IO ()
+main = do
+    -- Open the control socket to the daemon.
+    h <- liftIO $ handle (\e -> do hPutStrLn stderr (show (e ::IOError))
+                                   exitFailure)
+                  $ do sock <- socket AF_UNIX Stream defaultProtocol
+                       connect sock (SockAddrUnix "dht.sock")
+                       socketToHandle sock ReadWriteMode
+
+    -- Haskeline's default looks only at our stdin and not our stdout.
+    -- That's a bad idea because we can take input from the command line.
+    behavior <- do
+        useTerminal <- and <$> mapM hIsTerminalDevice [stdin,stdout]
+        return $ if useTerminal then preferTerm else useFileHandle stdin
+
+    runInputTBehaviorWithPrefs behavior defaultPrefs defaultSettings $ do
+
+    -- A command may be specified on the command line
+    -- or else we enter an interactive shell.
+    args <- dropWhile isSpace . unwords <$> liftIO getArgs
+    case args of
+        (_:_) -> do
+            let cs = filter (not . null) $ map (drop 1) $ groupBy (\_ c -> (c/=';')) (';':args)
+            forM_ cs $ \cmd -> sendCommand h cmd
+            sendCommand h "quit"
+        _     -> fix $ interactiveMode h
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
new file mode 100644
index 00000000..837cb210
--- /dev/null
+++ b/examples/dhtd.hs
@@ -0,0 +1,1341 @@
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE LambdaCase                #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE NamedFieldPuns            #-}
+{-# LANGUAGE NondecreasingIndentation  #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE PartialTypeSignatures     #-}
+{-# LANGUAGE PatternSynonyms           #-}
+{-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE RecordWildCards           #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE TupleSections             #-}
+{-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE TypeOperators             #-}
+
+module Main where
+
+import Control.Arrow
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.Bool
+import Data.Char
+import Data.Hashable
+import Data.List
+import qualified Data.IntMap.Strict as IntMap
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import qualified Data.Set        as Set
+import Data.Time.Clock
+import GHC.Conc (threadStatus,ThreadStatus(..))
+import GHC.Stats
+import Network.Socket
+import System.Environment
+import System.IO
+import System.Mem
+import System.Posix.Process
+import Text.PrettyPrint.HughesPJClass
+import Text.Printf
+import Text.Read
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+import Announcer
+import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
+import Network.UPNP as UPNP
+import Network.Address hiding (NodeId, NodeInfo(..))
+import Network.QueryResponse
+import Network.StreamServer
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Kademlia.Search
+import qualified Network.BitTorrent.MainlineDHT as Mainline
+import qualified Network.Tox as Tox
+import Network.Kademlia.Routing as R
+import Data.Aeson as J (ToJSON, FromJSON)
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as B
+import Control.Concurrent.Tasks
+import System.IO.Error
+import qualified Data.Serialize as S
+import Network.BitTorrent.DHT.ContactInfo as Peers
+import qualified Data.MinMaxPSQ as MM
+import Data.Wrapper.PSQ as PSQ (pattern (:->))
+import qualified Data.Wrapper.PSQ as PSQ
+import Data.Ord
+import Data.Time.Clock.POSIX
+import qualified Network.Tox.DHT.Transport as Tox
+import qualified Network.Tox.DHT.Handlers as Tox
+import qualified Network.Tox.Onion.Transport as Tox
+import qualified Network.Tox.Onion.Handlers as Tox
+import qualified Network.Tox.Crypto.Handlers as Tox
+import Data.Typeable
+import Roster
+import OnionRouter
+
+showReport :: [(String,String)] -> String
+showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
+
+showColumns :: [[String]] -> String
+showColumns rows = do
+    let cols = transpose rows
+        ws = map (maximum . map (succ . length)) cols
+    fs <- rows
+    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
+    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
+
+
+marshalForClient :: String -> String
+marshalForClient s = show (length s) ++ ":" ++ s
+
+data ClientHandle = ClientHandle Handle (MVar Int)
+
+-- | Writes a message and signals ready for next command.
+hPutClient :: ClientHandle -> String -> IO ()
+hPutClient (ClientHandle h hstate) s = do
+    st <- takeMVar hstate
+    hPutStr h ('.' : marshalForClient s)
+    putMVar hstate 1 -- ready for input
+
+-- | Writes message, but signals there is more to come.
+hPutClientChunk :: ClientHandle -> String -> IO ()
+hPutClientChunk (ClientHandle h hstate) s = do
+    st <- takeMVar hstate
+    hPutStr h (' ' : marshalForClient s)
+    putMVar hstate 2 -- ready for more output
+
+data DHTQuery nid ni = forall addr r tok.
+                        ( Ord addr
+                        , Typeable r
+                        , Typeable tok
+                        , Typeable ni
+                        ) => DHTQuery
+    { qsearch     :: Search nid addr tok ni r
+    , qhandler    :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination.
+    , qshowR      :: r -> String
+    , qshowTok    :: tok -> Maybe String
+    }
+
+data DHTAnnouncable nid = forall dta tok ni r.
+                        ( Show r
+                        , Typeable dta
+                        , Typeable tok
+                        , Typeable r
+                        , Typeable ni
+                        ) => DHTAnnouncable
+    { announceParseData :: String -> Either String dta
+    , announceParseToken :: dta -> String -> Either String tok
+    , announceParseAddress :: String -> Either String ni
+    , announceSendData :: dta -> tok -> Maybe ni -> IO (Maybe r)
+    , announceInterval :: POSIXTime
+    , qresultAddr :: dta -> nid
+    }
+
+data DHTLink = forall status linkid params.
+                ( Show status
+                , Show linkid
+                , Typeable status
+                , Typeable linkid
+                , Typeable params
+                ) => DHTLink
+    { linkInit    :: params -> IO (Either String status)
+    , linkParamParser :: [String] -> Either String params
+    , linkStatus  :: IO (Either String status)
+    , showLinkStatus :: status -> String
+    , linkNewPipe :: String -> linkid -> IO (Either String status)
+    , linkUnPipe  :: linkid -> IO (Either String status)
+    }
+
+data DHTSearch nid ni = forall addr tok r. DHTSearch
+    { searchThread     :: ThreadId
+    , searchState      :: SearchState nid addr tok ni r
+    , searchShowTok    :: tok -> Maybe String
+    , searchResults    :: TVar (Set.Set String)
+    }
+
+data DHTPing ni = forall r. DHTPing
+    { pingQuery :: [String] -> ni -> IO (Maybe r)
+    , pingShowResult :: r -> String
+    }
+
+data DHT = forall nid ni. ( Show     ni
+                          , Read     ni
+                          , ToJSON   ni
+                          , FromJSON ni
+                          , Ord      ni
+                          , Hashable ni
+                          , Show     nid
+                          , Ord      nid
+                          , Hashable nid
+                          , Typeable ni
+                          , S.Serialize nid
+                          ) =>
+    DHT
+    { dhtBuckets       :: TVar (BucketList ni)
+    , dhtSecretKey     :: STM (Maybe SecretKey)
+    , dhtPing          :: Map.Map String (DHTPing ni)
+    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
+    , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid)
+    , dhtLinks         :: Map.Map String DHTLink
+    , dhtParseId       :: String -> Either String nid
+    , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
+    , dhtFallbackNodes :: IO [ni]
+    , dhtBootstrap     :: [ni] -> [ni] -> IO ()
+    }
+
+nodesFileName :: String -> String
+nodesFileName netname = netname ++ "-nodes.json"
+
+saveNodes :: String -> DHT -> IO ()
+saveNodes netname DHT{dhtBuckets} = do
+    bkts <- atomically $ readTVar dhtBuckets
+    let ns = map fst $ concat $ R.toList bkts
+        bs = J.encode ns
+        fname = nodesFileName netname
+    L.writeFile fname bs
+
+loadNodes :: FromJSON ni => String -> IO [ni]
+loadNodes netname = do
+    let fname = nodesFileName netname
+    attempt <- tryIOError $ do
+        J.decode <$> L.readFile fname
+         >>= maybe (ioError $ userError "Nothing") return
+    either (const $ fallbackLoad fname) return attempt
+
+fallbackLoad :: FromJSON t => FilePath -> IO [t]
+fallbackLoad fname = do
+    attempt <- tryIOError $ do
+        J.decode <$> L.readFile fname
+         >>= maybe (ioError $ userError "Nothing") return
+    let go r = do
+            let m = HashMap.lookup "nodes" (r :: J.Object)
+                ns0 = case m of Just (J.Array v) -> V.toList v
+                                Nothing        -> []
+                ns1 = zip (map J.fromJSON ns0) ns0
+                issuc (J.Error _,_) = False
+                issuc _             = True
+                (ss,fs) = partition issuc ns1
+                ns = map (\(J.Success n,_) -> n) ss
+            mapM_ print (map snd fs)  >> return ns
+    either (const $ return []) go attempt
+
+
+{-
+pingNodes :: String -> DHT -> IO Bool
+pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
+    let fname = nodesFileName netname
+    attempt <- tryIOError $ do
+        J.decode <$> L.readFile fname
+         >>= maybe (ioError $ userError "Nothing") return
+-}
+
+asProxyTypeOf :: a -> proxy a -> a
+asProxyTypeOf = const
+
+pingNodes :: String -> DHT -> IO (Maybe Int)
+pingNodes netname dht@DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "ping" dhtPing = do
+    let fname = nodesFileName netname
+    ns <- loadNodes netname
+    case ns of
+        [] -> return Nothing
+        _ -> do
+            fork $ do
+                 myThreadId >>= flip labelThread ("pinging."++fname)
+                 putStrLn $ "Forked "++show fname
+                 withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do
+                   forM_ (ns `asTypeOf` [])
+                        $ \n -> forkTask g (show n)
+                                $ void
+                                $ ping [] n
+                 putStrLn $ "Load finished "++show fname
+            return $ Just $ length ns
+pingNodes _ _ = return Nothing
+
+
+
+reportTable :: Show ni => BucketList ni -> [(String,String)]
+reportTable bkts = map (show *** show . fst)
+                 $ concat
+                 $ zipWith map (map (,) [0::Int ..])
+                 $ R.toList
+                 $ bkts
+
+reportResult ::
+    String
+    -> (r -> String)
+    -> (tok -> Maybe String)
+    -> (ni -> String)
+    -> ClientHandle
+    -> Either String ([ni],[r],Maybe tok)
+    -> IO ()
+reportResult meth showR showTok showN h (Left e)            = hPutClient h e
+reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do
+    hPutClient h $ showReport report
+ where
+    report = intercalate [("","")] [ tok_r , node_r , result_r ]
+
+    tok_r = maybe [] (pure . ("token:",)) $ showTok =<< tok
+
+    node_r = map ( ("n",) . showN ) ns
+
+    result_r | (meth=="node") = []
+             | otherwise      = map ( (take 1 meth,) . showR ) rs
+
+-- example:
+-- * 10 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
+-- - 1  peer 141d6c6ee2810f46d28bbe8373d4f454a4122535
+--   22 node 141d6c6ee2810f46d28bbe8373d4f454a4122535
+--
+-- key: '*' in progress
+--      '-' stopped
+--      ' ' finished
+showSearches :: ( Show nid
+                , Ord nid
+                , Hashable nid
+                , Ord ni
+                , Hashable ni
+                ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String
+showSearches searches = do
+    tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do
+        (is'fin, cnt) <- atomically $
+                (,) <$> searchIsFinished searchState
+                    <*> (Set.size <$> readTVar searchResults)
+        tstat <- threadStatus searchThread
+        let stat = case tstat of
+                _ | is'fin     -> ' '
+                ThreadFinished -> '-'
+                ThreadDied     -> '-'
+                _              -> '*'
+        return (stat,show cnt,meth,show nid)
+    let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups
+        mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups
+    return $ do -- List monad.
+        (stat,cnt,meth,nid) <- tups
+        printf "  %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid
+
+forkSearch ::
+    ( Ord nid
+    , Hashable nid
+    , Ord ni
+    , Hashable ni
+    , Show nid
+    ) =>
+    String
+    -> nid
+    -> DHTQuery nid ni
+    -> TVar (Map.Map (String,nid) (DHTSearch nid ni))
+    -> TVar (BucketList ni)
+    -> ThreadId
+    -> TVar (Maybe (IO ()))
+    -> STM ()
+forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets  tid kvar = do
+    ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets
+    st <- newSearch qsearch nid ns
+    results <- newTVar Set.empty
+    let storeResult r = modifyTVar' results (Set.insert (qshowR r))
+                        >> return True
+        new = DHTSearch
+            { searchThread  = tid
+            , searchState   = st
+            , searchShowTok = qshowTok
+            , searchResults = results
+            }
+    modifyTVar' dhtSearches $ Map.insert (method,nid) new
+    -- Finally, we write the search loop action into a tvar that will be executed in a new
+    -- thread.
+    writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st
+
+reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) =>
+                                   String -> ClientHandle -> DHTSearch t1 t -> IO ()
+reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do
+    (ns,rs) <- atomically $ do
+        mm <- readTVar $ searchInformant searchState
+        rset <- readTVar searchResults
+        let ns = map (\(MM.Binding ni tok _) -> (ni,tok))
+                     $ MM.toList mm
+            rs = Set.toList rset
+        return (ns,rs)
+    let n'width       = succ $ maximum $ map (length . show . fst) ns
+        showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok =<< tok)
+        ns'           = map showN ns
+    reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))
+
+data Session = Session
+    { netname           :: String
+    , dhts              :: Map.Map String DHT
+    , externalAddresses :: IO [SockAddr]
+    , swarms            :: Mainline.SwarmsDatabase
+    , cryptosessions    :: Tox.NetCryptoSessions
+    , toxkeys           :: TVar Tox.AnnouncedKeys
+    , userkeys          :: TVar [(SecretKey,PublicKey)]
+    , roster            :: Roster
+    , onionRouter       :: OnionRouter
+    , announcer         :: Announcer
+    , signalQuit        :: MVar ()
+    }
+
+exceptionsToClient :: ClientHandle -> IO () -> IO ()
+exceptionsToClient (ClientHandle h hstate) action =
+    action `catch` \(SomeException e) -> do
+                        st <- takeMVar hstate
+                        when (st /= 1) $ do
+                            hPutStr h ('.': marshalForClient (show e))
+                        putMVar hstate 1 -- ready for input
+
+hGetClientLine :: ClientHandle -> IO String
+hGetClientLine (ClientHandle h hstate) = do
+    st <- takeMVar hstate
+    -- st should be 1
+    x <- hGetLine h
+    putMVar hstate 0 -- ready for output
+    return x
+
+hCloseClient :: ClientHandle -> IO ()
+hCloseClient (ClientHandle h hstate) = do
+    st <- takeMVar hstate
+    hClose h
+    putMVar hstate 3 -- closed file handle
+
+clientSession0 :: Session -> t1 -> t -> Handle -> IO ()
+clientSession0 s sock cnum h = do
+    hstate <- newMVar 1 -- ready for input
+    clientSession s sock cnum (ClientHandle h hstate)
+  `catch` \e -> if isEOFError e then return ()
+                                else throwIO e
+
+clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
+clientSession s@Session{..} sock cnum h = do
+    line <- dropWhile isSpace <$> hGetClientLine h
+    let (c,args) = second (dropWhile isSpace) $ break isSpace line
+        cmd0 :: IO () -> IO ()
+        cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h
+        switchNetwork dest = do hPutClient h ("Network: "++dest)
+                                clientSession s{netname=dest} sock cnum h
+        strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
+            where
+                dropEnd (x,_) =
+                    case B.unsnoc x of
+                                 Just (str,c) | isSpace c -> (str,False)
+                                 _ -> (x,True)
+    let mkrow :: (SecretKey, PublicKey) -> (String,String)
+        mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b))
+        mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__])
+        sessionCommands :: [[String]]
+        sessionCommands =
+            [ ["stop"]
+            , ["quit"]
+            , ["pid"]
+            , ["external-ip"]
+            , ["threads"]
+            , ["mem"]
+            , ["ls"]
+            , ["k"]
+            , ["roster"]
+            , ["onion"]
+            , ["g"]
+            , ["p"]
+            , ["a"]
+            , ["s"]
+            , ["x"]
+            , ["save"]
+            , ["load"]
+            , ["swarms"]
+            , ["peers"]
+            , ["toxids"]
+            , ["c"]
+            , ["help"]
+            , ["throw"]
+            ]
+    case (map toLower c,args) of
+        (n, _) | n `elem` Map.keys dhts -> switchNetwork n
+        -- "ping"
+        -- "cookie"
+        (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts
+                      , Just DHTPing{ pingQuery=ping
+                                    , pingShowResult=showr } <- Map.lookup pinglike dhtPing
+                      , ws@(_:_) <- words s
+                    -> cmd0 $ do
+                        case readEither $ last ws of
+                          Right addr -> do result <- ping (init ws) addr
+                                           let rs = [" ", maybe "Timeout." showr result]
+                                           hPutClient h $ unlines rs
+                          Left er -> hPutClient h er
+        (x,_) | not (null (strp x))
+              , x `notElem` map head sessionCommands -> cmd0 $ do
+                hPutClient h $ "error."
+
+        ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
+                          hCloseClient h
+                          putMVar signalQuit ()
+
+        ("throw", er) -> cmd0 $ do
+                            throwIO $ userError er
+                            hPutClient h "The impossible happened!"
+
+        ("quit", _) -> hPutClient h "" >> hCloseClient h
+
+        ("pid", _) -> cmd0 $ do
+                    pid <- getProcessID
+                    hPutClient h (show pid)
+        ("external-ip", _) -> cmd0 $ do
+                    unlines . map (either show show . either4or6) <$> externalAddresses
+                        >>= hPutClient h
+#ifdef THREAD_DEBUG
+        ("threads", _) -> cmd0 $ do
+                    ts <- threadsInformation
+                    tm <- getCurrentTime
+                    r <- forM ts $ \(tid,PerThread{..}) -> do
+                        stat <- threadStatus tid
+                        let showStat (ThreadBlocked reason) = show reason
+                            showStat stat                   = show stat
+                        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
+                    hPutClient h $ showColumns r
+#endif
+        ("mem", s) -> cmd0 $ do
+                    case s of
+                        "gc" -> do hPutClient h "Performing garbage collection..."
+                                   performMajorGC
+                        "" -> do
+                            is_enabled <- getGCStatsEnabled
+                            if is_enabled
+                             then do
+                                GCStats{..} <- getGCStats
+                                let r = [ ("bytesAllocated", show bytesAllocated)
+                                        , ("numGcs", show numGcs)
+                                        , ("maxBytesUsed", show maxBytesUsed)
+                                        , ("numByteUsageSamples", show numByteUsageSamples)
+                                        , ("cumulativeBytesUsed", show cumulativeBytesUsed)
+                                        , ("bytesCopied", show bytesCopied)
+                                        , ("currentBytesUsed", show currentBytesUsed)
+                                        , ("currentBytesSlop", show currentBytesSlop)
+                                        , ("maxBytesSlop", show maxBytesSlop)
+                                        , ("peakMegabytesAllocated", show peakMegabytesAllocated)
+                                        , ("mutatorCpuSeconds", show mutatorCpuSeconds)
+                                        , ("mutatorWallSeconds", show mutatorWallSeconds)
+                                        , ("gcCpuSeconds", show gcCpuSeconds)
+                                        , ("gcWallSeconds", show gcWallSeconds)
+                                        , ("cpuSeconds", show cpuSeconds)
+                                        , ("wallSeconds", show wallSeconds)
+                                        , ("parTotBytesCopied", show parTotBytesCopied)
+                                        , ("parMaxBytesCopied", show parMaxBytesCopied)
+                                        ]
+                                hPutClient h $ showReport r
+                            else hPutClient h "Run with +RTS -T to obtain live memory-usage information."
+                        _ -> hPutClient h "error."
+
+        ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        bkts <- atomically $ readTVar dhtBuckets
+                        let r = reportTable bkts
+                        hPutClient h $
+                            showReport $
+                                    r ++ [ ("buckets", show $ R.shape bkts)
+                                         , ("node-id", show $ thisNode bkts)
+                                         , ("network", netname) ]
+
+        --  TODO: online documentation.
+        --
+        --  k - manage key-pairs
+        --
+        --      k                  (list keys)
+        --      k gen              (generate new key and list keys)
+        --      k add <secret-key> (input a specific secret key)
+        --      k del <secret-key>
+        --      k secrets          (list key pairs, including secret keys)
+
+        ("k", s) | ""           <- strp s -> cmd0 $ do
+                        ks <- atomically $ readTVar userkeys
+                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) ks
+                 | "gen"        <- strp s -> cmd0 $ do
+                        secret <- generateSecretKey
+                        let pubkey = toPublic secret
+                        oldks <- atomically $ do
+                            ks <- readTVar userkeys
+                            modifyTVar userkeys ((secret,pubkey):)
+                            addRoster roster secret
+                            return ks
+                        let asString = show . Tox.key2id
+                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
+                                                  ++ [mappend " *" . show . Tox.key2id $ pubkey]
+                 | "secrets"    <- strp s -> cmd0 $ do
+                        ks <- atomically $ readTVar userkeys
+                        skey <- maybe (return Nothing) (atomically . dhtSecretKey)
+                                      $ Map.lookup netname dhts
+                        hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of
+                            Just x  -> [("",""),("dht-key:",B.unpack x)]
+                            Nothing -> []
+                 | ("add":secs) <- words s
+                 , mbSecs <- map (decodeSecret . B.pack) secs
+                 , all isJust mbSecs -> cmd0 $ do
+                        let f (Just b) = b
+                            f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
+                        let toPair x = (x,toPublic x)
+                            pairs = map (toPair . f) mbSecs
+                        oldks <- atomically $ do
+                            oldks <- readTVar userkeys
+                            modifyTVar userkeys (pairs ++)
+                            forM pairs $ \(sk,_) -> addRoster roster sk
+                            return oldks
+                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
+                                                  ++ map (mappend " *" . show . Tox.key2id .snd) pairs
+                 | ("del":secs) <- words s
+                 , mbSecs <- map (decodeSecret . B.pack) secs
+                 , all isJust mbSecs -> cmd0 $ do
+                        let f (Just b) = b
+                            f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
+                        let toPair x = (x,toPublic x)
+                            pairs = map (toPair . f) mbSecs
+                        ks <- atomically $ do
+                            modifyTVar userkeys (filter (`notElem` pairs) )
+                            forM pairs $ \(_,pk) -> delRoster roster pk
+                            readTVar userkeys
+                        hPutClient h . showReport $ map mkrow ks
+
+        ("roster", s) -> cmd0 $ join $ atomically $ do
+            dns <- dnsPresentation roster
+            fs <- HashMap.toList <$> friendRequests roster
+            let showFriend (remotekey,fr) =
+                    ("  " ++ show remotekey, T.unpack $ T.decodeUtf8 $ Tox.friendRequestText fr)
+                showAccount (me,cs) =
+                    [(show me,"")] ++ map showFriend cs
+                frs = fs >>= showAccount
+            return $ do
+                hPutClientChunk h $ unlines [ dns, "", "Friend Requests" ]
+                hPutClient h $ showReport frs
+
+        ("onion", s) -> cmd0 $ join $ atomically $ do
+            rm <- readTVar $ routeMap onionRouter
+            ts <- readTVar $ trampolineNodes onionRouter
+            rs <- mapM readTVar (pendingRoutes onionRouter)
+            let showRecord :: Int -> Bool -> [String]
+                showRecord n True = [show n, "pending", ""]
+                showRecord n False
+                    | Just RouteRecord{responseCount,timeoutCount} <- IntMap.lookup n rm
+                                = [show n, show responseCount, show timeoutCount]
+                    | otherwise = [show n, "error!",""]
+                r = map (uncurry showRecord) $ IntMap.toAscList rs
+            return $ do
+                hPutClientChunk h $ "trampolines: " ++ show (IntMap.size ts) ++ "\n"
+                hPutClient h $ showColumns $ ["","responses","timeouts"]:r
+
+
+        ("g", s) | Just DHT{..} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        -- arguments: method
+                        --            nid
+                        --            (optional dest-ni)
+                        self <- atomically $ thisNode <$> readTVar dhtBuckets
+                        let (method,xs) = break isSpace $ dropWhile isSpace s
+                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
+                            destination = dropWhile isSpace ys
+                            goQuery qry = either (hPutClient h . ("Bad search target: "++))
+                                                 (goTarget qry)
+                                                 $ dhtParseId nidstr
+                            goTarget DHTQuery{..} nid =
+                                go nid >>= reportResult method qshowR qshowTok show h
+                              where
+                                go | null destination = fmap Right . qhandler self
+                                   | otherwise        = case readEither destination of
+                                        Right ni -> fmap (maybe (Left "Timeout.") Right)
+                                                    . flip (searchQuery qsearch) ni
+                                        Left  e  -> const $ return $ Left ("Bad destination: "++e)
+                        maybe (hPutClient h ("Unsupported method: "++method))
+                              goQuery
+                              $ Map.lookup method dhtQuery
+
+        -- TODO: Online help.
+        --
+        -- p - put/publish a single given datum on a single given node.
+        --
+        --         When destination address (node-addr) is optional, it's absense means to
+        --         publish information in the local node's own database.
+        --
+        --         Bittorrent: (peer) publish yourself as peer in swarm.
+        --                     (port) set your current bittorrent listen port.
+        --
+        --             p peer <infohash> <token> [node-addr]
+        --
+        --             p port <num>
+        --
+        --         Tox: (toxid) publish a rendezvous onion route to dht node.
+        --              (friend) send a friend-request over a rendezvous point.
+        --              (dhtkey) send your dht node-id over a rendezvous point.
+        --
+        --             p toxid <key> <token> <node-addr>
+        --
+        --             p friend <key> <nospam> <rendezvous-addr> <text>
+        --
+        --             p dhtkey <key> - <rendezvous-addr>
+
+        ("p", s) | Just DHT{..} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        -- arguments: method
+                        --            data
+                        --            token
+                        --            (optional dest-ni)
+                        self <- atomically $ thisNode <$> readTVar dhtBuckets
+                        let (method,xs) = break isSpace $ dropWhile isSpace s
+                            (dtastr,ys) = break isSpace $ dropWhile isSpace xs
+                            (tokenstr,zs) = break isSpace $ dropWhile isSpace ys
+                            destination = dropWhile isSpace zs
+                            goTarget DHTAnnouncable{..} = do
+                                let dta = announceParseData dtastr
+                                    tok = dta >>= flip announceParseToken tokenstr
+                                case liftA2 (,) dta tok of
+                                    Left e    -> hPutClient h e
+                                    Right nid -> go nid >>= either (hPutClient h) (hPutClient h . show)
+                              where
+                                go | null destination = fmap (maybe (Left "Timeout.") Right)
+                                                        . flip (uncurry announceSendData) Nothing
+                                   | otherwise        = case announceParseAddress destination of
+                                        Right ni -> fmap (maybe (Left "Timeout.") Right)
+                                                    . flip (uncurry announceSendData) (Just ni)
+                                        Left  e  -> const $ return $ Left ("Bad destination: "++e)
+                        maybe (hPutClient h ("Unsupported method: "++method))
+                              goTarget
+                              $ Map.lookup method dhtAnnouncables
+
+        -- TODO: Online documentation.
+        --
+        -- a - announce, like put/publish but automatically selects nodes to publish on
+        --     and periodically refreshes them.
+        --
+        --     The method name is preceded with a + to start or a - to stop a given
+        --     recurring publication.
+        --
+        --     BitTorrent: (peer) Every minute, announce you are participating
+        --                        in a torrent swarm.
+        --
+        --         a +peer <infohash> a -peer <infohash>
+        --
+        --     Tox: (toxid) Every 15 seconds, announce your tox identity to the
+        --                  DHT so friends can find you.
+        --
+        --         a +toxid <key>
+        --         a -toxid <key>
+        --
+        --       These probably don't work:
+        --         (experimental) a +friend <nospam> <text>
+        --         (experimental) a +dhtkey
+        ("a", s) | Just DHT{..} <- Map.lookup netname dhts
+                 , not (null s)
+                    -> cmd0 $ do
+                        let (op:method,xs) = break isSpace $ dropWhile isSpace s
+                            (dtastr,ys)    = break isSpace $ dropWhile isSpace xs
+                            a = Map.lookup method dhtAnnouncables
+                            q = Map.lookup method dhtQuery
+                            doit :: Char -> Announcer -> AnnounceKey -> AnnounceMethod r -> r -> IO ()
+                            doit '+' = schedule
+                            doit '-' = cancel
+                            doit _   = \_ _ _ _ -> hPutClientChunk h "Starting(+) or canceling(-)?"
+                            matchingResult ::
+                                ( Typeable stok
+                                , Typeable ptok
+                                , Typeable sni
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (stok :~: ptok, sni :~: pni)
+                            matchingResult _ _ = liftA2 (,) eqT eqT
+                            matchingTok ::
+                                ( Typeable stok
+                                , Typeable ptok
+                                , Typeable sni
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (stok :~: ptok)
+                            matchingTok _ _ = eqT
+                            matchingNI ::
+                                ( Typeable stok
+                                , Typeable ptok
+                                , Typeable sni
+                                , Typeable pni )
+                                            => Search nid addr stok sni sr
+                                            -> (pr -> ptok -> Maybe pni -> IO (Maybe pubr))
+                                            -> Maybe (sni :~: pni)
+                            matchingNI _ _ = eqT
+                            chktok :: Maybe ()
+                            chktok = do
+                                DHTAnnouncable { announceSendData
+                                               , announceParseData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                Refl <- matchingTok qsearch announceSendData
+                                return ()
+                            chkni :: Maybe ()
+                            chkni = do
+                                DHTAnnouncable { announceSendData
+                                               , announceParseData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                Refl <- matchingNI qsearch announceSendData
+                                return ()
+                            mameth = do
+                                DHTAnnouncable { announceSendData
+                                               , announceParseData
+                                               , announceInterval
+                                               , qresultAddr } <- a
+                                DHTQuery { qsearch } <- q
+                                (Refl, Refl) <- matchingResult qsearch announceSendData
+                                -- return $ hPutClient h "Type matches."
+                                dta <- either (const Nothing) Just $ announceParseData dtastr
+                                return $ do
+                                    akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr)
+                                    doit op announcer
+                                            akey
+                                            (AnnounceMethod qsearch announceSendData dhtBuckets
+                                                            (qresultAddr dta)
+                                                            announceInterval)
+                                            dta
+                                    case op of
+                                        '+' -> hPutClient h $ "Announcing at " ++ show (qresultAddr dta) ++ "."
+                                        '-' -> hPutClient h $ "Canceling " ++ show (qresultAddr dta) ++ "."
+                        let aerror = unlines
+                                [ "announce error."
+                                , "method = " ++ method
+                                , "query = " ++ maybe "nil" (const "ok") q
+                                , "publish = " ++ maybe "nil" (const "ok") a
+                                , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil
+                                , "chkni = " ++ maybe "nil" (const "ok") chkni
+                                ]
+                        fromMaybe (hPutClient h aerror) mameth
+
+        ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        let (method,xs) = break isSpace s
+                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
+                            presentSearches = hPutClient h
+                                              =<< showSearches
+                                              =<< atomically (readTVar dhtSearches)
+                            goTarget qry nid = do
+                                kvar <- atomically $ newTVar Nothing
+                                -- Forking a thread, but it may ubruptly quit if the following
+                                -- STM action decides not to add a new search.  This is so that
+                                -- I can store the ThreadId into new DHTSearch structure.
+                                tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return)
+                                join $ atomically $ do
+                                    schs <- readTVar dhtSearches
+                                    case Map.lookup (method,nid) schs of
+                                        Nothing  -> do forkSearch method nid qry dhtSearches dhtBuckets tid kvar
+                                                       return $ presentSearches
+                                        Just sch -> do writeTVar kvar (Just $ return ())
+                                                       return $ reportSearchResults method h sch
+                            goQuery qry = either (hPutClient h . ("Bad search target: "++))
+                                                 (goTarget qry)
+                                                 $ dhtParseId nidstr
+                        if null method then presentSearches
+                                       else maybe (hPutClient h ("Unsupported method: "++method))
+                                                  goQuery
+                                                  $ Map.lookup method dhtQuery
+
+        ("x", s) | Just DHT{..} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        let (method,xs) = break isSpace s
+                            (nidstr,ys) = break isSpace $ dropWhile isSpace xs
+                            go nid = join $ atomically $ do
+                                schs <- readTVar dhtSearches
+                                case Map.lookup (method,nid) schs of
+                                    Nothing -> return $ hPutClient h "No match."
+                                    Just DHTSearch{searchThread} -> do
+                                        modifyTVar' dhtSearches (Map.delete (method,nid))
+                                        return $ do
+                                            killThread searchThread
+                                            hPutClient h "Removed search."
+                        either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr
+
+        ("save", _) | Just dht <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        saveNodes netname dht
+                        hPutClient h $ "Saved " ++ nodesFileName netname ++ "."
+
+        ("load", _) | Just dht <- Map.lookup netname dhts
+                    -> cmd0 $ do
+                        b <- pingNodes netname dht
+                        case b of
+                            Just num ->
+                                  hPutClient h $ unwords [ "Pinging"
+                                                         , show num
+                                                         , "nodes from"
+                                                         , nodesFileName netname ++ "."
+                                                         ]
+                            Nothing ->
+                                  hPutClient h $ "Failed: " ++ nodesFileName netname ++ "."
+
+        ("swarms", s) -> cmd0 $ do
+                    let fltr = case s of
+                                    ('-':'v':cs) | all isSpace (take 1 cs)
+                                      -> const True
+                                    _ -> (\(h,c,n) -> c/=0 )
+                    ss <- atomically $ Peers.knownSwarms <$> readTVar (Mainline.contactInfo swarms)
+                    let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n))
+                            $ filter fltr ss
+                    hPutClient h $ showReport r
+
+        ("peers", s) -> cmd0 $ case readEither s of
+                        Right ih -> do
+                            ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms)
+                            hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
+                        Left er -> hPutClient h er
+        ("toxids", s) -> cmd0 $ do
+                        keydb <- atomically $ readTVar toxkeys
+                        now <- getPOSIXTime
+                        let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb)
+                            mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ]
+                                where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
+                        hPutClient h $ showColumns entries
+        ("c", s) | "" <- strp s -> cmd0 $ do
+                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
+                        -- TODO: list all connections
+                        let connections =  [[{-TODO-}]]
+                        hPutClient h $ showColumns connections
+        ("c", s) -> cmd0 $ do
+                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
+                        -- form new connection according of type corresponding to parameter
+                        let ws = words s
+                        result
+                          <- case ws of
+                              (linktype:rest)
+                                -> case (Map.lookup (head ws) combinedLinkMap) of
+                                    Nothing -> return . Left $ "I don't know a '" ++ head ws ++ "' link type."
+                                    Just l@(DHTLink
+                                              { linkInit        {- :: params   -> IO (Either String status) -}
+                                              , linkParamParser {- :: [String] -> Either String params      -}
+                                              , showLinkStatus  {- :: status   -> String                    -}
+                                              }) -> case linkParamParser rest of
+                                                        Left er -> return $ Left er
+                                                        Right params -> fmap showLinkStatus <$> linkInit params
+                              _ -> return $ Left "parse error"
+                        case result of
+                            Left er -> hPutClient h er
+                            Right statusstr -> hPutClient h statusstr
+
+        ("help", s) | Just DHT{..} <- Map.lookup netname dhts
+                    -> cmd0 $ do
+            let tolist :: a -> [a]
+                tolist = (:[])
+
+                dhtkeys, announcables, links, ks, allcommands :: [[String]]
+                dhtkeys = map tolist $ Map.keys dhts
+                queries = map (tolist . ("s "++)) $ Map.keys dhtQuery
+                xs = map (tolist . ("x "++)) $ Map.keys dhtQuery
+                gs = map (tolist . ("g "++)) $ Map.keys dhtQuery
+                announcables = map (tolist . ("p "++)) $ Map.keys dhtAnnouncables
+                links = map (tolist . ("c "++)) $ Map.keys dhtLinks
+                ks = [["k gen"],["k public"],["k secret"]]
+                allcommands = sortBy (comparing head) $ concat [sessionCommands, dhtkeys, announcables, links, ks, queries, gs,xs]
+
+            hPutClient h ("Available commands:\n" ++ showColumns allcommands)
+
+        _    -> cmd0 $ hPutClient h "error."
+
+
+readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
+readExternals nodeAddr vars = do
+    as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars
+    let unspecified (SockAddrInet _ 0)              = True
+        unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True
+        unspecified _                               = False
+    -- TODO: Filter to only global addresses?
+    return $ filter (not . unspecified) as
+
+data Options = Options
+    { portbt  :: String
+    , porttox :: String
+    , ip6bt   :: Bool
+    , ip6tox  :: Bool
+    , dhtkey  :: Maybe SecretKey
+    }
+ deriving (Eq,Show)
+
+sensibleDefaults :: Options
+sensibleDefaults = Options
+    { portbt  = "6881"
+    , porttox = "33445"
+    , ip6bt   = True
+    , ip6tox  = True
+    , dhtkey  = Nothing
+    }
+
+-- bt=<port>,tox=<port>
+-- -4
+parseArgs :: [String] -> Options -> Options
+parseArgs []          opts         = opts
+parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
+    { dhtkey = decodeSecret $ B.pack k }
+parseArgs ("-4":args) opts         = parseArgs args opts
+    { ip6bt  = False
+    , ip6tox = False }
+parseArgs (arg:args) opts          = parseArgs args opts
+    { portbt  = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
+    , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports }
+ where
+    ports = map ( (dropWhile (==',') *** dropWhile (=='='))
+                . break (=='=') )
+                $ groupBy (const (/= ',')) arg
+
+noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
+noArgPing f [] x = f x
+noArgPing _ _  _ = return Nothing
+
+main :: IO ()
+main = do
+    args <- getArgs
+    let opts = parseArgs args sensibleDefaults
+    print opts
+
+    swarms <- Mainline.newSwarmsDatabase
+    -- Restore peer database before forking the listener thread.
+    peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
+    either (hPutStrLn stderr . ("bt-peers.dat: "++))
+           (atomically . writeTVar (Mainline.contactInfo swarms))
+           (peerdb >>= S.decodeLazy)
+
+    announcer <- forkAnnouncer
+
+    (quitBt,btdhts,btips,baddrs) <- case portbt opts of
+        "" -> return (return (), Map.empty,return [],[])
+        p  -> do
+            addr <- getBindAddress p (ip6bt opts)
+            (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr
+            quitBt <- forkListener "bt" (clientNet bt)
+            mainlineSearches <- atomically $ newTVar Map.empty
+            peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
+            let mainlineDHT bkts wantip = DHT
+                    { dhtBuckets = bkts btR
+                    , dhtPing    = Map.singleton "ping" $ DHTPing
+                                        { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
+                                        , pingShowResult = show
+                                        }
+                    , dhtQuery   = Map.fromList
+                                    [ ("node", DHTQuery
+                                        { qsearch = (Mainline.nodeSearch bt)
+                                        , qhandler = (\ni -> fmap Mainline.unwrapNodes
+                                                                . Mainline.findNodeH btR ni
+                                                                . flip Mainline.FindNode (Just Want_Both))
+                                        , qshowR = show
+                                        , qshowTok = (const Nothing)
+                                        })
+                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
+                                    -- sr = InfoHash
+                                    -- stok = Token
+                                    -- sni = NodeInfo
+                                    , ("peer", DHTQuery
+                                        { qsearch = (Mainline.peerSearch bt)
+                                        , qhandler = (\ni -> fmap Mainline.unwrapPeers
+                                                                . Mainline.getPeersH btR swarms ni
+                                                                . flip Mainline.GetPeers (Just Want_Both)
+                                                                . (read . show)) -- TODO: InfoHash -> NodeId
+                                        , qshowR = (show . pPrint)
+                                        , qshowTok = (Just . show)
+                                        })
+                                    ]
+                    , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
+                    , dhtSearches = mainlineSearches
+                    , dhtFallbackNodes = Mainline.bootstrapNodes wantip
+                    , dhtAnnouncables = Map.fromList
+                                    -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
+                                    -- dta = Announce
+                                    -- pr = Announced
+                                    -- ptok = Token
+                                    -- pni = NodeInfo
+                                    [ ("peer", DHTAnnouncable { announceSendData = \ih tok -> \case
+                                                                    Just ni -> do
+                                                                        port <- atomically $ readTVar peerPort
+                                                                        let dta = Mainline.mkAnnounce port ih tok
+                                                                        Mainline.announce bt dta ni
+                                                                    Nothing -> return Nothing
+                                                              , announceParseAddress = readEither
+                                                              , announceParseData = readEither
+                                                              , announceParseToken = const $ readEither
+                                                              , announceInterval = 60 -- TODO: Is one minute good?
+                                                              , qresultAddr = (read . show) -- TODO: InfoHash -> NodeId -- peer
+                                                              })
+                                    , ("port", DHTAnnouncable { announceParseData = readEither
+                                                              , announceParseToken = \_ _ -> return ()
+                                                              , announceParseAddress = const $ Right ()
+                                                              , announceSendData = \dta () -> \case
+                                                                    Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
+                                                                                  return $ Just dta
+                                                                    Just _ -> return Nothing
+                                                              , announceInterval = 0 -- TODO: The "port" setting should probably
+                                                                                     -- be a command rather than an announcement.
+                                                              , qresultAddr = const $ Mainline.zeroID
+                                                              })]
+
+                    , dhtLinks = Map.fromList
+                                    [ {- TODO -}
+                                    ]
+                    , dhtSecretKey = return Nothing
+                    , dhtBootstrap = case wantip of
+                                        Want_IP4 -> btBootstrap4
+                                        Want_IP6 -> btBootstrap6
+                    }
+                dhts = Map.fromList $
+                        ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
+                        : if ip6bt opts
+                            then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
+                            else []
+                ips :: IO [SockAddr]
+                ips = readExternals Mainline.nodeAddr
+                                        [ Mainline.routing4 btR
+                                        , Mainline.routing6 btR
+                                        ]
+            return (quitBt,dhts,ips, [addr])
+
+    keysdb <- Tox.newKeysDatabase
+
+    crypto <- Tox.newCrypto
+    netCryptoSessionsState <- Tox.newSessionsState crypto Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
+
+    (mbtox,quitTox,toxdhts,toxips,taddrs) <- case porttox opts of
+        "" -> return (Nothing,return (), Map.empty, return [],[])
+        toxport -> do
+            addrTox <- getBindAddress toxport (ip6tox opts)
+            hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
+            tox <- Tox.newTox keysdb addrTox (Just netCryptoSessionsState) (dhtkey opts)
+            (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox
+
+            toxSearches <- atomically $ newTVar Map.empty
+
+            let toxDHT bkts wantip = DHT
+                    { dhtBuckets = bkts (Tox.toxRouting tox)
+                    , dhtPing    = Map.fromList
+                                    [ ("ping", DHTPing
+                                            { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox)
+                                            , pingShowResult = show
+                                            })
+                                    , ("cookie", DHTPing
+                                            { pingQuery = \case
+                                                [keystr] | Just mykey <- readMaybe keystr
+                                                         -> Tox.cookieRequest (Tox.toxCryptoKeys tox)
+                                                                              (Tox.toxDHT tox)
+                                                                              (Tox.id2key mykey)
+                                                _        -> const $ return Nothing
+                                            , pingShowResult = show
+                                            })]
+                    , dhtQuery   = Map.fromList
+                                    [ ("node", DHTQuery
+                                        { qsearch = (Tox.nodeSearch $ Tox.toxDHT tox)
+                                        , qhandler = (\ni -> fmap Tox.unwrapNodes
+                                                                . Tox.getNodesH (Tox.toxRouting tox) ni
+                                                                . Tox.GetNodes)
+                                        , qshowR = show -- NodeInfo
+                                        , qshowTok = (const Nothing)
+                                        })
+                                    , ("toxid", DHTQuery
+                                        { qsearch = (Tox.toxidSearch (Tox.onionTimeout tox)
+                                                                          (Tox.toxCryptoKeys tox)
+                                                                          (Tox.toxOnion tox))
+                                        , qhandler = -- qhandler :: ni -> nid -> IO ([ni], [r], tok)
+                                                         (\ni nid ->
+                                                            Tox.unwrapAnnounceResponse Nothing
+                                                                <$> clientAddress (Tox.toxDHT tox) Nothing
+                                                                <*> Tox.announceH (Tox.toxRouting tox)
+                                                                                  (Tox.toxTokens tox)
+                                                                                  (Tox.toxAnnouncedKeys tox)
+                                                                                  (Tox.OnionDestination Tox.SearchingAlias ni Nothing)
+                                                                                  (Tox.AnnounceRequest zeros32 nid Tox.zeroID))
+                                        , qshowR  = show -- Rendezvous
+                                        , qshowTok = Just . show -- Nonce32
+                                        })
+                                    ]
+                    , dhtParseId  = readEither :: String -> Either String Tox.NodeId
+                    , dhtSearches = toxSearches
+                    , dhtFallbackNodes = return []
+                    , dhtAnnouncables = Map.fromList
+                                    [ ("toxid", DHTAnnouncable { announceSendData = \pubkey token -> \case
+                                                                    Just ni ->
+                                                                        Tox.putRendezvous
+                                                                            (Tox.onionTimeout tox)
+                                                                            (Tox.toxCryptoKeys tox)
+                                                                            (Tox.toxOnion tox)
+                                                                            (pubkey :: PublicKey)
+                                                                            (token :: Nonce32)
+                                                                            ni
+                                                                    Nothing -> return Nothing
+                                                               , announceParseAddress = readEither
+                                                               , announceParseToken = const $ readEither
+                                                               , announceParseData = fmap Tox.id2key . readEither
+                                                               , qresultAddr = Tox.key2id -- toxid
+
+                    -- For peers we are announcing ourselves to, if we are not
+                    -- announced to them toxcore tries every 3 seconds to
+                    -- announce ourselves to them until they return that we
+                    -- have announced ourselves to, then toxcore sends an
+                    -- announce request packet every 15 seconds to see if we
+                    -- are still announced and re announce ourselves at the
+                    -- same time. The timeout of 15 seconds means a `ping_id`
+                    -- received in the last packet will not have had time to
+                    -- expire (20 second minimum timeout) before it is resent
+                    -- 15 seconds later. Toxcore sends every announce packet
+                    -- with the `ping_id` previously received from that peer
+                    -- with the same path (if possible).
+                                                               , announceInterval = 15
+
+                                                               })
+                                    , ("dhtkey", DHTAnnouncable { announceSendData = \pubkey () -> \case
+                                                                    Just addr -> do
+                                                                        dkey <- Tox.getContactInfo tox
+                                                                        sendMessage
+                                                                            (Tox.toxToRoute tox)
+                                                                            (addr :: Tox.AnnouncedRendezvous)
+                                                                            (pubkey,Tox.OnionDHTPublicKey dkey)
+                                                                        return $ Just ()
+                                                                    Nothing -> return Nothing
+                                                               , announceParseAddress = readEither
+                                                               , announceParseToken = \_ _ -> return ()
+                                                               , announceParseData = fmap Tox.id2key . readEither
+                                                               , qresultAddr = Tox.key2id
+
+                    -- We send this packet every 30 seconds if there is more
+                    -- than one peer (in the 8) that says they our friend is
+                    -- announced on them. This packet can also be sent through
+                    -- the DHT module as a DHT request packet (see DHT) if we
+                    -- know the DHT public key of the friend and are looking
+                    -- for them in the DHT but have not connected to them yet.
+                    -- 30 second is a reasonable timeout to not flood the
+                    -- network with too many packets while making sure the
+                    -- other will eventually receive the packet. Since packets
+                    -- are sent through every peer that knows the friend,
+                    -- resending it right away without waiting has a high
+                    -- likelihood of failure as the chances of packet loss
+                    -- happening to all (up to to 8) packets sent is low.
+                    --
+                                                               , announceInterval = 30
+
+                                                               })
+                                    , ("friend", DHTAnnouncable { announceSendData = \pubkey nospam -> \case
+                                                                    Just addr -> do
+                                                                        let fr = Tox.FriendRequest nospam txt
+                                                                            -- nospam = 0xD64A8B00
+                                                                            txt = "Testing Friend Request!"
+                                                                        sendMessage
+                                                                            (Tox.toxToRoute tox)
+                                                                            (addr :: Tox.AnnouncedRendezvous)
+                                                                            (pubkey,Tox.OnionFriendRequest fr)
+                                                                        return $ Just ()
+                                                                    Nothing -> return Nothing
+                                                               , announceParseAddress = readEither
+                                                               , announceParseData = fmap Tox.id2key . readEither
+                                                               , announceParseToken = \pubkey nospamstr -> do
+                                                                        Tox.NoSpam nospam chksum <- readEither nospamstr
+                                                                        maybe (Right ())
+                                                                              (Tox.verifyChecksum pubkey)
+                                                                              chksum
+                                                                        return nospam
+                                                                , qresultAddr = Tox.key2id
+
+                    -- Friend requests are sent with exponentially increasing
+                    -- interval of 2 seconds, 4 seconds, 8 seconds, etc... in
+                    -- toxcore. This is so friend requests get resent but
+                    -- eventually get resent in intervals that are so big that
+                    -- they essentially expire. The sender has no way of
+                    -- knowing if a peer refuses a friend requests which is why
+                    -- friend requests need to expire in some way.  Note that
+                    -- the interval is the minimum timeout, if toxcore cannot
+                    -- send that friend request it will try again until it
+                    -- manages to send it. One reason for not being able to
+                    -- send the friend request would be that the onion has not
+                    -- found the friend in the onion and so cannot send an
+                    -- onion data packet to them.
+                    --
+                    -- TODO: Support exponential backoff behavior.  For now, setting
+                    -- interval to 8 seconds.
+
+                                                               , announceInterval = 8
+                                                               })]
+                    , dhtLinks = Map.fromList
+                                    [ {- TODO -}
+                                    ]
+                    , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
+                    , dhtBootstrap = case wantip of
+                                        Want_IP4 -> toxStrap4
+                                        Want_IP6 -> toxStrap6
+                    }
+                dhts = Map.fromList $
+                        ("tox4", toxDHT Tox.routing4 Want_IP4)
+                        : if ip6tox opts
+                            then [ ("tox6", toxDHT Tox.routing6 Want_IP6) ]
+                            else []
+                ips :: IO [SockAddr]
+                ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
+                                                 , Tox.routing6 $ Tox.toxRouting tox ]
+            return (Just tox, quitTox, dhts, ips, [addrTox])
+    _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
+
+    let dhts = Map.union btdhts toxdhts
+
+    waitForSignal <- do
+        signalQuit <- newEmptyMVar
+        let defaultToxData = do
+                toxids <- atomically $ newTVar []
+                rster <- newRoster
+                orouter <- newOnionRouter (hPutStrLn stderr)
+                return (toxids, rster, orouter)
+        (toxids,rstr,orouter) <- fromMaybe defaultToxData $ do
+            tox <- mbtox
+            return $ return ( userKeys (Tox.toxCryptoKeys tox), Tox.toxRoster tox, Tox.toxOnionRoutes tox )
+        let session = clientSession0 $ Session
+                { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
+                , dhts              = dhts  -- all DHTs
+                , signalQuit        = signalQuit
+                , swarms            = swarms
+                , cryptosessions    = netCryptoSessionsState
+                , toxkeys           = keysdb
+                , userkeys          = toxids
+                , roster            = rstr
+                , onionRouter       = orouter
+                , externalAddresses = liftM2 (++) btips toxips
+                , announcer         = announcer
+                }
+        srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
+        return $ do
+            () <- takeMVar signalQuit
+            quitListening srv
+
+
+    forM_ (Map.toList dhts)
+          $ \(netname, dht@DHT { dhtBuckets = bkts
+                               , dhtQuery = qrys
+                               , dhtPing = pings
+                               , dhtFallbackNodes = getBootstrapNodes
+                               , dhtBootstrap = bootstrap }) -> do
+        btSaved <- loadNodes netname --  :: IO [Mainline.NodeInfo]
+        putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"."
+        fallbackNodes <- getBootstrapNodes
+        let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
+            isNodesSearch Refl sch = sch
+            ping = maybe (const $ return False)
+                         (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery [])
+                         $ Map.lookup "ping" pings
+        fork $ do
+            myThreadId >>= flip labelThread ("bootstrap."++netname)
+            bootstrap btSaved fallbackNodes
+        return ()
+
+    waitForSignal
+
+    stopAnnouncer announcer
+    quitBt
+    quitTox
+
+    swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms)
+    L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb
diff --git a/readpackets.hs b/readpackets.hs
new file mode 100644
index 00000000..f02df538
--- /dev/null
+++ b/readpackets.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE PackageImports #-}
+module Main where
+
+import           Data.Binary.Get      (runGet)
+import qualified Data.ByteString      as BS
+import qualified Data.ByteString      as B
+import qualified Data.ByteString.Lazy as LZ
+import qualified Data.ByteString.Lazy.Char8 as L8
+import           Data.IORef
+import           Data.List
+import           Debug.Trace
+import           Text.Printf
+import           Text.Show.Pretty     as PP
+import "network-house" Net.Packet
+import qualified "network-house" Net.IPv4 as IP4
+import qualified "network-house" Net.IPv6 as IP6
+import "network-house" Net.PacketParsing
+import "network-house" Net.UDP as UDP
+import "pcap"          Network.Pcap
+import qualified Data.Serialize as S
+import qualified Network.Socket as HS
+import Control.Applicative
+
+import Crypto.Tox
+import Network.Tox.DHT.Transport as Tox
+import Data.BEncode as BE
+import Data.BEncode.Pretty
+-- import Data.IKE.Message
+
+-- traceM string = trace string $ return ()
+
+bs2chunk :: BS.ByteString -> UArray Int Word8
+bs2chunk bs = listArray (0,subtract 33 $ BS.length bs) $ drop 32 $ BS.unpack bs
+
+hex :: BS.ByteString -> String
+hex = concatMap (printf "%02x") . B.unpack
+
+hexlines :: BS.ByteString -> [String]
+hexlines bs = ss
+    where xs = zip [0..] $ hex bs
+          ls = groupBy (\(n,_) (m,_)-> n `div` 32 == m `div` 32) xs
+          ss = map (map snd) ls
+
+parsePacket :: IORef Int -> PktHdr -> BS.ByteString -> IO ()
+parsePacket cnt hdr buf = do
+    print hdr
+    let -- mb :: Maybe (BS.ByteString, Message Encrypted)
+        mb = do
+            udp <- doParse $ toInPack $ bs2chunk buf
+            -- traceM $ "got udp: " ++ show udp
+            -- traceM $ "got udp content: " ++ show (content udp)
+            let plen = Net.Packet.len $ content udp
+            bs <- fmap BS.pack . parseInPacket (bytes plen) $ content udp
+            -- traceM $ "Got bs " ++ show bs
+            let (checksum,blob) = BS.splitAt 2 bs -- extra 2 bytes in pcap capture, i'm assuming its a checksum
+--                 (first4,truncated) = BS.splitAt 4 blob
+--                 -- First 4 bytes being zero is how we distinguish between
+--                 -- ESP and IKEv2 packets on port 4500.
+--                 dta = if destPort udp /= Port 500 && first4==BS.pack [0,0,0,0]
+--                         then truncated
+--                         else blob
+                dta = blob
+            let d = BE.decode {- runGet getMessage $ LZ.fromStrict -} dta
+                saddr = HS.SockAddrInet 0 0 -- TODO
+                -- e = S.decode dta :: Either String (DHTMessage Encrypted8)
+                e = case Tox.parseDHTAddr (dta,saddr) :: Either (DHTMessage Encrypted8,NodeInfo) (BS.ByteString,HS.SockAddr) of
+                        Left toxpkt -> Right toxpkt
+                        Right _     -> Left "tox parse fail"
+            return $ (udp, bs, fmap Left d <|> fmap Right e)
+    flip (maybe $ return ()) mb $ \(udp, bs,m) -> do
+        putStrLn $ show udp
+        mapM_ putStrLn $ hexlines bs
+        -- putStrLn $ PP.ppShow m
+        either putStrLn (L8.putStrLn . either showBEncode (L8.pack . show)) m
+    modifyIORef' cnt (+1)
+
+main = do
+    cnt <- newIORef 0
+    pcap <- openOffline "packets.pcap"
+    loopResult <- loopBS pcap (-1) $ parsePacket cnt
+    pktcnt <- readIORef cnt
+    putStrLn $ "read "++show pktcnt ++" packets."
diff --git a/src/Control/Concurrent/Async/Lifted/Instrument.hs b/src/Control/Concurrent/Async/Lifted/Instrument.hs
new file mode 100644
index 00000000..eab0fadc
--- /dev/null
+++ b/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/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
new file mode 100644
index 00000000..7e4a7356
--- /dev/null
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Control.Concurrent.Lifted.Instrument
+    ( module Control.Concurrent.Lifted
+    , forkIO
+    , fork
+    , labelThread
+    , threadsInformation
+    , PerThread(..)
+    ) where
+
+import qualified Control.Concurrent.Lifted as Raw
+import Control.Concurrent.Lifted hiding (fork)
+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 System.IO
+import Control.Monad.IO.Class
+
+
+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 = hPutStrLn stderr
+    }
+{-# NOINLINE globals #-}
+
+
+forkIO :: IO () -> IO ThreadId
+forkIO = fork
+{-# INLINE forkIO #-}
+
+fork :: (MonadBaseControl IO m, MonadIO m) => m () -> m ThreadId
+fork action = do
+    t <- Raw.fork $ 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           -> liftIO $ 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/src/Control/Concurrent/Tasks.hs b/src/Control/Concurrent/Tasks.hs
new file mode 100644
index 00000000..287542ee
--- /dev/null
+++ b/src/Control/Concurrent/Tasks.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE CPP #-}
+module Control.Concurrent.Tasks where
+
+import Control.Concurrent.STM
+import Control.Exception
+import Data.Function
+import Data.List
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+newtype TaskGroup = TaskGroup
+    { taskQueue :: TChan (String,IO ())
+    }
+
+withTaskGroup :: String -> Int -> (TaskGroup -> IO ()) -> IO ()
+withTaskGroup glabel numslots action = do
+    tg <- atomically $ newTChan
+    cnt <- atomically $ newTVar 0
+    thread <- fork $ do
+        myThreadId >>= flip labelThread glabel
+        fix $ \again -> do
+            (slot, (lbl,task)) <- atomically $ do
+                slot <- readTVar cnt
+                check (slot < numslots)
+                writeTVar cnt (succ slot)
+                t <- readTChan tg
+                return (slot,t)
+            _ <- fork $ do
+                myThreadId >>= flip labelThread (intercalate "." [glabel,show slot,lbl])
+                task `catch` (\(SomeException e) -> return ())
+                atomically $ modifyTVar' cnt pred
+            again
+    action (TaskGroup tg) `onException` killThread thread
+    atomically $ do
+        isEmptyTChan tg >>= check
+        readTVar cnt >>= check . (== 0)
+    killThread thread
+
+forkTask :: TaskGroup -> String -> IO () -> IO ()
+forkTask (TaskGroup q) lbl action = atomically $ writeTChan q (lbl,action)
diff --git a/src/Control/TriadCommittee.hs b/src/Control/TriadCommittee.hs
new file mode 100644
index 00000000..88e665b6
--- /dev/null
+++ b/src/Control/TriadCommittee.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE TupleSections #-}
+module Control.TriadCommittee where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Maybe
+
+
+data TriadSlot = SlotA | SlotB | SlotC
+ deriving (Eq,Ord,Enum,Show,Read)
+
+data TriadCommittee voter a = TriadCommittee
+    { triadDecider :: TVar TriadSlot
+    , triadA :: TVar (Maybe (voter,a))
+    , triadB :: TVar (Maybe (voter,a))
+    , triadC :: TVar (Maybe (voter,a))
+    , triadNewDecision :: a -> STM ()
+    }
+
+triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
+triadSlot SlotA = triadA
+triadSlot SlotB = triadB
+triadSlot SlotC = triadC
+
+triadDecision :: a -> TriadCommittee voter a -> STM a
+triadDecision fallback triad = do
+    slot <- readTVar (triadDecider triad)
+    maybe fallback snd <$> readTVar (triadSlot slot triad)
+
+
+newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
+newTriadCommittee onChange =
+    TriadCommittee <$> newTVar SlotA
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> newTVar Nothing
+                   <*> pure onChange
+
+
+triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
+triadCountVotes prior triad = do
+    a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
+    b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
+    c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
+    let (slot,vote) = case catMaybes [a,b,c] of
+            [  (x,xvote)
+             , (y,yvote)
+             , (z,zvote) ]  -> if xvote == yvote then (x,Just xvote)
+                                                 else (z,Just zvote)
+            []              -> (SlotA,Nothing)
+            ((slot,vote):_) -> (slot, Just vote)
+    writeTVar (triadDecider triad) slot
+    case vote of
+        Just v | vote /= prior -> triadNewDecision triad v
+        _                      -> return ()
+
+
+addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
+addVote triad voter vote = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let avail (_,Nothing) = True
+        avail (_,Just x ) = (x == voter)
+        slots = filter avail [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad)
+                  (Just (voter,vote))
+        triadCountVotes prior triad
+
+
+delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
+delVote triad voter = do
+    a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
+    b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
+    c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
+    let match (_,Just x ) = (x == voter)
+        match _           = False
+        slots = filter match [a,b,c]
+    forM_ (take 1 slots) $ \(slot,_) -> do
+        prior <- do
+            slotp <- readTVar (triadDecider triad)
+            fmap snd <$> readTVar (triadSlot slotp triad)
+        writeTVar (triadSlot slot triad) Nothing
+        triadCountVotes prior triad
+
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs
new file mode 100644
index 00000000..665a38dd
--- /dev/null
+++ b/src/Crypto/Tox.hs
@@ -0,0 +1,571 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module Crypto.Tox
+    ( PublicKey
+    , publicKey
+    , getPublicKey
+    , putPublicKey
+    , SecretKey
+    , generateSecretKey
+    , toPublic
+    , SymmetricKey(..)
+    , TransportCrypto(..)
+    , SecretsCache
+    , newSecretsCache
+    , Encrypted
+    , Encrypted8(..)
+    , type (∘)(..)
+    , Asymm(..)
+    , getAsymm
+    , getAliasedAsymm
+    , putAsymm
+    , putAliasedAsymm
+    , Plain
+    , encodePlain
+    , decodePlain
+    -- , computeSharedSecret
+    , lookupSharedSecret
+    , encrypt
+    , decrypt
+    , Nonce8(..)
+    , Nonce24(..)
+    , incrementNonce24
+    , addtoNonce24
+    , Nonce32(..)
+    , getRemainingEncrypted
+    , putEncrypted
+    , Auth
+    , Sized(..)
+    , Size(..)
+    , State(..)
+    , zeros32
+    , zeros24
+    , decryptSymmetric
+    , encryptSymmetric
+    , encodeSecret
+    , decodeSecret
+    ) where
+
+import Control.Arrow
+import Control.Monad
+import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
+import qualified Crypto.Cipher.Salsa    as Salsa
+import qualified Crypto.Cipher.XSalsa   as XSalsa
+import Crypto.ECC.Class
+import qualified Crypto.Error           as Cryptonite
+import qualified Crypto.MAC.Poly1305    as Poly1305
+import Crypto.PubKey.Curve25519
+import Data.Bits
+import qualified Data.ByteArray         as BA
+         ;import Data.ByteArray         as BA (ByteArrayAccess, Bytes)
+import Data.ByteString                  as B
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Char8  as C8
+import Data.Data
+import Data.Functor.Contravariant
+#if MIN_VERSION_base(4,9,1)
+import Data.Kind
+#else
+import GHC.Exts (Constraint)
+#endif
+import Data.Ord
+import Data.Serialize as S
+import Data.Word
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import System.Endian
+import qualified Data.ByteString.Internal
+import Control.Concurrent.STM
+import Crypto.Error.Types                     (CryptoFailable (..), throwCryptoError)
+import Network.Socket (SockAddr)
+import GHC.Exts (Word(..),inline)
+import GHC.Prim
+import Data.Word64Map (fitsInInt)
+import Data.MinMaxPSQ (MinMaxPSQ')
+import qualified Data.MinMaxPSQ as MM
+import Data.Time.Clock.POSIX
+import Data.Hashable
+import System.IO.Unsafe (unsafeDupablePerformIO)
+
+-- | A 16-byte mac and an arbitrary-length encrypted stream.
+newtype Encrypted a = Encrypted ByteString
+ deriving (Eq,Ord,Data,ByteArrayAccess)
+
+newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
+ deriving (Serialize, Show)
+
+newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }
+
+infixr ∘
+
+newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
+instance Ord Auth where
+    compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
+instance Data Auth where
+    gfoldl k z x = z x
+    -- Well, this is a little wonky... XXX
+    gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
+    toConstr _ = con_Auth
+    dataTypeOf _ = mkDataType "Crypto.Tox" [con_Auth]
+con_Auth :: Constr
+con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
+instance Serialize Auth where
+    get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
+    put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
+
+instance Typeable a => Show (Encrypted a) where
+    show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a))
+
+encryptedAuth :: Encrypted a -> Auth
+encryptedAuth (Encrypted bs)
+    | Right auth <- decode (B.take 16 bs) = auth
+    | otherwise                           = error "encryptedAuth: insufficient bytes"
+
+authAndBytes :: Encrypted a -> (Auth, ByteString)
+authAndBytes (Encrypted bs) = (auth,bs')
+ where
+    (as,bs')   = B.splitAt 16 bs
+    Right auth = decode as
+
+-- | Info about a type's serialized length. Either the length is known
+-- independently of the value, or the length depends on the value.
+data Size a
+    = VarSize (a -> Int)
+    | ConstSize !Int
+    deriving Typeable
+
+instance Contravariant Size where
+  contramap f sz = case sz of
+      ConstSize n -> ConstSize n
+      VarSize g   -> VarSize (\x -> g (f x))
+
+instance Monoid (Size a) where
+    ConstSize x `mappend` ConstSize y = ConstSize (x + y)
+    VarSize f   `mappend` ConstSize y = VarSize $ \x -> f x + y
+    ConstSize x `mappend` VarSize g   = VarSize $ \y -> x + g y
+    VarSize f   `mappend` VarSize g   = VarSize $ \x -> f x + g x
+    mempty = ConstSize 0
+
+
+class Sized a where size :: Size a
+
+instance Sized a => Serialize (Encrypted a) where
+    get = case size :: Size a of
+            VarSize _   -> Encrypted <$> (remaining >>= getBytes)
+            ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
+    put = putEncrypted
+
+instance Sized a => Sized (Encrypted a) where
+    size = case size :: Size a of
+        ConstSize n -> ConstSize $ n + 16
+        VarSize _   -> VarSize $ \(Encrypted bs) -> B.length bs
+
+instance (Sized a, Sized b) => Sized (a,b) where
+    size = case (size :: Size a, size :: Size b) of
+        (ConstSize a , ConstSize b) -> ConstSize $ a + b
+        (VarSize f   , ConstSize b) -> VarSize $ \(a, _) -> f a + b
+        (ConstSize a , VarSize g)   -> VarSize $ \(_, b) -> a + g b
+        (VarSize f   , VarSize g)   -> VarSize $ \(a, b) -> f a + g b
+
+getRemainingEncrypted :: Get (Encrypted a)
+getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)
+
+putEncrypted :: Encrypted a -> Put
+putEncrypted (Encrypted bs) = putByteString bs
+
+newtype Plain (s:: * -> Constraint) a = Plain ByteString
+
+
+decodePlain :: Serialize a => Plain Serialize a -> Either String a
+decodePlain (Plain bs) = decode bs
+
+encodePlain :: Serialize a => a -> Plain Serialize a
+encodePlain a = Plain $ encode a
+
+storePlain :: Storable a => a -> IO (Plain Storable a)
+storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a)
+
+retrievePlain :: Storable a => Plain Storable a -> IO a
+retrievePlain (Plain bs) = BA.withByteArray bs peek
+
+decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a)
+decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do
+    let sym_nonce_bytes = B.take 12 n24
+        (mac, bs'')     = B.splitAt 16 bs
+    symm <- left show . Cryptonite.eitherCryptoError $ do
+        sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
+        Symmetric.initialize symmkey sym_nonce
+    let (ds, symm') = Symmetric.decrypt bs'' symm
+        auth = Symmetric.finalize symm'
+    if BA.convert auth /= mac
+        then Left "symmetricDecipher: Auth fail."
+        else return $ Plain ds
+
+encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x
+encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es
+ where
+    Cryptonite.CryptoPassed es = do
+        sym_nonce <- Symmetric.nonce12 (BA.take 12 n24)
+        symm <- Symmetric.initialize symmkey sym_nonce
+        let (rpath_bs, symm') = Symmetric.encrypt bs symm
+            auth = Symmetric.finalize symm' -- 16 bytes
+        return (BA.convert auth `BA.append` rpath_bs)
+
+
+data State = State Poly1305.State XSalsa.State
+
+decrypt :: State -> Encrypted a -> Either String (Plain s a)
+decrypt (State hash crypt) ciphertext
+    | (a == mac) = Right (Plain m)
+    | otherwise  = Left "decipherAndAuth: auth fail"
+  where
+    (mac, c) = authAndBytes ciphertext
+    m = fst . XSalsa.combine crypt $ c
+    a = Auth . Poly1305.finalize . Poly1305.update hash $ c
+
+-- Encrypt-then-Mac:  Encrypt the cleartext, then compute the MAC on the
+-- ciphertext, and prepend it to the ciphertext
+encrypt :: State -> Plain s a -> Encrypted a
+encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c
+  where
+    c = fst . XSalsa.combine crypt $ m
+    a = Auth . Poly1305.finalize . Poly1305.update hash $ c
+
+-- (Poly1305.State, XSalsa.State)
+computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
+computeSharedSecret sk recipient = k `seq` \nonce ->
+    let -- cipher state
+        st0 = XSalsa.initialize 20 k nonce
+        -- Poly1305 key
+        (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
+        -- Since rs is 32 bytes, this pattern should never fail...
+        Cryptonite.CryptoPassed hash = Poly1305.initialize rs
+    in State hash crypt
+ where
+    -- diffie helman
+    shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
+    -- shared secret XSalsa key
+    k = hsalsa20 shared zeros24
+
+unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64
+unsafeFirstWord64 ba = unsafeDupablePerformIO $ BA.withByteArray ba peek
+{-# INLINE unsafeFirstWord64 #-}
+
+instance Hashable PublicKey where
+    hashWithSalt salt pk = hashWithSalt salt (unsafeFirstWord64 pk)
+    {-# INLINE hashWithSalt #-}
+
+instance Hashable SecretKey where
+    hashWithSalt salt sk = hashWithSalt salt (unsafeFirstWord64 sk)
+    {-# INLINE hashWithSalt #-}
+
+instance Ord PublicKey where compare = unsafeCompare32Bytes
+                             {-# INLINE compare #-}
+instance Ord SecretKey where compare = unsafeCompare32Bytes
+                             {-# INLINE compare #-}
+
+unsafeCompare32Bytes :: (ByteArrayAccess ba, ByteArrayAccess bb)
+                        => ba -> bb -> Ordering
+unsafeCompare32Bytes ba bb =
+    unsafeDupablePerformIO $ BA.withByteArray ba
+                    $ \pa -> BA.withByteArray bb
+                    $ \pb -> unsafeCompare32Bytes' 3 pa pb
+
+unsafeCompare32Bytes' :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering
+unsafeCompare32Bytes' !n !pa !pb = do
+    a <- peek pa
+    b <- peek pb
+    if n == 0
+        then return $! inline compare a b
+        else case inline compare a b of
+            EQ  -> unsafeCompare32Bytes' (n - 1)
+                                         (pa `plusPtr` 8)
+                                         (pb `plusPtr` 8)
+            neq -> return neq
+
+
+
+lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State
+lookupSharedSecret TransportCrypto{secretsCache} sk recipient nonce = do
+    now <- getPOSIXTime
+    atomically $ do
+    mm <- readTVar $ sharedSecret secretsCache
+    case MM.lookup' recipient mm of
+        Nothing -> do
+            let miss = computeSharedSecret sk recipient
+            writeTVar (sharedSecret secretsCache)
+                      (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
+            return $ miss nonce
+        Just (stamp,smm) -> do
+            let (r,v) = case MM.lookup' sk smm of
+                    Nothing | let miss = computeSharedSecret sk recipient
+                                      -> (miss, MM.insertTake' 3 sk miss (Down now) smm)
+                    Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm)
+            writeTVar (sharedSecret secretsCache)
+                      (MM.insertTake' 160 recipient v (Down now) mm)
+            return $ r nonce
+
+
+hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
+hsalsa20 k n = BA.append a b
+ where
+    Salsa.State st = XSalsa.initialize 20 k n
+    (_, as) = BA.splitAt 4 st
+    (a, xs) = BA.splitAt 16 as
+    (_, bs) = BA.splitAt 24 xs
+    (b, _ ) = BA.splitAt 16 bs
+
+
+newtype Nonce24 = Nonce24 ByteString
+ deriving (Eq, Ord, ByteArrayAccess,Data)
+
+addtoNonce24 :: Nonce24 -> Word -> IO Nonce24
+addtoNonce24 (Nonce24 n24) n = Nonce24 <$> BA.copy n24 init
+    where
+        init :: Ptr Word -> IO ()
+        init ptr | fitsInInt (Proxy :: Proxy Word64) = do
+            let frmBE64 = fromIntegral . fromBE64 . fromIntegral
+                tBE64   = fromIntegral . toBE64   . fromIntegral
+                !(W# input) = n
+            W# w1 <- frmBE64 <$> peek ptr
+            W# w2 <- frmBE64 <$> peekElemOff ptr 1
+            W# w3 <- frmBE64 <$> peekElemOff ptr 2
+            let (# overflw,  sum   #) = plusWord2# w3 input
+                (# overflw', sum'  #) = plusWord2# w2 overflw
+                (# discard,  sum'' #) = plusWord2# w1 overflw'
+            poke        ptr   $ tBE64 (W# sum'')
+            pokeElemOff ptr 1 $ tBE64 (W# sum')
+            pokeElemOff ptr 2 $ tBE64 (W# sum)
+
+        init ptr | fitsInInt (Proxy :: Proxy Word32) = do
+            let frmBE32 = fromIntegral . fromBE32 . fromIntegral
+                tBE32   = fromIntegral . toBE32   . fromIntegral
+                !(W# input) = n
+            W# w1 <- frmBE32 <$> peek ptr
+            W# w2 <- frmBE32 <$> peekElemOff ptr 1
+            W# w3 <- frmBE32 <$> peekElemOff ptr 2
+            W# w4 <- frmBE32 <$> peekElemOff ptr 3
+            W# w5 <- frmBE32 <$> peekElemOff ptr 4
+            W# w6 <- frmBE32 <$> peekElemOff ptr 5
+            let (# overflw_,   sum_     #) = plusWord2# w6 input
+                (# overflw__,  sum__    #) = plusWord2# w5 overflw_
+                (# overflw___, sum___   #) = plusWord2# w6 overflw__
+                (# overflw,  sum   #) = plusWord2# w3 overflw___
+                (# overflw', sum'  #) = plusWord2# w2 overflw
+                (# discard,  sum'' #) = plusWord2# w1 overflw'
+            poke        ptr   $ tBE32 (W# sum'')
+            pokeElemOff ptr 1 $ tBE32 (W# sum')
+            pokeElemOff ptr 2 $ tBE32 (W# sum)
+            pokeElemOff ptr 3 $ tBE32 (W# sum___)
+            pokeElemOff ptr 4 $ tBE32 (W# sum__)
+            pokeElemOff ptr 5 $ tBE32 (W# sum_)
+        init _ = error "incrementNonce24: I only support 64 and 32 bits"
+
+incrementNonce24 :: Nonce24 -> IO Nonce24
+incrementNonce24 nonce24 = addtoNonce24 nonce24 1
+
+quoted :: ShowS -> ShowS
+quoted shows s = '"':shows ('"':s)
+
+bin2hex :: ByteArrayAccess bs => bs -> String
+bin2hex = C8.unpack . Base16.encode . BA.convert
+
+bin2base64 :: ByteArrayAccess bs => bs -> String
+bin2base64 = C8.unpack . Base64.encode . BA.convert
+
+
+instance Show Nonce24 where
+    showsPrec d nonce = quoted (mappend $ bin2hex nonce)
+
+instance Sized Nonce24 where size = ConstSize 24
+
+instance Serialize Nonce24 where
+    get = Nonce24 <$> getBytes 24
+    put (Nonce24 bs) = putByteString bs
+
+newtype Nonce8 = Nonce8 Word64
+ deriving (Eq, Ord, Data, Serialize)
+
+-- Note: Big-endian to match Serialize instance.
+instance Storable Nonce8 where
+    sizeOf _ = 8
+    alignment _ = alignment (undefined::Word64)
+    peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr)
+    poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w)
+
+instance Sized Nonce8 where size = ConstSize 8
+
+instance ByteArrayAccess Nonce8 where
+    length _ = 8
+    withByteArray (Nonce8 w64) kont =
+        allocaBytes 8 $ \p -> do
+            poke (castPtr p :: Ptr Word64) $ toBE64 w64
+            kont p
+
+instance Show Nonce8 where
+    showsPrec d nonce = quoted (mappend $ bin2hex nonce)
+
+
+newtype Nonce32 = Nonce32 ByteString
+ deriving (Eq, Ord, ByteArrayAccess, Data)
+
+instance Show Nonce32 where
+    showsPrec d nonce = mappend $ bin2base64 nonce
+
+instance Read Nonce32 where
+    readsPrec _ str = either (const []) id $ do
+        let (ds,ss) = Prelude.splitAt 43 str
+        ss' <- case ss of
+                '=':xs -> Right xs -- optional terminating '='
+                _      -> Right ss
+        bs <- Base64.decode (C8.pack $ ds ++ ['='])
+        guard $ B.length bs == 32
+        return [ (Nonce32 bs, ss') ]
+
+instance Serialize Nonce32 where
+    get = Nonce32 <$> getBytes 32
+    put (Nonce32 bs) = putByteString bs
+
+instance Sized Nonce32 where size = ConstSize 32
+
+
+zeros32 :: Nonce32
+zeros32 = Nonce32 $ BA.replicate 32 0
+
+zeros24 :: ByteString
+zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
+
+-- | `32`   | sender's DHT public key   |
+-- | `24`   | nonce                     |
+-- | `?`    | encrypted message         |
+data Asymm a = Asymm
+    { senderKey :: PublicKey
+    , asymmNonce :: Nonce24
+    , asymmData :: a
+    }
+ deriving (Functor,Foldable,Traversable, Show)
+
+instance Sized a => Sized (Asymm a) where
+    size = case size of
+        ConstSize a -> ConstSize $ a + 24 + 32
+        VarSize f   -> VarSize $ \Asymm { asymmData = x } -> f x + 24 + 32
+
+-- | Field order: senderKey, then nonce This is the format used by
+-- Ping/Pong/GetNodes/SendNodes.
+--
+-- See 'getAliasedAsymm' if the nonce precedes the key.
+getAsymm :: Serialize a => Get (Asymm a)
+getAsymm = Asymm <$> getPublicKey <*> get <*> get
+
+putAsymm :: Serialize a => Asymm a -> Put
+putAsymm (Asymm key nonce dta) = putPublicKey key >> put nonce >> put dta
+
+-- | Field order: nonce, and then senderKey.
+getAliasedAsymm :: Serialize a => Get (Asymm a)
+getAliasedAsymm = flip Asymm <$> get <*> getPublicKey <*> get
+
+putAliasedAsymm :: Serialize a => Asymm a -> Put
+putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta
+
+data SecretsCache = SecretsCache
+    { sharedSecret :: TVar (MinMaxPSQ' PublicKey
+                                       (Down POSIXTime)
+                                       (MinMaxPSQ' SecretKey (Down POSIXTime) (Nonce24 -> State)))
+    }
+
+newSecretsCache :: IO SecretsCache
+newSecretsCache = atomically (SecretsCache <$> newTVar MM.empty)
+
+
+newtype SymmetricKey = SymmetricKey ByteString
+
+data TransportCrypto = TransportCrypto
+    { transportSecret :: SecretKey
+    , transportPublic :: PublicKey
+    , onionAliasSecret :: SecretKey
+    , onionAliasPublic :: PublicKey
+    , rendezvousSecret :: SecretKey
+    , rendezvousPublic :: PublicKey
+    , transportSymmetric :: STM SymmetricKey
+    , transportNewNonce :: STM Nonce24
+    , userKeys :: TVar [(SecretKey,PublicKey)]
+    , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))]
+    , secretsCache :: SecretsCache
+    }
+
+getPublicKey :: S.Get PublicKey
+getPublicKey = throwCryptoError . publicKey <$> S.getBytes 32
+
+putPublicKey :: PublicKey -> S.Put
+putPublicKey bs = S.putByteString $ BA.convert bs
+
+-- 32 bytes -> 42 base64 digits.
+--
+encodeSecret :: SecretKey -> Maybe C8.ByteString
+encodeSecret k = do
+    (a,bs) <- BA.uncons (BA.convert k)
+    -- Bytes
+    -- 1   31
+    -- a | bs
+    (cs,c) <- unsnoc bs
+    -- Bytes
+    --  1   30   1
+    --  a | cs | c
+    --
+    -- Based on the following pasted from the generateSecretKey function:
+    --
+    --   tweakToSecretKey :: ScrubbedBytes -> SecretKey
+    --   tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
+    --         modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
+    --         modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
+    --
+    -- We know the following holds:
+    --   a == a .&. 0xf8
+    --   c == (c .&. 0x7f) .|. 0x40
+    --
+    -- Therefore, there are 5 reserved bits:
+    --   a := aaaa a000
+    --   c := 01dd cccc
+    --
+    -- That gives us 256 - 5 = 251 bits to encode.
+    -- 42 * 6 = 252
+    --
+    let -- We'll reserve the first bit as zero so that the encoded
+        -- key starts with a digit between A and f.  Other digits will be
+        -- arbitrary.
+        --
+        -- The middle 30 bytes will be encoded as is from the source byte
+        -- string (cs). It remains to compute the first (a') and last (c')
+        -- bytes.
+        xs = Base64.encode $ a' `BA.cons` cs `BA.snoc` c'
+        -- a' := 0aaaaadd
+        a' = shiftR a 1 .|. (shiftR c 4 .&. 0x03)
+        -- c' := cccc0000
+        c' = shiftL c 4
+    return $ BA.take 42 xs
+
+-- 42 base64 digits. First digit should be between A and f.  The rest are
+-- arbitrary.
+decodeSecret :: C8.ByteString -> Maybe SecretKey
+decodeSecret k64 | B.length k64 < 42 = Nothing
+decodeSecret k64 = do
+    xs <- either (const Nothing) Just $ Base64.decode $ B.append k64 "A="
+    (a',ds) <- B.uncons $ B.take 32 xs
+    (cs,c') <- B.unsnoc ds
+    let c = 0x40 .|. shiftR c' 4 .|. ( 0x30 .&. shiftL a' 4)
+        a = 0xf8 .&. shiftL a' 1
+    case secretKey $ B.cons a cs `B.snoc` c of
+        CryptoPassed x -> Just x
+        _              -> Nothing
+
diff --git a/src/Data/BEncode/Pretty.hs b/src/Data/BEncode/Pretty.hs
new file mode 100644
index 00000000..89fcb489
--- /dev/null
+++ b/src/Data/BEncode/Pretty.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE CPP                #-}
+module Data.BEncode.Pretty where -- (showBEncode) where
+
+import Data.BEncode.Types
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Text.Printf
+import qualified Data.ByteString.Base16 as Base16
+#ifdef BENCODE_AESON
+import Data.BEncode.BDict hiding (map)
+import Data.Aeson.Types hiding (parse)
+import Data.Aeson.Encode.Pretty
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Vector as Vector
+import Data.Foldable as Foldable
+#endif
+
+{-
+unhex :: Text -> BS.ByteString
+unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2]
+ where
+    nibs = encodeUtf8 t
+    unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10
+                + unnib (BS.index nibs (i * 2 + 1))
+    unnib a | a <= 0x39 = a - 0x30
+            | otherwise = a - (0x41 - 10)
+
+hex :: BS.ByteString -> Text
+hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs
+-}
+
+#ifdef BENCODE_AESON
+
+quote_chr :: Char
+quote_chr = ' '
+
+quote :: Text -> Text
+quote t = quote_chr `T.cons` t `T.snoc` quote_chr
+
+encodeByteString :: BS.ByteString -> Text
+encodeByteString s = either (const . decodeUtf8 $ Base16.encode s) quote $ decodeUtf8' s
+
+decodeByteString :: Text -> BS.ByteString
+decodeByteString s
+        | T.head s==quote_chr = encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s)
+        | otherwise           = fst (Base16.decode (encodeUtf8 s))
+
+instance ToJSON BValue where
+    toJSON (BInteger x) = Number $ fromIntegral x
+    toJSON (BString s) = String $ encodeByteString s
+    toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs
+    toJSON (BDict d) = toJSON d
+
+instance ToJSON a => ToJSON (BDictMap a) where
+    toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d
+       where
+        convert (k,v) = (encodeByteString k,toJSON v)
+
+instance FromJSON BValue where
+    parseJSON (Number x) = pure $ BInteger (truncate x)
+    parseJSON (Bool x)   = pure $ BInteger $ if x then 1 else 0
+    parseJSON (String s) = pure $ BString $ decodeByteString s
+    parseJSON (Array v)  = BList <$> traverse parseJSON (Foldable.toList v)
+    parseJSON (Object d) = BDict <$> parseJSON (Object d)
+    parseJSON (Null)     = pure $ BDict Nil
+
+instance FromJSON v => FromJSON (BDictMap v) where
+    parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d)
+        where
+            convert (k,v) = (,) (decodeByteString k) <$> parseJSON v
+    parseJSON _ = fail "Not a BDict"
+#endif
+
+showBEncode :: BValue -> BL.ByteString
+#ifdef BENCODE_AESON
+showBEncode b = encodePretty $ toJSON b
+#else
+showBEncode b = BL8.pack (show b)
+#endif
diff --git a/src/Data/Bits/ByteString.hs b/src/Data/Bits/ByteString.hs
new file mode 100644
index 00000000..bf0316fd
--- /dev/null
+++ b/src/Data/Bits/ByteString.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-------------------------------------------------------------------------------
+-- |
+-- Module       : Data.Bits.ByteString
+-- Copyright    : (c) 2016 Michael Carpenter
+-- License      : BSD3
+-- Maintainer   : Michael Carpenter <oldmanmike.dev@gmail.com>
+-- Stability    : experimental
+-- Portability  : portable
+--
+-------------------------------------------------------------------------------
+module Data.Bits.ByteString where
+
+import            Data.Bits
+import qualified  Data.ByteString as B
+import            Data.Word
+
+instance Bits B.ByteString where
+
+  (.&.) a b = B.pack $ B.zipWith (.&.) a b
+  {-# INLINE (.&.) #-}
+
+  (.|.) a b = B.pack $ B.zipWith (.|.) a b
+  {-# INLINE (.|.) #-}
+
+  xor a b = B.pack $ B.zipWith xor a b
+  {-# INLINE xor #-}
+
+  complement = B.map complement
+  {-# INLINE complement #-}
+
+  shift x i
+    | i < 0     = x `shiftR` (-i)
+    | i > 0     = x `shiftL` i
+    | otherwise = x
+  {-# INLINE shift #-}
+
+  shiftR bs 0 = bs
+  shiftR "" _ = B.empty
+  shiftR bs i
+      | i `mod` 8 == 0 =
+        B.take (B.length bs) $ B.append
+          (B.replicate (i `div` 8) 0)
+          (B.drop (i `div` 8) bs)
+      | i `mod` 8 /= 0 =
+        B.pack $ take (B.length bs)
+          $ (replicate (i `div` 8) (0 :: Word8))
+          ++ (go (i `mod` 8) 0 $ B.unpack (B.take (B.length bs - (i `div` 8)) bs))
+    where
+    go _ _ [] = []
+    go j w1 (w2:wst) = (maskR j w1 w2) : go j w2 wst
+    maskR j w1 w2 = (shiftL w1 (8-j)) .|. (shiftR w2 j)
+  shiftR _ _ = error "I can't believe you've done this."
+  {-# INLINE shiftR #-}
+
+  shiftL bs 0 = bs
+  shiftL "" _ = B.empty
+  shiftL bs i
+      | i `mod` 8 == 0 =
+        B.take (B.length bs) $ B.append
+          (B.drop (i `div` 8) bs)
+          (B.replicate (i `div` 8) 0)
+      | i `mod` 8 /= 0 =
+        B.pack $ drop ((i `div` 8) - B.length bs)
+          $ (tail (go (i `mod` 8) 0 $ B.unpack (B.drop (i `div` 8) bs)))
+          ++ (replicate (i `div` 8) 0)
+    where
+    go j w1 [] = [shiftL w1 j]
+    go j w1 (w2:wst) = (maskL j w1 w2) : go j w2 wst
+    maskL j w1 w2 = (shiftL w1 j) .|. (shiftR w2 (8-j))
+  shiftL _ _ = error "I can't believe you've done this."
+  {-# INLINE shiftL #-}
+
+  rotate x i
+    | i < 0     = x `rotateR` (-i)
+    | i > 0     = x `rotateL` i
+    | otherwise = x
+  {-# INLINE rotate #-}
+
+  rotateR bs 0 = bs
+  rotateR bs i
+      | B.length bs == 0 = B.empty
+      | B.length bs == 1 = B.singleton (rotateR (bs `B.index` 0) i)
+      | B.length bs > 1 = do
+        let shiftedWords =
+              B.append
+                (B.drop (nWholeWordsToShift i) bs)
+                (B.take (nWholeWordsToShift i) bs)
+        let tmpShiftedBits = (shiftR shiftedWords (i `mod` 8))
+        let rotatedBits = (shiftL (B.last shiftedWords) (8 - (i `mod` 8))) .|. (B.head tmpShiftedBits)
+        rotatedBits `B.cons` (B.tail tmpShiftedBits)
+    where
+    nWholeWordsToShift n =  (B.length bs - (n `div` 8))
+  rotateR _ _ = error "I can't believe you've done this."
+  {-# INLINE rotateR #-}
+
+  rotateL bs 0 = bs
+  rotateL bs i
+      | B.length bs == 0 = B.empty
+      | B.length bs == 1 = B.singleton (rotateL (bs `B.index` 0) i)
+      | i `mod` 8 == 0 = B.append
+                          (B.drop (i `div` 8) bs)
+                          (B.take (i `div` 8) bs)
+      | B.length bs > 1 = do
+        let shiftedWords =
+              B.append
+                (B.drop (i `div` 8) bs)
+                (B.take (i `div` 8) bs)
+        let tmpShiftedBits = (shiftL shiftedWords (i `mod` 8))
+        let rotatedBits = (shiftR (B.head shiftedWords) (8 - (i `mod` 8))) .|. (B.last tmpShiftedBits)
+        (B.init tmpShiftedBits) `B.snoc` rotatedBits
+  rotateL _ _ = error "I can't believe you've done this."
+  {-# INLINE rotateL #-}
+
+  bitSize x = 8 * B.length x
+  {-# INLINE bitSize #-}
+
+  bitSizeMaybe x = Just (8 * B.length x)
+  {-# INLINE bitSizeMaybe #-}
+
+  isSigned _ = False
+  {-# INLINE isSigned #-}
+
+  testBit x i = testBit (B.index x (B.length x - (i `div` 8) - 1)) (i `mod` 8)
+  {-# INLINE testBit #-}
+
+  bit i = (bit $ mod i 8) `B.cons` (B.replicate (div i 8) (255 :: Word8))
+  {-# INLINE bit #-}
+
+  popCount x = sum $ map popCount $ B.unpack x
+  {-# INLINE popCount #-}
diff --git a/src/Data/Digest/CRC32C.hs b/src/Data/Digest/CRC32C.hs
new file mode 100644
index 00000000..18c1314f
--- /dev/null
+++ b/src/Data/Digest/CRC32C.hs
@@ -0,0 +1,100 @@
+module Data.Digest.CRC32C
+    ( crc32c
+    , crc32c_update
+    ) where
+
+import Data.Bits
+import Data.ByteString    (ByteString)
+import Data.Word
+import Data.Array.Base    (unsafeAt)
+import Data.Array.Unboxed
+
+import qualified Data.ByteString as B
+
+
+crc32c :: ByteString -> Word32
+crc32c = crc32c_update 0
+
+crc32c_update :: Word32 -> ByteString -> Word32
+crc32c_update crc bs = flipd $ step (flipd crc) bs
+  where
+    flipd = xor 0xffffffff
+
+step :: Word32 -> ByteString -> Word32
+step crc bs = B.foldl step' crc bs
+  where
+    step' acc b = let x = table !!! ((acc .&. 0xff) `xor` fromIntegral b)
+                    in x `xor` (acc `shiftR` 8)
+{-# INLINEABLE step #-}
+
+(!!!) :: (IArray a e, Ix i, Integral i) => a i e -> i -> e
+arr !!! i = unsafeAt arr $ fromIntegral i
+{-# INLINEABLE (!!!) #-}
+
+table :: UArray Word32 Word32
+table = listArray (0,255) $
+    [ 0x00000000, 0xf26b8303, 0xe13b70f7, 0x1350f3f4
+    , 0xc79a971f, 0x35f1141c, 0x26a1e7e8, 0xd4ca64eb
+    , 0x8ad958cf, 0x78b2dbcc, 0x6be22838, 0x9989ab3b
+    , 0x4d43cfd0, 0xbf284cd3, 0xac78bf27, 0x5e133c24
+    , 0x105ec76f, 0xe235446c, 0xf165b798, 0x030e349b
+    , 0xd7c45070, 0x25afd373, 0x36ff2087, 0xc494a384
+    , 0x9a879fa0, 0x68ec1ca3, 0x7bbcef57, 0x89d76c54
+    , 0x5d1d08bf, 0xaf768bbc, 0xbc267848, 0x4e4dfb4b
+    , 0x20bd8ede, 0xd2d60ddd, 0xc186fe29, 0x33ed7d2a
+    , 0xe72719c1, 0x154c9ac2, 0x061c6936, 0xf477ea35
+    , 0xaa64d611, 0x580f5512, 0x4b5fa6e6, 0xb93425e5
+    , 0x6dfe410e, 0x9f95c20d, 0x8cc531f9, 0x7eaeb2fa
+    , 0x30e349b1, 0xc288cab2, 0xd1d83946, 0x23b3ba45
+    , 0xf779deae, 0x05125dad, 0x1642ae59, 0xe4292d5a
+    , 0xba3a117e, 0x4851927d, 0x5b016189, 0xa96ae28a
+    , 0x7da08661, 0x8fcb0562, 0x9c9bf696, 0x6ef07595
+    , 0x417b1dbc, 0xb3109ebf, 0xa0406d4b, 0x522bee48
+    , 0x86e18aa3, 0x748a09a0, 0x67dafa54, 0x95b17957
+    , 0xcba24573, 0x39c9c670, 0x2a993584, 0xd8f2b687
+    , 0x0c38d26c, 0xfe53516f, 0xed03a29b, 0x1f682198
+    , 0x5125dad3, 0xa34e59d0, 0xb01eaa24, 0x42752927
+    , 0x96bf4dcc, 0x64d4cecf, 0x77843d3b, 0x85efbe38
+    , 0xdbfc821c, 0x2997011f, 0x3ac7f2eb, 0xc8ac71e8
+    , 0x1c661503, 0xee0d9600, 0xfd5d65f4, 0x0f36e6f7
+    , 0x61c69362, 0x93ad1061, 0x80fde395, 0x72966096
+    , 0xa65c047d, 0x5437877e, 0x4767748a, 0xb50cf789
+    , 0xeb1fcbad, 0x197448ae, 0x0a24bb5a, 0xf84f3859
+    , 0x2c855cb2, 0xdeeedfb1, 0xcdbe2c45, 0x3fd5af46
+    , 0x7198540d, 0x83f3d70e, 0x90a324fa, 0x62c8a7f9
+    , 0xb602c312, 0x44694011, 0x5739b3e5, 0xa55230e6
+    , 0xfb410cc2, 0x092a8fc1, 0x1a7a7c35, 0xe811ff36
+    , 0x3cdb9bdd, 0xceb018de, 0xdde0eb2a, 0x2f8b6829
+    , 0x82f63b78, 0x709db87b, 0x63cd4b8f, 0x91a6c88c
+    , 0x456cac67, 0xb7072f64, 0xa457dc90, 0x563c5f93
+    , 0x082f63b7, 0xfa44e0b4, 0xe9141340, 0x1b7f9043
+    , 0xcfb5f4a8, 0x3dde77ab, 0x2e8e845f, 0xdce5075c
+    , 0x92a8fc17, 0x60c37f14, 0x73938ce0, 0x81f80fe3
+    , 0x55326b08, 0xa759e80b, 0xb4091bff, 0x466298fc
+    , 0x1871a4d8, 0xea1a27db, 0xf94ad42f, 0x0b21572c
+    , 0xdfeb33c7, 0x2d80b0c4, 0x3ed04330, 0xccbbc033
+    , 0xa24bb5a6, 0x502036a5, 0x4370c551, 0xb11b4652
+    , 0x65d122b9, 0x97baa1ba, 0x84ea524e, 0x7681d14d
+    , 0x2892ed69, 0xdaf96e6a, 0xc9a99d9e, 0x3bc21e9d
+    , 0xef087a76, 0x1d63f975, 0x0e330a81, 0xfc588982
+    , 0xb21572c9, 0x407ef1ca, 0x532e023e, 0xa145813d
+    , 0x758fe5d6, 0x87e466d5, 0x94b49521, 0x66df1622
+    , 0x38cc2a06, 0xcaa7a905, 0xd9f75af1, 0x2b9cd9f2
+    , 0xff56bd19, 0x0d3d3e1a, 0x1e6dcdee, 0xec064eed
+    , 0xc38d26c4, 0x31e6a5c7, 0x22b65633, 0xd0ddd530
+    , 0x0417b1db, 0xf67c32d8, 0xe52cc12c, 0x1747422f
+    , 0x49547e0b, 0xbb3ffd08, 0xa86f0efc, 0x5a048dff
+    , 0x8ecee914, 0x7ca56a17, 0x6ff599e3, 0x9d9e1ae0
+    , 0xd3d3e1ab, 0x21b862a8, 0x32e8915c, 0xc083125f
+    , 0x144976b4, 0xe622f5b7, 0xf5720643, 0x07198540
+    , 0x590ab964, 0xab613a67, 0xb831c993, 0x4a5a4a90
+    , 0x9e902e7b, 0x6cfbad78, 0x7fab5e8c, 0x8dc0dd8f
+    , 0xe330a81a, 0x115b2b19, 0x020bd8ed, 0xf0605bee
+    , 0x24aa3f05, 0xd6c1bc06, 0xc5914ff2, 0x37faccf1
+    , 0x69e9f0d5, 0x9b8273d6, 0x88d28022, 0x7ab90321
+    , 0xae7367ca, 0x5c18e4c9, 0x4f48173d, 0xbd23943e
+    , 0xf36e6f75, 0x0105ec76, 0x12551f82, 0xe03e9c81
+    , 0x34f4f86a, 0xc69f7b69, 0xd5cf889d, 0x27a40b9e
+    , 0x79b737ba, 0x8bdcb4b9, 0x988c474d, 0x6ae7c44e
+    , 0xbe2da0a5, 0x4c4623a6, 0x5f16d052, 0xad7d5351
+    ]
diff --git a/src/Data/MinMaxPSQ.hs b/src/Data/MinMaxPSQ.hs
new file mode 100644
index 00000000..3b9a4d6c
--- /dev/null
+++ b/src/Data/MinMaxPSQ.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE BangPatterns, PatternSynonyms #-}
+module Data.MinMaxPSQ
+    ( module Data.MinMaxPSQ
+    , Binding'
+    , pattern Binding
+    ) where
+
+import Data.Ord
+import qualified Data.Wrapper.PSQ as PSQ
+         ;import Data.Wrapper.PSQ as PSQ hiding (insert, insert', null, size)
+import Prelude hiding (null, take)
+
+data MinMaxPSQ' k p v = MinMaxPSQ !(PSQ' k p v) !(PSQ' k (Down p) v)
+type MinMaxPSQ k p = MinMaxPSQ' k p ()
+
+empty :: MinMaxPSQ' k p v
+empty = MinMaxPSQ PSQ.empty PSQ.empty
+
+singleton' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v
+singleton' k v p = MinMaxPSQ (PSQ.singleton' k v p) (PSQ.singleton' k v (Down p))
+
+null :: MinMaxPSQ' k p v -> Bool
+null (MinMaxPSQ nq xq) = PSQ.null nq
+
+size :: MinMaxPSQ' k p v -> Int
+size (MinMaxPSQ nq xq) = PSQ.size nq
+
+toList :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> [Binding' k p v]
+toList (MinMaxPSQ nq xq) = PSQ.toList nq
+
+fromList :: (PSQKey k, Ord p) => [Binding' k p v] -> MinMaxPSQ' k p v
+fromList kps = MinMaxPSQ (PSQ.fromList kps)
+                         (PSQ.fromList $ map (\(Binding k v p) -> Binding k v (Down p)) kps)
+
+findMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
+findMin (MinMaxPSQ nq xq) = PSQ.findMin nq
+
+findMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
+findMax (MinMaxPSQ nq xq) = fmap (\(Binding k v (Down p)) -> Binding k v p) $ PSQ.findMin xq
+
+insert :: (PSQKey k, Ord p) => k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
+insert k p (MinMaxPSQ nq xq) = MinMaxPSQ (PSQ.insert k p        nq)
+                                         (PSQ.insert k (Down p) xq)
+
+insert' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+insert' k v p (MinMaxPSQ nq xq) = MinMaxPSQ (PSQ.insert' k v p        nq)
+                                            (PSQ.insert' k v (Down p) xq)
+
+delete :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+delete k (MinMaxPSQ nq xq) = MinMaxPSQ (PSQ.delete k nq) (PSQ.delete k xq)
+
+deleteMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+deleteMin (MinMaxPSQ nq xq) = case PSQ.minView nq of
+    Just (Binding k _ _, nq') -> MinMaxPSQ nq' (PSQ.delete k xq)
+    Nothing                   -> MinMaxPSQ nq xq
+
+deleteMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+deleteMax (MinMaxPSQ nq xq) = case PSQ.minView xq of
+    Just (Binding k _ _, xq') -> MinMaxPSQ (PSQ.delete k nq) xq'
+    Nothing                   -> MinMaxPSQ nq xq
+
+minView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
+minView (MinMaxPSQ nq xq) = fmap (\(Binding k v p, nq') -> (Binding k v p, MinMaxPSQ nq' (PSQ.delete k xq)))
+                            $ PSQ.minView nq
+
+maxView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
+maxView (MinMaxPSQ nq xq) = fmap (\(Binding k v (Down p), xq') -> (Binding k v p, MinMaxPSQ (PSQ.delete k nq) xq'))
+                            $ PSQ.minView xq
+
+-- | Maintains a bounded 'MinMaxPSQ' by deleting the maximum element if the
+-- insertion would cause the queue to have too many elements.
+insertTake :: (PSQKey k, Ord p) => Int -> k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
+insertTake n k p q = take n $ insert k p q
+
+-- | Maintains a bounded 'MinMaxPSQ\'' by deleting the maximum element if the
+-- insertion would cause the queue to have too many elements.
+insertTake' :: (PSQKey k, Ord p) => Int -> k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+insertTake' n k v p q = take n $ insert' k v p q
+
+
+-- | Truncate the 'MinMaxPSQ' to the given number of lowest priority elements.
+take :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
+take !n !q | (size q <= n) = q
+           | null q        = q
+           | otherwise     = take n $ deleteMax q
+
+-- | Like 'take', except it provides a list deleted bindings.
+takeView :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> ( [Binding' k p v], MinMaxPSQ' k p v )
+takeView !n !q | (size q <= n) = ([], q)
+               | null q        = ([], q)
+               | otherwise     = let Just (x,q') = maxView q
+                                     (xs,q'')    = takeView n q'
+                                     ys          = x:xs
+                                 in (ys, ys `seq` q'')
+
+
+
+lookup' :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> Maybe (p, v)
+lookup' k (MinMaxPSQ q _) = PSQ.lookup k q
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs
new file mode 100644
index 00000000..4af583ed
--- /dev/null
+++ b/src/Data/Torrent.hs
@@ -0,0 +1,1328 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Torrent file contains metadata about files and folders but not
+--   content itself. The files are bencoded dictionaries. There is
+--   also other info which is used to help join the swarm.
+--
+--   This module provides torrent metainfo serialization and info hash
+--   extraction.
+--
+--   For more info see:
+--   <http://www.bittorrent.org/beps/bep_0003.html#metainfo-files>,
+--   <https://wiki.theory.org/BitTorrentSpecification#Metainfo_File_Structure>
+--
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Data.Torrent
+       ( -- * InfoHash
+         -- $infohash
+         InfoHash(..)
+       , textToInfoHash
+       , longHex
+       , shortHex
+
+         -- * File layout
+         -- ** FileInfo
+       , FileOffset
+       , FileSize
+       , FileInfo (..)
+       , fileLength
+       , filePath
+       , fileMD5Sum
+
+         -- ** Layout info
+       , LayoutInfo (..)
+       , singleFile
+       , multiFile
+       , rootDirName
+       , joinFilePath
+       , isSingleFile
+       , isMultiFile
+       , suggestedName
+       , contentLength
+       , fileCount
+       , blockCount
+
+         -- ** Flat layout info
+       , FileLayout
+       , flatLayout
+       , accumPositions
+       , fileOffset
+
+         -- ** Internal
+       , sizeInBase
+
+         -- * Pieces
+         -- ** Attributes
+       , PieceIx
+       , PieceCount
+       , PieceSize
+       , minPieceSize
+       , maxPieceSize
+       , defaultPieceSize
+       , PieceHash
+
+         -- ** Piece data
+       , Piece (..)
+       , pieceSize
+       , hashPiece
+
+         -- ** Piece control
+       , HashList (..)
+       , PieceInfo (..)
+       , pieceLength
+       , pieceHashes
+       , pieceCount
+
+         -- ** Validation
+       , pieceHash
+       , checkPieceLazy
+
+         -- * Info dictionary
+       , InfoDict (..)
+       , infohash
+       , layoutInfo
+       , pieceInfo
+       , isPrivate
+#ifdef VERSION_bencoding
+       , infoDictionary
+#endif
+
+         -- * Torrent file
+       , Torrent(..)
+
+         -- ** Lenses
+       , announce
+       , announceList
+       , comment
+       , createdBy
+       , creationDate
+       , encoding
+       , infoDict
+       , publisher
+       , publisherURL
+       , signature
+
+         -- ** Utils
+       , nullTorrent
+       , typeTorrent
+       , torrentExt
+       , isTorrentPath
+#ifdef VERSION_bencoding
+       , fromFile
+       , toFile
+#endif
+
+         -- * Magnet
+         -- $magnet-link
+       , Magnet(..)
+       , nullMagnet
+       , simpleMagnet
+       , detailedMagnet
+       , parseMagnet
+       , renderMagnet
+
+         -- ** URN
+       , URN (..)
+       , NamespaceId
+       , btih
+       , infohashURN
+       , parseURN
+       , renderURN
+       ) where
+
+import Prelude
+import Control.Applicative
+import Control.DeepSeq
+import Control.Exception
+import Control.Lens
+import Control.Monad
+import Crypto.Hash
+#ifdef VERSION_bencoding
+import Data.BEncode as BE
+import Data.BEncode.Types as BE
+#endif
+import Data.Bits
+#ifdef VERSION_bits_extras
+import Data.Bits.Extras
+#endif
+import qualified Data.ByteArray as Bytes
+import Data.ByteString as BS
+import Data.ByteString.Base16 as Base16
+import Data.ByteString.Base32 as Base32
+import Data.ByteString.Base64 as Base64
+import Data.ByteString.Char8 as BC (pack, unpack)
+import Data.ByteString.Lazy  as BL
+import Data.Char
+import Data.Convertible
+import Data.Default
+import Data.Hashable   as Hashable
+import Data.Int
+import Data.List as L
+import Data.Map as M
+import Data.Maybe
+import Data.Serialize as S
+import Data.String
+import Data.Text as T
+import Data.Text.Encoding as T
+import Data.Text.Read
+import Data.Time.Clock.POSIX
+import Data.Typeable
+import Network (HostName)
+import Network.HTTP.Types.QueryLike
+import Network.HTTP.Types.URI
+import Network.URI
+import Text.ParserCombinators.ReadP as P
+import Text.PrettyPrint as PP
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+import System.FilePath
+import System.Posix.Types
+
+import Network.Address
+import Network.Kademlia.Routing
+
+
+{-----------------------------------------------------------------------
+--  Info hash
+-----------------------------------------------------------------------}
+-- TODO
+--
+-- data Word160 = Word160 {-# UNPACK #-} !Word64
+--                        {-# UNPACK #-} !Word64
+--                        {-# UNPACK #-} !Word32
+--
+-- newtype InfoHash = InfoHash Word160
+--
+-- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes
+
+-- $infohash
+--
+-- Infohash is a unique identifier of torrent.
+
+-- | Exactly 20 bytes long SHA1 hash of the info part of torrent file.
+newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString }
+  deriving (Eq, Ord, Typeable)
+
+infoHashLen :: Int
+infoHashLen = 20
+
+-- | Meaningless placeholder value.
+instance Default InfoHash where
+  def = "0123456789012345678901234567890123456789"
+
+-- | Hash raw bytes. (no encoding)
+instance Hashable InfoHash where
+  hashWithSalt s (InfoHash ih) = hashWithSalt s ih
+  {-# INLINE hashWithSalt #-}
+
+#ifdef VERSION_bencoding
+-- | Convert to\/from raw bencoded string. (no encoding)
+instance BEncode InfoHash where
+  toBEncode = toBEncode . getInfoHash
+  fromBEncode be = InfoHash <$> fromBEncode be
+#endif
+
+#if 0
+instance TableKey KMessageOf InfoHash where
+  toNodeId = either (error msg) id . S.decode . S.encode
+    where -- TODO unsafe coerse?
+      msg = "tableKey: impossible"
+#endif
+
+
+-- | Convert to\/from raw bytestring. (no encoding)
+instance Serialize InfoHash where
+  put (InfoHash ih) = putByteString ih
+  {-# INLINE put #-}
+
+  get = InfoHash <$> getBytes infoHashLen
+  {-# INLINE get #-}
+
+-- | Convert to raw query value. (no encoding)
+instance QueryValueLike InfoHash where
+  toQueryValue (InfoHash ih) = Just ih
+  {-# INLINE toQueryValue #-}
+
+-- | Convert to base16 encoded string.
+instance Show InfoHash where
+  show (InfoHash ih) = BC.unpack (Base16.encode ih)
+
+-- | Convert to base16 encoded Doc string.
+instance Pretty InfoHash where
+  pPrint = text . show
+
+-- | Read base16 encoded string.
+instance Read InfoHash where
+  readsPrec _ = readP_to_S $ do
+      str <- replicateM (infoHashLen * 2) (satisfy isHexDigit)
+      return $ InfoHash $ decodeIH str
+    where
+      decodeIH       = BS.pack . L.map fromHex . pair
+      fromHex (a, b) = read $ '0' : 'x' : a : b : []
+
+      pair (a : b : xs) = (a, b) : pair xs
+      pair _            = []
+
+-- | Convert raw bytes to info hash.
+instance Convertible BS.ByteString InfoHash where
+  safeConvert bs
+    | BS.length bs == infoHashLen = pure (InfoHash bs)
+    |          otherwise          = convError "invalid length" bs
+
+-- | Parse infohash from base16\/base32\/base64 encoded string.
+instance Convertible Text InfoHash where
+  safeConvert t
+      | 20 == hashLen = pure (InfoHash hashStr)
+      | 26 <= hashLen && hashLen <= 28 =
+        case Base64.decode hashStr of
+          Left  msg   -> convError ("invalid base64 encoding " ++ msg) t
+          Right ihStr -> safeConvert ihStr
+
+      |      hashLen == 32   =
+        case Base32.decode hashStr of
+          Left  msg   -> convError msg t
+          Right ihStr -> safeConvert ihStr
+
+      |      hashLen == 40   =
+        let (ihStr, inv) = Base16.decode hashStr
+        in if BS.length inv /= 0
+           then convError "invalid base16 encoding" t
+           else safeConvert ihStr
+
+      |        otherwise     = convError "invalid length" t
+    where
+      hashLen = BS.length hashStr
+      hashStr = T.encodeUtf8 t
+
+-- | Decode from base16\/base32\/base64 encoded string.
+instance IsString InfoHash where
+  fromString = either (error . prettyConvertError) id . safeConvert . T.pack
+
+ignoreErrorMsg :: Either a b -> Maybe b
+ignoreErrorMsg = either (const Nothing) Just
+
+-- | Tries both base16 and base32 while decoding info hash.
+--
+--  Use 'safeConvert' for detailed error messages.
+--
+textToInfoHash :: Text -> Maybe InfoHash
+textToInfoHash = ignoreErrorMsg . safeConvert
+
+-- | Hex encode infohash to text, full length.
+longHex :: InfoHash -> Text
+longHex = T.decodeUtf8 . Base16.encode . getInfoHash
+
+-- | The same as 'longHex', but only first 7 characters.
+shortHex :: InfoHash -> Text
+shortHex = T.take 7 . longHex
+
+{-----------------------------------------------------------------------
+--  File info
+-----------------------------------------------------------------------}
+
+-- | Size of a file in bytes.
+type FileSize = FileOffset
+
+#ifdef VERSION_bencoding
+deriving instance BEncode  FileOffset
+#endif
+
+-- | Contain metainfo about one single file.
+data FileInfo a = FileInfo {
+      fiLength      :: {-# UNPACK #-} !FileSize
+      -- ^ Length of the file in bytes.
+
+      -- TODO unpacked MD5 sum
+    , fiMD5Sum      :: !(Maybe BS.ByteString)
+      -- ^ 32 character long MD5 sum of the file.  Used by third-party
+      -- tools, not by bittorrent protocol itself.
+
+    , fiName        :: !a
+      -- ^ One or more string elements that together represent the
+      -- path and filename. Each element in the list corresponds to
+      -- either a directory name or (in the case of the last element)
+      -- the filename.  For example, the file:
+      --
+      --   > "dir1/dir2/file.ext"
+      --
+      --   would consist of three string elements:
+      --
+      --   > ["dir1", "dir2", "file.ext"]
+      --
+    } deriving (Show, Read, Eq, Typeable
+               , Functor, Foldable
+               )
+
+makeLensesFor
+  [ ("fiLength", "fileLength")
+  , ("fiMD5Sum", "fileMD5Sum")
+  , ("fiName"  , "filePath"  )
+  ]
+  ''FileInfo
+
+instance NFData a => NFData (FileInfo a) where
+  rnf FileInfo {..} = rnf fiName
+  {-# INLINE rnf #-}
+
+#ifdef VERSION_bencoding
+instance BEncode (FileInfo [BS.ByteString]) where
+  toBEncode FileInfo {..} = toDict $
+       "length" .=! fiLength
+    .: "md5sum" .=? fiMD5Sum
+    .: "path"   .=! fiName
+    .: endDict
+  {-# INLINE toBEncode #-}
+
+  fromBEncode = fromDict $ do
+    FileInfo <$>! "length"
+             <*>? "md5sum"
+             <*>! "path"
+  {-# INLINE fromBEncode #-}
+
+type Put a = a -> BDict -> BDict
+#endif
+
+#ifdef VERSION_bencoding
+putFileInfoSingle :: Data.Torrent.Put (FileInfo BS.ByteString)
+putFileInfoSingle FileInfo {..} cont =
+       "length" .=! fiLength
+    .: "md5sum" .=? fiMD5Sum
+    .: "name"   .=! fiName
+    .: cont
+
+getFileInfoSingle :: BE.Get (FileInfo BS.ByteString)
+getFileInfoSingle = do
+    FileInfo <$>! "length"
+             <*>? "md5sum"
+             <*>! "name"
+
+instance BEncode (FileInfo BS.ByteString) where
+  toBEncode = toDict . (`putFileInfoSingle` endDict)
+  {-# INLINE toBEncode #-}
+
+  fromBEncode = fromDict getFileInfoSingle
+  {-# INLINE fromBEncode #-}
+#endif
+
+instance Pretty (FileInfo BS.ByteString) where
+  pPrint FileInfo {..} =
+       "Path: " <> text (T.unpack (T.decodeUtf8 fiName))
+    $$ "Size: " <> text (show fiLength)
+    $$ maybe PP.empty ppMD5 fiMD5Sum
+   where
+    ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5))
+
+-- | Join file path.
+joinFilePath :: FileInfo [BS.ByteString] -> FileInfo BS.ByteString
+joinFilePath = fmap (BS.intercalate "/")
+
+{-----------------------------------------------------------------------
+--  Layout info
+-----------------------------------------------------------------------}
+
+-- | Original (found in torrent file) layout info is either:
+--
+--     * Single file with its /name/.
+--
+--     * Multiple files with its relative file /paths/.
+--
+data LayoutInfo
+  = SingleFile
+    { -- | Single file info.
+      liFile     :: !(FileInfo BS.ByteString)
+    }
+  | MultiFile
+    { -- | List of the all files that torrent contains.
+      liFiles    :: ![FileInfo [BS.ByteString]]
+
+      -- | The /suggested/ name of the root directory in which to
+      -- store all the files.
+    , liDirName  :: !BS.ByteString
+    } deriving (Show, Read, Eq, Typeable)
+
+makeLensesFor
+  [ ("liFile"   , "singleFile" )
+  , ("liFiles"  , "multiFile"  )
+  , ("liDirName", "rootDirName")
+  ]
+  ''LayoutInfo
+
+instance NFData LayoutInfo where
+  rnf SingleFile {..} = ()
+  rnf MultiFile  {..} = rnf liFiles
+
+-- | Empty multifile layout.
+instance Default LayoutInfo where
+  def = MultiFile [] ""
+
+#ifdef VERSION_bencoding
+getLayoutInfo :: BE.Get LayoutInfo
+getLayoutInfo = single <|> multi
+  where
+    single = SingleFile <$>  getFileInfoSingle
+    multi  = MultiFile  <$>! "files" <*>! "name"
+
+putLayoutInfo :: Data.Torrent.Put LayoutInfo
+putLayoutInfo SingleFile {..} = putFileInfoSingle liFile
+putLayoutInfo MultiFile  {..} = \ cont ->
+     "files" .=! liFiles
+  .: "name"  .=! liDirName
+  .: cont
+
+instance BEncode LayoutInfo where
+  toBEncode   = toDict . (`putLayoutInfo` endDict)
+  fromBEncode = fromDict getLayoutInfo
+#endif
+
+instance Pretty LayoutInfo where
+  pPrint SingleFile {..} = pPrint liFile
+  pPrint MultiFile  {..} = vcat $ L.map (pPrint . joinFilePath) liFiles
+
+-- | Test if this is single file torrent.
+isSingleFile :: LayoutInfo -> Bool
+isSingleFile SingleFile {} = True
+isSingleFile _             = False
+{-# INLINE isSingleFile #-}
+
+-- | Test if this is multifile torrent.
+isMultiFile :: LayoutInfo -> Bool
+isMultiFile MultiFile {} = True
+isMultiFile _            = False
+{-# INLINE isMultiFile #-}
+
+-- | Get name of the torrent based on the root path piece.
+suggestedName :: LayoutInfo -> BS.ByteString
+suggestedName (SingleFile FileInfo {..}) = fiName
+suggestedName  MultiFile           {..}  = liDirName
+{-# INLINE suggestedName #-}
+
+-- | Find sum of sizes of the all torrent files.
+contentLength :: LayoutInfo -> FileSize
+contentLength SingleFile { liFile  = FileInfo {..} } = fiLength
+contentLength MultiFile  { liFiles = tfs           } = L.sum (L.map fiLength tfs)
+
+-- | Get number of all files in torrent.
+fileCount :: LayoutInfo -> Int
+fileCount SingleFile {..} = 1
+fileCount MultiFile  {..} = L.length liFiles
+
+-- | Find number of blocks of the specified size. If torrent size is
+-- not a multiple of block size then the count is rounded up.
+blockCount :: Int -> LayoutInfo -> Int
+blockCount blkSize ci = contentLength ci `sizeInBase` blkSize
+
+------------------------------------------------------------------------
+
+-- | File layout specifies the order and the size of each file in the
+--   storage. Note that order of files is highly important since we
+--   coalesce all the files in the given order to get the linear block
+--   address space.
+--
+type FileLayout a = [(FilePath, a)]
+
+-- | Extract files layout from torrent info with the given root path.
+flatLayout
+  :: FilePath            -- ^ Root path for the all torrent files.
+  -> LayoutInfo          -- ^ Torrent content information.
+  -> FileLayout FileSize -- ^ The all file paths prefixed with the given root.
+flatLayout prefixPath SingleFile { liFile = FileInfo {..} }
+    = [(prefixPath </> BC.unpack fiName, fiLength)]
+flatLayout prefixPath MultiFile  {..}     = L.map mkPath liFiles
+  where   -- TODO use utf8 encoding in name
+    mkPath FileInfo {..} = (_path, fiLength)
+      where
+        _path = prefixPath </> BC.unpack liDirName
+           </> joinPath (L.map BC.unpack fiName)
+
+-- | Calculate offset of each file based on its length, incrementally.
+accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize)
+accumPositions = go 0
+  where
+    go !_ [] = []
+    go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs
+
+-- | Gives global offset of a content file for a given full path.
+fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset
+fileOffset = L.lookup
+{-# INLINE fileOffset #-}
+
+------------------------------------------------------------------------
+
+-- | Divide and round up.
+sizeInBase :: Integral a => a -> Int -> Int
+sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align
+  where
+    align = if n `mod` fromIntegral b == 0 then 0 else 1
+{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-}
+{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-}
+
+{-----------------------------------------------------------------------
+-- Piece attributes
+-----------------------------------------------------------------------}
+
+-- | Zero-based index of piece in torrent content.
+type PieceIx   = Int
+
+-- | Size of piece in bytes. Should be a power of 2.
+--
+--   NOTE: Have max and min size constrained to wide used
+--   semi-standard values. This bounds should be used to make decision
+--   about piece size for new torrents.
+--
+type PieceSize = Int
+
+-- | Number of pieces in torrent or a part of torrent.
+type PieceCount = Int
+
+defaultBlockSize :: Int
+defaultBlockSize = 16 * 1024
+
+-- | Optimal number of pieces in torrent.
+optimalPieceCount :: PieceCount
+optimalPieceCount = 1000
+{-# INLINE optimalPieceCount #-}
+
+-- | Piece size should not be less than this value.
+minPieceSize :: Int
+minPieceSize = defaultBlockSize * 4
+{-# INLINE minPieceSize #-}
+
+-- | To prevent transfer degradation piece size should not exceed this
+-- value.
+maxPieceSize :: Int
+maxPieceSize = 4 * 1024 * 1024
+{-# INLINE maxPieceSize #-}
+
+toPow2 :: Int -> Int
+#ifdef VERSION_bits_extras
+toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x)
+#else
+toPow2 x = bit $ fromIntegral (countLeadingZeros (0 :: Int) - countLeadingZeros x)
+#endif
+
+-- | Find the optimal piece size for a given torrent size.
+defaultPieceSize :: Int64 -> Int
+defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc
+  where
+    pc = fromIntegral (x `div` fromIntegral optimalPieceCount)
+
+{-----------------------------------------------------------------------
+-- Piece data
+-----------------------------------------------------------------------}
+
+type PieceHash = BS.ByteString
+
+hashsize :: Int
+hashsize = 20
+{-# INLINE hashsize #-}
+
+-- TODO check if pieceLength is power of 2
+-- | Piece payload should be strict or lazy bytestring.
+data Piece a = Piece
+  { -- | Zero-based piece index in torrent.
+    pieceIndex :: {-# UNPACK #-} !PieceIx
+
+    -- | Payload.
+  , pieceData  :: !a
+  } deriving (Show, Read, Eq, Functor, Typeable)
+
+instance NFData a => NFData (Piece a) where
+  rnf (Piece a b) = rnf a `seq` rnf b
+
+-- | Payload bytes are omitted.
+instance Pretty (Piece a) where
+  pPrint Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex)
+
+-- | Get size of piece in bytes.
+pieceSize :: Piece BL.ByteString -> PieceSize
+pieceSize Piece {..} = fromIntegral (BL.length pieceData)
+
+-- | Get piece hash.
+hashPiece :: Piece BL.ByteString -> PieceHash
+hashPiece Piece {..} = Bytes.convert (hashlazy pieceData :: Digest SHA1)
+
+{-----------------------------------------------------------------------
+-- Piece control
+-----------------------------------------------------------------------}
+
+-- | A flat array of SHA1 hash for each piece.
+newtype HashList = HashList { unHashList :: BS.ByteString }
+  deriving ( Show, Read, Eq, Typeable
+#ifdef VERSION_bencoding
+           , BEncode
+#endif
+           )
+
+-- | Empty hash list.
+instance Default HashList where
+  def = HashList ""
+
+-- | Part of torrent file used for torrent content validation.
+data PieceInfo = PieceInfo
+  { piPieceLength  :: {-# UNPACK #-} !PieceSize
+    -- ^ Number of bytes in each piece.
+
+  , piPieceHashes  :: !HashList
+    -- ^ Concatenation of all 20-byte SHA1 hash values.
+  } deriving (Show, Read, Eq, Typeable)
+
+-- | Number of bytes in each piece.
+makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo
+
+-- | Concatenation of all 20-byte SHA1 hash values.
+makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo
+
+instance NFData PieceInfo where
+  rnf (PieceInfo a (HashList b)) = rnf a `seq` rnf b
+
+instance Default PieceInfo where
+  def = PieceInfo 1 def
+
+
+#ifdef VERSION_bencoding
+putPieceInfo :: Data.Torrent.Put PieceInfo
+putPieceInfo PieceInfo {..} cont =
+       "piece length" .=! piPieceLength
+    .: "pieces"       .=! piPieceHashes
+    .: cont
+
+getPieceInfo :: BE.Get PieceInfo
+getPieceInfo = do
+    PieceInfo <$>! "piece length"
+              <*>! "pieces"
+
+instance BEncode PieceInfo where
+  toBEncode   = toDict . (`putPieceInfo` endDict)
+  fromBEncode = fromDict getPieceInfo
+#endif
+
+-- | Hashes are omitted.
+instance Pretty PieceInfo where
+  pPrint  PieceInfo {..} = "Piece size: " <> int piPieceLength
+
+slice :: Int -> Int -> BS.ByteString -> BS.ByteString
+slice start len = BS.take len . BS.drop start
+{-# INLINE slice #-}
+
+-- | Extract validation hash by specified piece index.
+pieceHash :: PieceInfo -> PieceIx -> PieceHash
+pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes)
+
+-- | Find count of pieces in the torrent. If torrent size is not a
+-- multiple of piece size then the count is rounded up.
+pieceCount :: PieceInfo -> PieceCount
+pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize
+
+-- | Test if this is last piece in torrent content.
+isLastPiece :: PieceInfo -> PieceIx -> Bool
+isLastPiece ci i = pieceCount ci == succ i
+
+-- | Validate piece with metainfo hash.
+checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool
+checkPieceLazy pinfo @ PieceInfo {..} Piece {..}
+  = (fromIntegral (BL.length pieceData) == piPieceLength
+     || isLastPiece pinfo pieceIndex)
+  && Bytes.convert (hashlazy pieceData :: Digest SHA1) == pieceHash pinfo pieceIndex
+
+{-----------------------------------------------------------------------
+--  Info dictionary
+-----------------------------------------------------------------------}
+
+{- note that info hash is actually reduntant field
+   but it's better to keep it here to avoid heavy recomputations
+-}
+
+-- | Info part of the .torrent file contain info about each content file.
+data InfoDict = InfoDict
+  { idInfoHash     :: !InfoHash
+    -- ^ SHA1 hash of the (other) 'DictInfo' fields.
+
+  , idLayoutInfo   :: !LayoutInfo
+    -- ^ File layout (name, size, etc) information.
+
+  , idPieceInfo    :: !PieceInfo
+    -- ^ Content validation information.
+
+  , idPrivate      :: !Bool
+    -- ^ If set the client MUST publish its presence to get other
+    -- peers ONLY via the trackers explicity described in the
+    -- metainfo file.
+    --
+    --   BEP 27: <http://www.bittorrent.org/beps/bep_0027.html>
+  } deriving (Show, Read, Eq, Typeable)
+
+makeLensesFor
+  [ ("idInfoHash"  , "infohash"  )
+  , ("idLayoutInfo", "layoutInfo")
+  , ("idPieceInfo" , "pieceInfo" )
+  , ("idPrivate"   , "isPrivate" )
+  ]
+  ''InfoDict
+
+instance NFData InfoDict where
+  rnf InfoDict {..} = rnf idLayoutInfo
+
+instance Hashable InfoDict where
+  hashWithSalt = Hashable.hashUsing idInfoHash
+  {-# INLINE hashWithSalt #-}
+
+-- | Hash lazy bytestring using SHA1 algorithm.
+hashLazyIH :: BL.ByteString -> InfoHash
+hashLazyIH = either (const (error msg)) id . safeConvert . (Bytes.convert :: Digest SHA1 -> BS.ByteString) . hashlazy
+  where
+    msg = "Infohash.hash: impossible: SHA1 is always 20 bytes long"
+
+#ifdef VERSION_bencoding
+-- | Empty info dictionary with zero-length content.
+instance Default InfoDict where
+  def = infoDictionary def def False
+
+-- | Smart constructor: add a info hash to info dictionary.
+infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict
+infoDictionary li pinfo private = InfoDict ih li pinfo private
+  where
+    ih = hashLazyIH $ BE.encode $ InfoDict def li pinfo private
+
+getPrivate :: BE.Get Bool
+getPrivate = (Just True ==) <$>? "private"
+
+putPrivate :: Bool -> BDict -> BDict
+putPrivate False = id
+putPrivate True  = \ cont -> "private" .=! True .: cont
+
+instance BEncode InfoDict where
+  toBEncode InfoDict {..} = toDict $
+      putLayoutInfo idLayoutInfo   $
+      putPieceInfo  idPieceInfo    $
+      putPrivate    idPrivate      $
+      endDict
+
+  fromBEncode dict = (`fromDict` dict) $ do
+      InfoDict ih <$> getLayoutInfo
+                  <*> getPieceInfo
+                  <*> getPrivate
+    where
+      ih = hashLazyIH (BE.encode dict)
+#endif
+
+ppPrivacy :: Bool -> Doc
+ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public"
+
+--ppAdditionalInfo :: InfoDict -> Doc
+--ppAdditionalInfo layout = PP.empty
+
+instance Pretty InfoDict where
+  pPrint InfoDict {..} =
+    pPrint idLayoutInfo $$
+    pPrint  idPieceInfo  $$
+    ppPrivacy    idPrivate
+
+{-----------------------------------------------------------------------
+--  Torrent info
+-----------------------------------------------------------------------}
+-- TODO add torrent file validation
+
+-- | Metainfo about particular torrent.
+data Torrent = Torrent
+  { tAnnounce     :: !(Maybe URI)
+    -- ^ The URL of the tracker.
+
+  , tAnnounceList :: !(Maybe [[URI]])
+    -- ^ Announce list add multiple tracker support.
+    --
+    --   BEP 12: <http://www.bittorrent.org/beps/bep_0012.html>
+
+  , tComment      :: !(Maybe Text)
+    -- ^ Free-form comments of the author.
+
+  , tCreatedBy    :: !(Maybe Text)
+    -- ^ Name and version of the program used to create the .torrent.
+
+  , tCreationDate :: !(Maybe POSIXTime)
+    -- ^ Creation time of the torrent, in standard UNIX epoch.
+
+  , tEncoding     :: !(Maybe Text)
+    -- ^ String encoding format used to generate the pieces part of
+    --   the info dictionary in the .torrent metafile.
+
+  , tInfoDict     :: !InfoDict
+    -- ^ Info about each content file.
+
+  , tNodes        :: !(Maybe [NodeAddr HostName])
+    -- ^ This key should be set to the /K closest/ nodes in the
+    -- torrent generating client's routing table. Alternatively, the
+    -- key could be set to a known good 'Network.Address.Node'
+    -- such as one operated by the person generating the torrent.
+    --
+    -- Please do not automatically add \"router.bittorrent.com\" to
+    -- this list because different bittorrent software may prefer to
+    -- use different bootstrap node.
+
+  , tPublisher    :: !(Maybe URI)
+    -- ^ Containing the RSA public key of the publisher of the
+    -- torrent.  Private counterpart of this key that has the
+    -- authority to allow new peers onto the swarm.
+
+  , tPublisherURL :: !(Maybe URI)
+  , tSignature    :: !(Maybe BS.ByteString)
+    -- ^ The RSA signature of the info dictionary (specifically, the
+    --   encrypted SHA-1 hash of the info dictionary).
+    } deriving (Show, Eq, Typeable)
+
+makeLensesFor
+  [ ("tAnnounce"    , "announce"    )
+  , ("tAnnounceList", "announceList")
+  , ("tComment"     , "comment"     )
+  , ("tCreatedBy"   , "createdBy"   )
+  , ("tCreationDate", "creationDate")
+  , ("tEncoding"    , "encoding"    )
+  , ("tInfoDict"    , "infoDict"    )
+  , ("tPublisher"   , "publisher"   )
+  , ("tPublisherURL", "publisherURL")
+  , ("tSignature"   , "signature"   )
+  ]
+  ''Torrent
+
+instance NFData Torrent where
+  rnf Torrent {..} = rnf tInfoDict
+
+#ifdef VERSION_bencoding
+-- TODO move to bencoding
+instance BEncode URI where
+  toBEncode uri = toBEncode (BC.pack (uriToString id uri ""))
+  {-# INLINE toBEncode #-}
+
+  fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url
+  fromBEncode b           = decodingError $ "url <" ++ show b ++ ">"
+  {-# INLINE fromBEncode #-}
+
+--pico2uni :: Pico -> Uni
+--pico2uni = undefined
+
+-- TODO move to bencoding
+instance BEncode POSIXTime where
+  toBEncode pt = toBEncode (floor pt :: Integer)
+  fromBEncode (BInteger i) = return $ fromIntegral i
+  fromBEncode _            = decodingError $ "POSIXTime"
+
+-- TODO to bencoding package
+instance {-# OVERLAPPING #-} BEncode String where
+  toBEncode = toBEncode . T.pack
+  fromBEncode v = T.unpack <$> fromBEncode v
+
+instance BEncode Torrent where
+  toBEncode Torrent {..} = toDict $
+       "announce"      .=? tAnnounce
+    .: "announce-list" .=? tAnnounceList
+    .: "comment"       .=? tComment
+    .: "created by"    .=? tCreatedBy
+    .: "creation date" .=? tCreationDate
+    .: "encoding"      .=? tEncoding
+    .: "info"          .=! tInfoDict
+    .: "nodes"         .=? tNodes
+    .: "publisher"     .=? tPublisher
+    .: "publisher-url" .=? tPublisherURL
+    .: "signature"     .=? tSignature
+    .: endDict
+
+  fromBEncode = fromDict $ do
+    Torrent <$>? "announce"
+            <*>? "announce-list"
+            <*>? "comment"
+            <*>? "created by"
+            <*>? "creation date"
+            <*>? "encoding"
+            <*>! "info"
+            <*>? "nodes"
+            <*>? "publisher"
+            <*>? "publisher-url"
+            <*>? "signature"
+#endif
+
+(<:>) :: Doc -> Doc -> Doc
+name <:>   v       = name <> ":" <+> v
+
+(<:>?) :: Doc -> Maybe Doc -> Doc
+_    <:>?  Nothing = PP.empty
+name <:>? (Just d) = name <:> d
+
+instance Pretty Torrent where
+  pPrint Torrent {..} =
+       "InfoHash: " <> pPrint (idInfoHash tInfoDict)
+    $$ hang "General" 4 generalInfo
+    $$ hang "Tracker" 4 trackers
+    $$ pPrint tInfoDict
+   where
+    trackers = case tAnnounceList of
+        Nothing  -> text (show tAnnounce)
+        Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs
+      where
+        ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs)
+
+    generalInfo =
+        "Comment"       <:>? ((text . T.unpack) <$> tComment)      $$
+        "Created by"    <:>? ((text . T.unpack) <$> tCreatedBy)    $$
+        "Created on"    <:>? ((text . show . posixSecondsToUTCTime)
+                               <$> tCreationDate) $$
+        "Encoding"      <:>? ((text . T.unpack) <$> tEncoding)     $$
+        "Publisher"     <:>? ((text . show) <$> tPublisher)    $$
+        "Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$
+        "Signature"     <:>? ((text . show) <$> tSignature)
+
+#ifdef VERSION_bencoding
+-- | No files, no trackers, no nodes, etc...
+instance Default Torrent where
+  def = nullTorrent def
+#endif
+
+-- | A simple torrent contains only required fields.
+nullTorrent :: InfoDict -> Torrent
+nullTorrent info = Torrent
+    Nothing Nothing Nothing Nothing Nothing Nothing
+    info    Nothing Nothing Nothing Nothing
+
+-- | Mime type of torrent files.
+typeTorrent :: BS.ByteString
+typeTorrent = "application/x-bittorrent"
+
+-- | Extension usually used for torrent files.
+torrentExt :: String
+torrentExt = "torrent"
+
+-- | Test if this path has proper extension.
+isTorrentPath :: FilePath -> Bool
+isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt
+
+#ifdef VERSION_bencoding
+-- | Read and decode a .torrent file.
+fromFile :: FilePath -> IO Torrent
+fromFile filepath = do
+  contents <- BS.readFile filepath
+  case BE.decode contents of
+    Right !t -> return t
+    Left msg -> throwIO $ userError $ msg ++ " while reading torrent file"
+
+-- | Encode and write a .torrent file.
+toFile :: FilePath -> Torrent -> IO ()
+toFile filepath = BL.writeFile filepath . BE.encode
+#endif
+
+{-----------------------------------------------------------------------
+--  URN
+-----------------------------------------------------------------------}
+
+-- | Namespace identifier determines the syntactic interpretation of
+-- namespace-specific string.
+type NamespaceId = [Text]
+
+-- | BitTorrent Info Hash (hence the name) namespace
+-- identifier. Namespace-specific string /should/ be a base16\/base32
+-- encoded SHA1 hash of the corresponding torrent /info/ dictionary.
+--
+btih :: NamespaceId
+btih  = ["btih"]
+
+-- | URN is pesistent location-independent identifier for
+--   resources. In particular, URNs are used represent torrent names
+--   as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for
+--   more info.
+--
+data URN = URN
+  { urnNamespace :: NamespaceId -- ^ a namespace identifier;
+  , urnString    :: Text        -- ^ a corresponding
+                                -- namespace-specific string.
+  } deriving (Eq, Ord, Typeable)
+
+-----------------------------------------------------------------------
+
+instance Convertible URN InfoHash where
+  safeConvert u @ URN {..}
+    | urnNamespace /= btih = convError "invalid namespace" u
+    |       otherwise      = safeConvert urnString
+
+-- | Make resource name for torrent with corresponding
+-- infohash. Infohash is base16 (hex) encoded.
+--
+infohashURN :: InfoHash -> URN
+infohashURN = URN btih . longHex
+
+-- | Meaningless placeholder value.
+instance Default URN where
+  def = infohashURN def
+
+------------------------------------------------------------------------
+
+-- | Render URN to its text representation.
+renderURN :: URN -> Text
+renderURN URN {..}
+  = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString]
+
+instance Pretty URN where
+  pPrint = text . T.unpack . renderURN
+
+instance Show URN where
+  showsPrec n = showsPrec n . T.unpack . renderURN
+
+instance QueryValueLike URN where
+  toQueryValue = toQueryValue . renderURN
+  {-# INLINE toQueryValue #-}
+
+-----------------------------------------------------------------------
+
+_unsnoc :: [a] -> Maybe ([a], a)
+_unsnoc [] = Nothing
+_unsnoc xs = Just (L.init xs, L.last xs)
+
+instance Convertible Text URN where
+  safeConvert t = case T.split (== ':') t of
+    uriScheme : body
+      | T.toLower uriScheme == "urn" ->
+        case _unsnoc body of
+          Just (namespace, val) -> pure URN
+            { urnNamespace = namespace
+            , urnString    = val
+            }
+          Nothing -> convError "missing URN string" body
+      | otherwise -> convError "invalid URN scheme" uriScheme
+    []            -> convError "missing URN scheme" t
+
+instance IsString URN where
+  fromString = either (error . prettyConvertError) id
+             . safeConvert . T.pack
+
+-- | Try to parse an URN from its text representation.
+--
+--  Use 'safeConvert' for detailed error messages.
+--
+parseURN :: Text -> Maybe URN
+parseURN = either (const Nothing) pure . safeConvert
+
+{-----------------------------------------------------------------------
+--  Magnet
+-----------------------------------------------------------------------}
+-- $magnet-link
+--
+--   Magnet URI scheme is an standard defining Magnet links. Magnet
+--   links are refer to resources by hash, in particular magnet links
+--   can refer to torrent using corresponding infohash. In this way,
+--   magnet links can be used instead of torrent files.
+--
+--   This module provides bittorrent specific implementation of magnet
+--   links.
+--
+--   For generic magnet uri scheme see:
+--   <http://magnet-uri.sourceforge.net/magnet-draft-overview.txt>,
+--   <http://www.iana.org/assignments/uri-schemes/prov/magnet>
+--
+--   Bittorrent specific details:
+--   <http://www.bittorrent.org/beps/bep_0009.html>
+--
+
+-- TODO multiple exact topics
+-- TODO render/parse supplement for URI/query
+
+-- | An URI used to identify torrent.
+data Magnet = Magnet
+  { -- | Torrent infohash hash. Can be used in DHT queries if no
+    -- 'tracker' provided.
+    exactTopic  :: !InfoHash -- TODO InfoHash -> URN?
+
+    -- | A filename for the file to download. Can be used to
+    -- display name while waiting for metadata.
+  , displayName :: Maybe Text
+
+    -- | Size of the resource in bytes.
+  , exactLength :: Maybe Integer
+
+    -- | URI pointing to manifest, e.g. a list of further items.
+  , manifest :: Maybe Text
+
+    -- | Search string.
+  , keywordTopic :: Maybe Text
+
+    -- | A source to be queried after not being able to find and
+    -- download the file in the bittorrent network in a defined
+    -- amount of time.
+  , acceptableSource :: Maybe URI
+
+    -- | Direct link to the resource.
+  , exactSource      :: Maybe URI
+
+    -- | URI to the tracker.
+  , tracker :: Maybe URI
+
+    -- | Additional or experimental parameters.
+  , supplement :: Map Text Text
+  } deriving (Eq, Ord, Typeable)
+
+instance QueryValueLike Integer where
+  toQueryValue = toQueryValue . show
+
+instance QueryValueLike URI where
+  toQueryValue = toQueryValue . show
+
+instance QueryLike Magnet where
+  toQuery Magnet {..} =
+    [ ("xt", toQueryValue $ infohashURN exactTopic)
+    , ("dn", toQueryValue displayName)
+    , ("xl", toQueryValue exactLength)
+    , ("mt", toQueryValue manifest)
+    , ("kt", toQueryValue keywordTopic)
+    , ("as", toQueryValue acceptableSource)
+    , ("xs", toQueryValue exactSource)
+    , ("tr", toQueryValue tracker)
+    ]
+
+instance QueryValueLike Magnet where
+  toQueryValue = toQueryValue . renderMagnet
+
+instance Convertible QueryText Magnet where
+  safeConvert xs = do
+      urnStr   <- getTextMsg "xt" "exact topic not defined" xs
+      infoHash <- convertVia (error "safeConvert" :: URN)  urnStr
+      return Magnet
+        { exactTopic       = infoHash
+        , displayName      = getText "dn" xs
+        , exactLength      = getText "xl" xs >>= getInt
+        , manifest         = getText "mt" xs
+        , keywordTopic     = getText "kt" xs
+        , acceptableSource = getText "as" xs >>= getURI
+        , exactSource      = getText "xs" xs >>= getURI
+        , tracker          = getText "tr" xs >>= getURI
+        , supplement       = M.empty
+        }
+    where
+      getInt    = either (const Nothing) (Just . fst) . signed decimal
+      getURI    = parseURI . T.unpack
+      getText p = join . L.lookup p
+      getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps
+
+magnetScheme :: URI
+magnetScheme = URI
+    { uriScheme    = "magnet:"
+    , uriAuthority = Nothing
+    , uriPath      = ""
+    , uriQuery     = ""
+    , uriFragment  = ""
+    }
+
+isMagnetURI :: URI -> Bool
+isMagnetURI u = u { uriQuery = "" } == magnetScheme
+
+-- | Can be used instead of 'parseMagnet'.
+instance Convertible URI Magnet where
+  safeConvert u @ URI {..}
+    | not (isMagnetURI u) = convError "this is not a magnet link" u
+    |      otherwise      = safeConvert $ parseQueryText $ BC.pack uriQuery
+
+-- | Can be used instead of 'renderMagnet'.
+instance Convertible Magnet URI where
+  safeConvert m = pure $ magnetScheme
+    { uriQuery = BC.unpack $ renderQuery True $ toQuery m }
+
+instance Convertible String Magnet where
+  safeConvert str
+    | Just uri <- parseURI str = safeConvert uri
+    |        otherwise         = convError "unable to parse uri" str
+
+------------------------------------------------------------------------
+
+-- | Meaningless placeholder value.
+instance Default Magnet where
+  def = Magnet
+    { exactTopic       = def
+    , displayName      = Nothing
+    , exactLength      = Nothing
+    , manifest         = Nothing
+    , keywordTopic     = Nothing
+    , acceptableSource = Nothing
+    , exactSource      = Nothing
+    , tracker          = Nothing
+    , supplement       = M.empty
+    }
+
+-- | Set 'exactTopic' ('xt' param) only, other params are empty.
+nullMagnet :: InfoHash -> Magnet
+nullMagnet u = Magnet
+    { exactTopic   = u
+    , displayName  = Nothing
+    , exactLength  = Nothing
+    , manifest     = Nothing
+    , keywordTopic = Nothing
+    , acceptableSource = Nothing
+    , exactSource      = Nothing
+    , tracker    = Nothing
+    , supplement = M.empty
+    }
+
+-- | Like 'nullMagnet' but also include 'displayName' ('dn' param).
+simpleMagnet :: Torrent -> Magnet
+simpleMagnet Torrent {tInfoDict = InfoDict {..}}
+  = (nullMagnet idInfoHash)
+    { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo
+    }
+
+-- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and
+-- 'tracker' ('tr' param).
+--
+detailedMagnet :: Torrent -> Magnet
+detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce}
+  = (simpleMagnet t)
+    { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo
+    , tracker     = tAnnounce
+    }
+
+-----------------------------------------------------------------------
+
+parseMagnetStr :: String -> Maybe Magnet
+parseMagnetStr = either (const Nothing) Just . safeConvert
+
+renderMagnetStr :: Magnet -> String
+renderMagnetStr = show . (convert :: Magnet -> URI)
+
+instance Pretty Magnet where
+  pPrint = PP.text . renderMagnetStr
+
+instance Show Magnet where
+  show = renderMagnetStr
+  {-# INLINE show #-}
+
+instance Read Magnet where
+  readsPrec _ xs
+      | Just m <- parseMagnetStr mstr = [(m, rest)]
+      | otherwise = []
+    where
+      (mstr, rest) = L.break (== ' ') xs
+
+instance IsString Magnet where
+  fromString str = fromMaybe (error msg) $ parseMagnetStr str
+    where
+      msg = "unable to parse magnet: " ++ str
+
+-- | Try to parse magnet link from urlencoded string. Use
+-- 'safeConvert' to find out error location.
+--
+parseMagnet :: Text -> Maybe Magnet
+parseMagnet = parseMagnetStr . T.unpack
+{-# INLINE parseMagnet #-}
+
+-- | Render magnet link to urlencoded string
+renderMagnet :: Magnet -> Text
+renderMagnet = T.pack . renderMagnetStr
+{-# INLINE renderMagnet #-}
diff --git a/src/Data/Word64Map.hs b/src/Data/Word64Map.hs
new file mode 100644
index 00000000..9e93c8c8
--- /dev/null
+++ b/src/Data/Word64Map.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnboxedTuples       #-}
+module Data.Word64Map where
+
+import Data.Bits
+import qualified Data.IntMap as IntMap
+         ;import Data.IntMap (IntMap)
+import Data.Typeable
+import Data.Word
+
+-- | Since 'Int' may be 32 or 64 bits, this function is provided as a
+-- convenience to test if an integral type, such as 'Data.Word.Word64', can be
+-- safely transformed into an 'Int' for use with 'IntMap'.
+--
+-- Returns 'True' if the proxied type can be losslessly converted to 'Int' using
+-- 'fromIntegral'.
+fitsInInt :: forall proxy word. (Bounded word, Integral word) => proxy word -> Bool
+fitsInInt proxy = (original == casted)
+ where
+    original = div maxBound 2 :: word
+    casted   = fromIntegral (fromIntegral original :: Int) :: word
+
+newtype Word64Map a = Word64Map (IntMap (IntMap a))
+
+empty :: Word64Map a
+empty = Word64Map IntMap.empty
+
+-- Warning: This function assumes an 'Int' is either 64 or 32 bits.
+keyFrom64 :: Word64 -> (# Int,Int #)
+keyFrom64 w8 =
+    if fitsInInt (Proxy :: Proxy Word64)
+        then (# fromIntegral w8              , 0               #)
+        else (# fromIntegral (w8 `shiftR` 32), fromIntegral w8 #)
+{-# INLINE keyFrom64 #-}
+
+lookup :: Word64 -> Word64Map b -> Maybe b
+lookup w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 = do
+    m' <- IntMap.lookup hi m
+    IntMap.lookup lo m'
+{-# INLINE lookup #-}
+
+insert :: Word64 -> b -> Word64Map b -> Word64Map b
+insert w8 b (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
+    = Word64Map $ IntMap.alter (Just . maybe (IntMap.singleton lo b)
+                                             (IntMap.insert lo b))
+                               hi
+                               m
+{-# INLINE insert #-}
+
+delete :: Word64 -> Word64Map b -> Word64Map b
+delete w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
+    = Word64Map $ IntMap.alter (maybe Nothing
+                                      (\m' -> case IntMap.delete lo m' of
+                                                m'' | IntMap.null m'' -> Nothing
+                                                m''                   -> Just m''))
+                               hi
+                               m
+{-# INLINE delete #-}
+
+
+
diff --git a/src/Data/Wrapper/PSQ.hs b/src/Data/Wrapper/PSQ.hs
new file mode 100644
index 00000000..631af6ec
--- /dev/null
+++ b/src/Data/Wrapper/PSQ.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Data.Wrapper.PSQ
+#if 0
+     ( module Data.Wrapper.PSQ , module Data.PSQueue ) where
+
+import Data.PSQueue hiding (foldr, foldl)
+import qualified Data.PSQueue as PSQueue
+
+type PSQKey k = (Ord k)
+
+-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
+fold' :: (Ord k, Ord p) => (k -> p -> () -> a -> a) -> a -> PSQ k p -> a
+fold' f a q = PSQueue.foldr f' a q
+ where
+    f' (k :-> prio) x = f k prio () x
+
+#else
+    ( module Data.Wrapper.PSQ , module HashPSQ ) where
+
+import Data.OrdPSQ as OrdPSQ hiding (insert, map, singleton, minView)
+import qualified Data.OrdPSQ as OrdPSQ
+
+import Data.HashPSQ as HashPSQ hiding (insert, map, singleton, minView)
+import qualified Data.HashPSQ as Q
+import Data.Hashable
+
+type PSQ' k p v = HashPSQ k p v
+type PSQ k p    = PSQ' k p ()
+
+type Binding' k p v = (k,p,v)
+type Binding k p    = Binding' k p ()
+
+type PSQKey k = (Hashable k, Ord k)
+
+pattern (:->) :: k -> p -> Binding k p
+pattern k :-> p <- (k,p,_) where k :-> p = (k,p,())
+
+-- I tried defining (::->) :: (k,v) -> p -> Binding' k p v
+-- but no luck...
+pattern Binding :: k -> v -> p -> Binding' k p v
+pattern Binding k v p <- (k,p,v) where Binding k v p = (k,p,v)
+
+key :: (k,p,v) -> k
+key (k,p,v) = k
+{-# INLINE key #-}
+
+prio :: (k,p,v) -> p
+prio (k,p,v) = p
+{-# INLINE prio #-}
+
+insert :: (PSQKey k, Ord p) => k -> p -> PSQ k p -> PSQ k p
+insert k p q = Q.insert k p () q
+{-# INLINE insert #-}
+
+insert' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v -> PSQ' k p v
+insert' k v p q = Q.insert k p v q
+{-# INLINE insert' #-}
+
+insertWith :: (PSQKey k, Ord p) => (p -> p -> p) -> k -> p -> PSQ k p -> PSQ k p
+insertWith f k p0 q = snd $ Q.alter f' k q
+ where
+    f' (Just (p,())) = ((),Just (f p0 p, ()))
+    f' Nothing       = ((),Just (p0,()))
+{-# INLINE insertWith #-}
+
+singleton :: (PSQKey k, Ord p) => k -> p -> PSQ k p
+singleton k p = Q.singleton k p ()
+{-# INLINE singleton #-}
+
+singleton' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v
+singleton' k v p = Q.singleton k p v
+{-# INLINE singleton' #-}
+
+
+minView :: (PSQKey k, Ord p) => PSQ' k p v -> Maybe (Binding' k p v, PSQ' k p v)
+minView q = fmap (\(k,p,v,q') -> (Binding k v p, q')) $ Q.minView q
+{-# INLINE minView #-}
+
+#endif
diff --git a/src/Data/Wrapper/PSQInt.hs b/src/Data/Wrapper/PSQInt.hs
new file mode 100644
index 00000000..c61b7ab6
--- /dev/null
+++ b/src/Data/Wrapper/PSQInt.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Data.Wrapper.PSQInt
+#if 0
+     ( module Data.Wrapper.PSQInt , module Data.PSQueue ) where
+
+import Data.PSQueue hiding (foldr, foldl, PSQ)
+import qualified Data.PSQueue as PSQueue
+
+type PSQ p = PSQueue.PSQ Int p
+
+-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
+fold' :: (Ord p) => (Int -> p -> () -> a -> a) -> a -> PSQ p -> a
+fold' f a q = PSQueue.foldr f' a q
+ where
+    f' (k :-> prio) x = f k prio () x
+
+#else
+    ( module Data.Wrapper.PSQInt
+    , module IntPSQ
+    , pattern (:->)
+    , key
+    , prio
+    ) where
+
+import Data.Wrapper.PSQ (Binding, pattern (:->), key, prio)
+
+import Data.IntPSQ as IntPSQ hiding (insert, map, singleton, minView)
+import qualified Data.IntPSQ as Q
+
+type PSQ p = IntPSQ p ()
+
+type PSQKey = ()
+
+insert :: (Ord p) => Int -> p -> PSQ p -> PSQ p
+insert k p q = Q.insert k p () q
+{-# INLINE insert #-}
+
+insertWith :: (Ord p) => (p -> p -> p) -> Int -> p -> PSQ p -> PSQ p
+insertWith f k p0 q = snd $ Q.alter f' k q
+ where
+    f' (Just (p,())) = ((),Just (f p0 p, ()))
+    f' Nothing      = ((),Nothing)
+{-# INLINE insertWith #-}
+
+singleton :: (Ord p) => Int -> p -> PSQ p
+singleton k p = Q.singleton k p ()
+{-# INLINE singleton #-}
+
+minView :: (Ord p) => PSQ p -> Maybe (Binding Int p, PSQ p)
+minView q = fmap (\(k,p,(),q') -> (k :-> p, q')) $ Q.minView q
+{-# INLINE minView #-}
+
+#endif
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
new file mode 100644
index 00000000..4f163b79
--- /dev/null
+++ b/src/Network/Address.hs
@@ -0,0 +1,1225 @@
+-- |
+--   Module      :  Network.Address
+--   Copyright   :  (c) Sam Truzjan 2013
+--                  (c) Daniel Gröber 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  provisional
+--   Portability :  portable
+--
+--   Peer and Node addresses.
+--
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE ViewPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.Address
+       ( -- * Address
+         Address (..)
+       , fromAddr
+       , PortNumber
+       , SockAddr
+
+         -- ** IP
+       , IPv4
+       , IPv6
+       , IP (..)
+       , un4map
+       , WantIP (..)
+       , ipFamily
+       , is4mapped
+       , either4or6
+
+         -- * PeerId
+         -- $peer-id
+       , PeerId
+
+         -- ** Generation
+       , genPeerId
+       , timestamp
+       , entropy
+
+         -- ** Encoding
+       , azureusStyle
+       , shadowStyle
+       , defaultClientId
+       , defaultVersionNumber
+
+         -- * PeerAddr
+         -- $peer-addr
+       , PeerAddr(..)
+       , defaultPorts
+       , peerSockAddr
+       , peerSocket
+
+         -- * Node
+       , NodeAddr (..)
+
+         -- ** Id
+       , testIdBit
+       , bucketRange
+       , genBucketSample
+       , genBucketSample'
+
+         -- * Fingerprint
+         -- $fingerprint
+       , Software (..)
+       , Fingerprint (..)
+       , libFingerprint
+       , fingerprint
+
+         -- * Utils
+       , libUserAgent
+       , sockAddrPort
+       , setPort
+       , getBindAddress
+       ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Exception (onException)
+#ifdef VERSION_bencoding
+import Data.BEncode as BE
+import Data.BEncode.BDict (BKey)
+#endif
+import Data.Bits
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS
+import Data.ByteString.Char8 as BC
+import Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Builder as BS
+import Data.Char
+import Data.Convertible
+import Data.Default
+import Data.IP
+import Data.List as L
+import Data.List.Split as L
+import Data.Maybe       (fromMaybe, catMaybes, mapMaybe)
+import Data.Monoid
+import Data.Hashable
+import Data.Ord
+import Data.Serialize as S
+import Data.String
+import Data.Time
+import Data.Typeable
+import Data.Version
+import Data.Word
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.Read        (readMaybe)
+import Network.HTTP.Types.QueryLike
+import Network.Socket
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+#if !MIN_VERSION_time(1,5,0)
+import System.Locale    (defaultTimeLocale)
+#endif
+import System.Entropy
+import System.IO (stderr)
+
+-- import Paths_bittorrent (version)
+
+instance Pretty UTCTime where
+  pPrint = PP.text . show
+
+setPort :: PortNumber -> SockAddr -> SockAddr
+setPort port (SockAddrInet  _   h  ) = SockAddrInet  port   h
+setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
+setPort _    addr                    = addr
+{-# INLINE setPort #-}
+
+-- | Obtains the port associated with a socket address
+-- if one is associated with it.
+sockAddrPort :: SockAddr -> Maybe PortNumber
+sockAddrPort (SockAddrInet  p   _  ) = Just p
+sockAddrPort (SockAddrInet6 p _ _ _) = Just p
+sockAddrPort _                       = Nothing
+{-# INLINE sockAddrPort #-}
+
+class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
+    => Address a where
+  toSockAddr   :: a        -> SockAddr
+  fromSockAddr :: SockAddr -> Maybe a
+
+fromAddr :: (Address a, Address b) => a -> Maybe b
+fromAddr = fromSockAddr . toSockAddr
+
+-- | Note that port is zeroed.
+instance Address IPv4 where
+  toSockAddr = SockAddrInet 0 . toHostAddress
+  fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
+  fromSockAddr  _                 = Nothing
+
+-- | Note that port is zeroed.
+instance Address IPv6 where
+  toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
+  fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
+  fromSockAddr  _                      = Nothing
+
+-- | Note that port is zeroed.
+instance Address IP where
+  toSockAddr (IPv4 h) = toSockAddr h
+  toSockAddr (IPv6 h) = toSockAddr h
+  fromSockAddr sa =
+        IPv4 <$> fromSockAddr sa
+    <|> IPv6 <$> fromSockAddr sa
+
+data NodeAddr a = NodeAddr
+  { nodeHost ::                !a
+  , nodePort :: {-# UNPACK #-} !PortNumber
+  } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
+
+instance Show a => Show (NodeAddr a) where
+  showsPrec i NodeAddr {..}
+    = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
+
+instance Read (NodeAddr IPv4) where
+  readsPrec i = RP.readP_to_S $ do
+    ipv4 <- RP.readS_to_P (readsPrec i)
+    _    <- RP.char ':'
+    port <- toEnum <$> RP.readS_to_P (readsPrec i)
+    return $ NodeAddr ipv4 port
+
+-- | @127.0.0.1:6882@
+instance Default (NodeAddr IPv4) where
+  def = "127.0.0.1:6882"
+
+-- | KRPC compatible encoding.
+instance Serialize a => Serialize (NodeAddr a) where
+  get = NodeAddr <$> get <*> get
+  {-# INLINE get #-}
+  put NodeAddr {..} = put nodeHost >> put nodePort
+  {-# INLINE put #-}
+
+-- | Example:
+--
+--   @nodePort \"127.0.0.1:6881\" == 6881@
+--
+instance IsString (NodeAddr IPv4) where
+  fromString str
+    | [hostAddrStr, portStr] <- splitWhen (== ':') str
+    , Just hostAddr <- readMaybe hostAddrStr
+    , Just portNum  <- toEnum <$> readMaybe portStr
+                = NodeAddr hostAddr portNum
+    | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str
+
+
+instance Hashable a => Hashable (NodeAddr a) where
+  hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
+  {-# INLINE hashWithSalt #-}
+
+instance Pretty ip => Pretty (NodeAddr ip) where
+  pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
+
+
+
+instance Address PeerAddr where
+  toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
+  fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> sockAddrPort sa
+
+{-----------------------------------------------------------------------
+--  Peer id
+-----------------------------------------------------------------------}
+-- $peer-id
+--
+--  'PeerID' represent self assigned peer identificator. Ideally each
+--  host in the network should have unique peer id to avoid
+--  collisions, therefore for peer ID generation we use good entropy
+--  source. Peer ID is sent in /tracker request/, sent and received in
+--  /peer handshakes/ and used in DHT queries.
+--
+
+-- TODO use unpacked Word160 form (length is known statically)
+
+-- | Peer identifier is exactly 20 bytes long bytestring.
+newtype PeerId = PeerId { getPeerId :: ByteString }
+  deriving ( Show, Eq, Ord, Typeable
+#ifdef VERSION_bencoding
+           , BEncode
+#endif
+           )
+
+peerIdLen :: Int
+peerIdLen = 20
+
+-- | For testing purposes only.
+instance Default PeerId where
+  def = azureusStyle defaultClientId defaultVersionNumber ""
+
+instance Hashable PeerId where
+  hashWithSalt = hashUsing getPeerId
+  {-# INLINE hashWithSalt #-}
+
+instance Serialize PeerId where
+  put = putByteString . getPeerId
+  get = PeerId <$> getBytes peerIdLen
+
+instance QueryValueLike PeerId where
+  toQueryValue (PeerId pid) = Just pid
+  {-# INLINE toQueryValue #-}
+
+instance IsString PeerId where
+  fromString str
+      | BS.length bs == peerIdLen = PeerId bs
+      | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
+    where
+      bs = fromString str
+
+instance Pretty PeerId where
+  pPrint = text . BC.unpack . getPeerId
+
+instance Convertible BS.ByteString PeerId where
+  safeConvert bs
+    | BS.length bs == peerIdLen = pure (PeerId bs)
+    |          otherwise        = convError "invalid length" bs
+
+------------------------------------------------------------------------
+
+-- | Pad bytestring so it's becomes exactly request length. Conversion
+-- is done like so:
+--
+--     * length < size: Complete bytestring by given charaters.
+--
+--     * length = size: Output bytestring as is.
+--
+--     * length > size: Drop last (length - size) charaters from a
+--     given bytestring.
+--
+byteStringPadded :: ByteString -- ^ bytestring to be padded.
+                 -> Int        -- ^ size of result builder.
+                 -> Char       -- ^ character used for padding.
+                 -> BS.Builder
+byteStringPadded bs s c =
+      BS.byteString (BS.take s bs) <>
+      BS.byteString (BC.replicate padLen c)
+  where
+    padLen = s - min (BS.length bs) s
+
+-- | Azureus-style encoding have the following layout:
+--
+--     * 1  byte : '-'
+--
+--     * 2  bytes: client id
+--
+--     * 4  bytes: version number
+--
+--     * 1  byte : '-'
+--
+--     * 12 bytes: random number
+--
+azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
+             -> ByteString -- ^ Version number, padded with 'X'.
+             -> ByteString -- ^ Random number, padded with '0'.
+             -> PeerId     -- ^ Azureus-style encoded peer ID.
+azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
+    BS.char8 '-' <>
+      byteStringPadded cid 2  'H' <>
+      byteStringPadded ver 4  'X' <>
+    BS.char8 '-' <>
+      byteStringPadded rnd 12 '0'
+
+-- | Shadow-style encoding have the following layout:
+--
+--     * 1 byte   : client id.
+--
+--     * 0-4 bytes: version number. If less than 4 then padded with
+--     '-' char.
+--
+--     * 15 bytes : random number. If length is less than 15 then
+--     padded with '0' char.
+--
+shadowStyle :: Char       -- ^ Client ID.
+            -> ByteString -- ^ Version number.
+            -> ByteString -- ^ Random number.
+            -> PeerId     -- ^ Shadow style encoded peer ID.
+shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
+    BS.char8 cid <>
+      byteStringPadded ver 4  '-' <>
+      byteStringPadded rnd 15 '0'
+
+
+-- | 'HS'- 2 bytes long client identifier.
+defaultClientId :: ByteString
+defaultClientId = "HS"
+
+-- | Gives exactly 4 bytes long version number for any version of the
+-- package.  Version is taken from .cabal file.
+defaultVersionNumber :: ByteString
+defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
+                         versionBranch myVersion
+  where
+    Fingerprint _ myVersion = libFingerprint
+
+------------------------------------------------------------------------
+
+-- | Gives 15 characters long decimal timestamp such that:
+--
+--     * 6 bytes   : first 6 characters from picoseconds obtained with %q.
+--
+--     * 1 byte    : character \'.\' for readability.
+--
+--     * 9..* bytes: number of whole seconds since the Unix epoch
+--     (!)REVERSED.
+--
+--   Can be used both with shadow and azureus style encoding. This
+--   format is used to make the ID's readable for debugging purposes.
+--
+timestamp :: IO ByteString
+timestamp = (BC.pack . format) <$> getCurrentTime
+  where
+    format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
+               L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t))
+
+-- | Gives 15 character long random bytestring. This is more robust
+-- method for generation of random part of peer ID than 'timestamp'.
+entropy :: IO ByteString
+entropy = getEntropy 15
+
+-- NOTE: entropy generates incorrrect peer id
+
+-- |  Here we use 'azureusStyle' encoding with the following args:
+--
+--      * 'HS' for the client id; ('defaultClientId')
+--
+--      * Version of the package for the version number;
+--      ('defaultVersionNumber')
+--
+--      * UTC time day ++ day time for the random number. ('timestamp')
+--
+genPeerId :: IO PeerId
+genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
+
+{-----------------------------------------------------------------------
+-- Peer Addr
+-----------------------------------------------------------------------}
+-- $peer-addr
+--
+--   'PeerAddr' is used to represent peer address. Currently it's
+--   just peer IP and peer port but this might change in future.
+--
+
+{-----------------------------------------------------------------------
+--  Port number
+-----------------------------------------------------------------------}
+
+#ifdef VERSION_bencoding
+instance BEncode PortNumber where
+  toBEncode   = toBEncode    .  fromEnum
+  fromBEncode = fromBEncode >=> portNumber
+    where
+      portNumber :: Integer -> BE.Result PortNumber
+      portNumber n
+        | 0 <= n && n <= fromIntegral (maxBound :: Word16)
+        = pure $ fromIntegral n
+        | otherwise = decodingError $ "PortNumber: " ++ show n
+#endif
+{-----------------------------------------------------------------------
+--  IP addr
+-----------------------------------------------------------------------}
+
+class IPAddress i where
+  toHostAddr :: i -> Either HostAddress HostAddress6
+
+instance IPAddress IPv4 where
+  toHostAddr = Left . toHostAddress
+  {-# INLINE toHostAddr #-}
+
+instance IPAddress IPv6 where
+  toHostAddr = Right . toHostAddress6
+  {-# INLINE toHostAddr #-}
+
+instance IPAddress IP where
+  toHostAddr (IPv4 ip) = toHostAddr ip
+  toHostAddr (IPv6 ip) = toHostAddr ip
+  {-# INLINE toHostAddr #-}
+
+deriving instance Typeable IP
+deriving instance Typeable IPv4
+deriving instance Typeable IPv6
+
+#ifdef VERSION_bencoding
+ipToBEncode :: Show i => i -> BValue
+ipToBEncode ip = BString $ BS8.pack $ show ip
+{-# INLINE ipToBEncode #-}
+
+ipFromBEncode :: Read a => BValue -> BE.Result a
+ipFromBEncode (BString (BS8.unpack -> ipStr))
+  | Just ip <- readMaybe (ipStr) = pure ip
+  |         otherwise            = decodingError $ "IP: " ++ ipStr
+ipFromBEncode _    = decodingError $ "IP: addr should be a bstring"
+
+instance BEncode IP where
+  toBEncode   = ipToBEncode
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+
+instance BEncode IPv4 where
+  toBEncode   = ipToBEncode
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+
+instance BEncode IPv6 where
+  toBEncode   = ipToBEncode
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+#endif
+
+-- | Peer address info normally extracted from peer list or peer
+-- compact list encoding.
+data PeerAddr = PeerAddr
+  { peerId   :: !(Maybe PeerId)
+
+    -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
+    -- 'HostName'.
+  , peerHost :: !IP
+
+    -- | The port the peer listenning for incoming P2P sessions.
+  , peerPort :: {-# UNPACK #-} !PortNumber
+  } deriving (Show, Eq, Ord, Typeable)
+
+#ifdef VERSION_bencoding
+peer_ip_key, peer_id_key, peer_port_key :: BKey
+peer_ip_key   = "ip"
+peer_id_key   = "peer id"
+peer_port_key = "port"
+
+-- | The tracker's 'announce response' compatible encoding.
+instance BEncode PeerAddr where
+  toBEncode PeerAddr {..} = toDict $
+       peer_ip_key   .=! peerHost
+    .: peer_id_key   .=? peerId
+    .: peer_port_key .=! peerPort
+    .: endDict
+
+  fromBEncode = fromDict $ do
+    peerAddr <$>! peer_ip_key
+             <*>? peer_id_key
+             <*>! peer_port_key
+    where
+      peerAddr = flip PeerAddr
+#endif
+
+-- | The tracker's 'compact peer list' compatible encoding. The
+-- 'peerId' is always 'Nothing'.
+--
+--   For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
+--
+-- WARNING: Input must be exactly 6 or 18 bytes so that we can identify IP version.
+--
+instance Serialize PeerAddr where
+  put PeerAddr {..} = put peerHost >> put peerPort
+  get = do
+    cnt <- remaining
+    PeerAddr Nothing <$> isolate (cnt - 2) get <*> get
+
+-- | @127.0.0.1:6881@
+instance Default PeerAddr where
+  def = "127.0.0.1:6881"
+
+-- | Example:
+--
+--   @peerPort \"127.0.0.1:6881\" == 6881@
+--
+instance IsString PeerAddr where
+  fromString str
+    | [hostAddrStr, portStr] <- splitWhen (== ':') str
+    , Just hostAddr <- readMaybe hostAddrStr
+    , Just portNum  <- toEnum <$> readMaybe portStr
+                = PeerAddr Nothing (IPv4 hostAddr) portNum
+    | [((ip,port),"")] <- readsIPv6_port str =
+        PeerAddr Nothing (IPv6 ip) port
+    | otherwise = error $ "fromString: unable to parse IP: " ++ str
+
+instance Read PeerAddr where
+  readsPrec i = RP.readP_to_S $ do
+    ip <-     IPv4 <$> ( RP.readS_to_P (readsPrec i)                         )
+          <|> IPv6 <$> ( RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' )
+    _    <- RP.char ':'
+    port <- toEnum <$> RP.readS_to_P (readsPrec i)
+    return $ PeerAddr Nothing ip port
+
+readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
+readsIPv6_port = RP.readP_to_S $ do
+  ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']'
+  _ <- RP.char ':'
+  port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof
+  return (ip,port)
+
+
+-- | fingerprint + "at" + dotted.host.inet.addr:port
+instance Pretty PeerAddr where
+  pPrint PeerAddr {..}
+    | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
+    |     otherwise      = paddr
+    where
+      paddr = pPrint peerHost <> ":" <> text (show peerPort)
+
+instance Hashable PeerAddr where
+  hashWithSalt s PeerAddr {..} =
+    s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort
+
+-- | Ports typically reserved for bittorrent P2P listener.
+defaultPorts :: [PortNumber]
+defaultPorts =  [6881..6889]
+
+_peerSockAddr :: PeerAddr -> (Family, SockAddr)
+_peerSockAddr PeerAddr {..} =
+    case peerHost of
+          IPv4 ipv4 ->
+              (AF_INET, SockAddrInet peerPort (toHostAddress  ipv4))
+          IPv6 ipv6 ->
+              (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0)
+
+peerSockAddr :: PeerAddr -> SockAddr
+peerSockAddr = snd . _peerSockAddr
+
+-- | Create a socket connected to the address specified in a peerAddr
+peerSocket :: SocketType -> PeerAddr -> IO Socket
+peerSocket socketType pa = do
+    let (family, addr) = _peerSockAddr pa
+    sock <- socket family socketType defaultProtocol
+    connect sock addr
+    return sock
+
+{-----------------------------------------------------------------------
+--  Node info
+-----------------------------------------------------------------------}
+--   $node-info
+--
+--   A \"node\" is a client\/server listening on a UDP port
+--   implementing the distributed hash table protocol. The DHT is
+--   composed of nodes and stores the location of peers. BitTorrent
+--   clients include a DHT node, which is used to contact other nodes
+--   in the DHT to get the location of peers to download from using
+--   the BitTorrent protocol.
+
+-- asNodeId :: ByteString -> NodeId
+-- asNodeId bs = NodeId $ BS.take nodeIdSize bs
+
+{-
+
+-- | Test if the nth bit is set.
+testIdBit :: NodeId -> Word -> Bool
+testIdBit (NodeId bs) i
+  | fromIntegral i < nodeIdSize * 8
+  , (q, r) <- quotRem (fromIntegral i) 8
+  = testBit (BS.index bs q) (7 - r)
+  |     otherwise      = False
+-}
+
+testIdBit :: FiniteBits bs => bs -> Word -> Bool
+testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i))
+{-# INLINE testIdBit #-}
+
+-- | Generate a random 'NodeId' within a range suitable for a bucket.  To
+-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
+-- is for the current deepest bucket in our routing table:
+--
+-- > sample <- genBucketSample nid (bucketRange index is_last)
+genBucketSample :: ( FiniteBits nid
+                   , Serialize nid
+                   ) => nid -> (Int,Word8,Word8) -> IO nid
+genBucketSample n qmb = genBucketSample' getEntropy n qmb
+
+-- | Generalizion of 'genBucketSample' that accepts a byte generator
+-- function to use instead of the system entropy.
+genBucketSample' :: forall m dht nid.
+                    ( Applicative m
+                    , FiniteBits nid
+                    , Serialize nid
+                    ) =>
+    (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
+genBucketSample' gen self (q,m,b)
+    | q <= 0           =  either error id . S.decode <$> gen nodeIdSize
+    | q >= nodeIdSize  =  pure self
+    | otherwise        =  either error id . S.decode .  build <$> gen (nodeIdSize - q + 1)
+ where
+    nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
+
+    -- Prepends q bytes to modified input:
+    --   applies mask m
+    --   toggles bit b
+    build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
+     where
+        hd = BS.take q $ S.encode self
+        h = xor b (complement m .&. BS.last hd)
+        t = m .&. BS.head tl
+
+
+------------------------------------------------------------------------
+
+-- | Accepts a depth/index of a bucket and whether or not it is the last one,
+-- yields:
+--
+--  count of leading bytes to be copied from your node id.
+--
+--  mask to clear the extra bits of the last copied byte
+--
+--  mask to toggle the last copied bit if it is not the last bucket
+--
+-- Normally this is used with 'genBucketSample' to obtain a random id suitable
+-- for refreshing a particular bucket.
+bucketRange :: Int -> Bool -> (Int, Word8, Word8)
+bucketRange depth is_last = (q,m,b)
+ where
+     (q,r) = divMod ((if is_last then (+7) else (+8)) depth) 8
+     m = 2^(7-r) - 1
+     b = if is_last then 0 else 2^(7-r)
+
+------------------------------------------------------------------------
+
+#ifdef VERSION_bencoding
+-- | Torrent file compatible encoding.
+instance BEncode a => BEncode (NodeAddr a) where
+  toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort)
+  {-# INLINE toBEncode #-}
+  fromBEncode b = uncurry NodeAddr <$> fromBEncode b
+  {-# INLINE fromBEncode #-}
+#endif
+
+
+instance Hashable PortNumber where
+  hashWithSalt s = hashWithSalt s . fromEnum
+  {-# INLINE hashWithSalt #-}
+
+instance Pretty PortNumber where
+  pPrint = PP.int . fromEnum
+  {-# INLINE pPrint #-}
+
+instance Serialize PortNumber where
+  get = fromIntegral <$> getWord16be
+  {-# INLINE get #-}
+  put = putWord16be . fromIntegral
+  {-# INLINE put #-}
+
+instance Pretty IPv4 where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+instance Pretty IPv6 where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+instance Pretty IP where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+
+-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
+-- number of bytes since we have no other way of telling which
+-- address type we are trying to parse
+instance Serialize IP where
+    put (IPv4 ip) = put ip
+    put (IPv6 ip) = put ip
+
+    get = do
+      n <- remaining
+      case n of
+        4  -> IPv4 <$> get
+        16 -> IPv6 <$> get
+        _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
+
+instance Serialize IPv4 where
+    put = putWord32host    .  toHostAddress
+    get = fromHostAddress <$> getWord32host
+
+instance Serialize IPv6 where
+    put ip = put $ toHostAddress6 ip
+    get = fromHostAddress6 <$> get
+
+
+instance Hashable IPv4 where
+  hashWithSalt = hashUsing toHostAddress
+  {-# INLINE hashWithSalt #-}
+
+instance Hashable IPv6 where
+  hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
+
+instance Hashable IP where
+  hashWithSalt s (IPv4 h) = hashWithSalt s h
+  hashWithSalt s (IPv6 h) = hashWithSalt s h
+
+
+
+------------------------------------------------------------------------
+
+{-----------------------------------------------------------------------
+-- Fingerprint
+-----------------------------------------------------------------------}
+-- $fingerprint
+--
+--   'Fingerprint' is used to identify the client implementation and
+--   version which also contained in 'Peer'. For exsample first 6
+--   bytes of peer id of this this library are @-HS0100-@ while for
+--   mainline we have @M4-3-6--@.  We could extract this info and
+--   print in human-friendly form: this is useful for debugging and
+--   logging.
+--
+--   For more information see:
+--   <http://bittorrent.org/beps/bep_0020.html>
+--
+--
+--   NOTE: Do /not/ use this information to control client
+--   capabilities (such as supported enchancements), this should be
+--   done using 'Network.BitTorrent.Extension'!
+--
+
+-- TODO FIXME
+version :: Version
+version = Version [0, 0, 0, 3] []
+
+-- | List of registered client versions + 'IlibHSbittorrent' (this
+-- package) + 'IUnknown' (for not recognized software). All names are
+-- prefixed by \"I\" because some of them starts from lowercase letter
+-- but that is not a valid Haskell constructor name.
+--
+data Software =
+   IUnknown
+
+ | IMainline
+
+ | IABC
+ | IOspreyPermaseed
+ | IBTQueue
+ | ITribler
+ | IShadow
+ | IBitTornado
+
+-- UPnP(!) Bit Torrent !???
+-- 'U' - UPnP NAT Bit Torrent
+ | IBitLord
+ | IOpera
+ | IMLdonkey
+
+ | IAres
+ | IArctic
+ | IAvicora
+ | IBitPump
+ | IAzureus
+ | IBitBuddy
+ | IBitComet
+ | IBitflu
+ | IBTG
+ | IBitRocket
+ | IBTSlave
+ | IBittorrentX
+ | IEnhancedCTorrent
+ | ICTorrent
+ | IDelugeTorrent
+ | IPropagateDataClient
+ | IEBit
+ | IElectricSheep
+ | IFoxTorrent
+ | IGSTorrent
+ | IHalite
+ | IlibHSbittorrent
+ | IHydranode
+ | IKGet
+ | IKTorrent
+ | ILH_ABC
+ | ILphant
+ | ILibtorrent
+ | ILibTorrent
+ | ILimeWire
+ | IMonoTorrent
+ | IMooPolice
+ | IMiro
+ | IMoonlightTorrent
+ | INetTransport
+ | IPando
+ | IqBittorrent
+ | IQQDownload
+ | IQt4TorrentExample
+ | IRetriever
+ | IShareaza
+ | ISwiftbit
+ | ISwarmScope
+ | ISymTorrent
+ | Isharktorrent
+ | ITorrentDotNET
+ | ITransmission
+ | ITorrentstorm
+ | ITuoTu
+ | IuLeecher
+ | IuTorrent
+ | IVagaa
+ | IBitLet
+ | IFireTorrent
+ | IXunlei
+ | IXanTorrent
+ | IXtorrent
+ | IZipTorrent
+   deriving (Show, Eq, Ord, Enum, Bounded)
+
+parseSoftware :: ByteString -> Software
+parseSoftware = f . BC.unpack
+ where
+  f "AG" = IAres
+  f "A~" = IAres
+  f "AR" = IArctic
+  f "AV" = IAvicora
+  f "AX" = IBitPump
+  f "AZ" = IAzureus
+  f "BB" = IBitBuddy
+  f "BC" = IBitComet
+  f "BF" = IBitflu
+  f "BG" = IBTG
+  f "BR" = IBitRocket
+  f "BS" = IBTSlave
+  f "BX" = IBittorrentX
+  f "CD" = IEnhancedCTorrent
+  f "CT" = ICTorrent
+  f "DE" = IDelugeTorrent
+  f "DP" = IPropagateDataClient
+  f "EB" = IEBit
+  f "ES" = IElectricSheep
+  f "FT" = IFoxTorrent
+  f "GS" = IGSTorrent
+  f "HL" = IHalite
+  f "HS" = IlibHSbittorrent
+  f "HN" = IHydranode
+  f "KG" = IKGet
+  f "KT" = IKTorrent
+  f "LH" = ILH_ABC
+  f "LP" = ILphant
+  f "LT" = ILibtorrent
+  f "lt" = ILibTorrent
+  f "LW" = ILimeWire
+  f "MO" = IMonoTorrent
+  f "MP" = IMooPolice
+  f "MR" = IMiro
+  f "ML" = IMLdonkey
+  f "MT" = IMoonlightTorrent
+  f "NX" = INetTransport
+  f "PD" = IPando
+  f "qB" = IqBittorrent
+  f "QD" = IQQDownload
+  f "QT" = IQt4TorrentExample
+  f "RT" = IRetriever
+  f "S~" = IShareaza
+  f "SB" = ISwiftbit
+  f "SS" = ISwarmScope
+  f "ST" = ISymTorrent
+  f "st" = Isharktorrent
+  f "SZ" = IShareaza
+  f "TN" = ITorrentDotNET
+  f "TR" = ITransmission
+  f "TS" = ITorrentstorm
+  f "TT" = ITuoTu
+  f "UL" = IuLeecher
+  f "UT" = IuTorrent
+  f "VG" = IVagaa
+  f "WT" = IBitLet
+  f "WY" = IFireTorrent
+  f "XL" = IXunlei
+  f "XT" = IXanTorrent
+  f "XX" = IXtorrent
+  f "ZT" = IZipTorrent
+  f _    = IUnknown
+
+-- | Used to represent a not recognized implementation
+instance Default Software where
+  def = IUnknown
+  {-# INLINE def #-}
+
+-- | Example: @\"BitLet\" == 'IBitLet'@
+instance IsString Software where
+  fromString str
+    | Just impl <- L.lookup str alist = impl
+    | otherwise = error $ "fromString: not recognized " ++ str
+    where
+      alist = L.map mk [minBound..maxBound]
+      mk  x = (L.tail $ show x, x)
+
+-- | Example: @pPrint 'IBitLet' == \"IBitLet\"@
+instance Pretty Software where
+  pPrint = text . L.tail . show
+
+-- | Just the '0' version.
+instance Default Version where
+  def = Version [0] []
+  {-# INLINE def #-}
+
+-- | For dot delimited version strings.
+--   Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@
+--
+instance IsString Version where
+  fromString str
+    | Just nums <- chunkNums str = Version nums []
+    | otherwise = error $ "fromString: invalid version string " ++ str
+    where
+      chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
+
+instance Pretty Version where
+  pPrint = text . showVersion
+
+-- | The all sensible infomation that can be obtained from a peer
+-- identifier or torrent /createdBy/ field.
+data Fingerprint = Fingerprint Software Version
+  deriving (Show, Eq, Ord)
+
+-- | Unrecognized client implementation.
+instance Default Fingerprint where
+  def = Fingerprint def def
+  {-# INLINE def #-}
+
+-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
+instance IsString Fingerprint where
+  fromString str
+    | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver)
+    | otherwise = error $ "fromString: invalid client info string" ++ str
+    where
+      (impl, _ver) = L.span ((/=) '-') str
+
+instance Pretty Fingerprint where
+  pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v
+
+-- | Fingerprint of this (the bittorrent library) package. Normally,
+-- applications should introduce its own fingerprints, otherwise they
+-- can use 'libFingerprint' value.
+--
+libFingerprint :: Fingerprint
+libFingerprint =  Fingerprint IlibHSbittorrent version
+
+-- | HTTP user agent of this (the bittorrent library) package. Can be
+-- used in HTTP tracker requests.
+libUserAgent :: String
+libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version)
+
+{-----------------------------------------------------------------------
+--  For torrent file
+-----------------------------------------------------------------------}
+-- TODO collect information about createdBy torrent field
+-- renderImpl :: ClientImpl -> Text
+-- renderImpl = T.pack . L.tail . show
+--
+-- renderVersion :: Version -> Text
+-- renderVersion = undefined
+--
+-- renderClientInfo :: ClientInfo -> Text
+-- renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
+--
+-- parseClientInfo :: Text -> ClientImpl
+-- parseClientInfo t = undefined
+
+
+-- code used for generation; remove it later on
+--
+-- mkEnumTyDef :: NM -> String
+-- mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
+--
+-- mkPars :: NM -> String
+-- mkPars = unlines . map (\(code, impl) -> "  f \"" ++ code ++ "\" = " ++ "I" ++ impl)
+--
+-- type NM = [(String, String)]
+-- nameMap :: NM
+-- nameMap =
+--  [ ("AG", "Ares")
+--  , ("A~", "Ares")
+--  , ("AR", "Arctic")
+--  , ("AV", "Avicora")
+--  , ("AX", "BitPump")
+--  , ("AZ", "Azureus")
+--  , ("BB", "BitBuddy")
+--  , ("BC", "BitComet")
+--  , ("BF", "Bitflu")
+--  , ("BG", "BTG")
+--  , ("BR", "BitRocket")
+--  , ("BS", "BTSlave")
+--  , ("BX", "BittorrentX")
+--  , ("CD", "EnhancedCTorrent")
+--  , ("CT", "CTorrent")
+--  , ("DE", "DelugeTorrent")
+--  , ("DP", "PropagateDataClient")
+--  , ("EB", "EBit")
+--  , ("ES", "ElectricSheep")
+--  , ("FT", "FoxTorrent")
+--  , ("GS", "GSTorrent")
+--  , ("HL", "Halite")
+--  , ("HS", "libHSnetwork_bittorrent")
+--  , ("HN", "Hydranode")
+--  , ("KG", "KGet")
+--  , ("KT", "KTorrent")
+--  , ("LH", "LH_ABC")
+--  , ("LP", "Lphant")
+--  , ("LT", "Libtorrent")
+--  , ("lt", "LibTorrent")
+--  , ("LW", "LimeWire")
+--  , ("MO", "MonoTorrent")
+--  , ("MP", "MooPolice")
+--  , ("MR", "Miro")
+--  , ("MT", "MoonlightTorrent")
+--  , ("NX", "NetTransport")
+--  , ("PD", "Pando")
+--  , ("qB", "qBittorrent")
+--  , ("QD", "QQDownload")
+--  , ("QT", "Qt4TorrentExample")
+--  , ("RT", "Retriever")
+--  , ("S~", "Shareaza")
+--  , ("SB", "Swiftbit")
+--  , ("SS", "SwarmScope")
+--  , ("ST", "SymTorrent")
+--  , ("st", "sharktorrent")
+--  , ("SZ", "Shareaza")
+--  , ("TN", "TorrentDotNET")
+--  , ("TR", "Transmission")
+--  , ("TS", "Torrentstorm")
+--  , ("TT", "TuoTu")
+--  , ("UL", "uLeecher")
+--  , ("UT", "uTorrent")
+--  , ("VG", "Vagaa")
+--  , ("WT", "BitLet")
+--  , ("WY", "FireTorrent")
+--  , ("XL", "Xunlei")
+--  , ("XT", "XanTorrent")
+--  , ("XX", "Xtorrent")
+--  , ("ZT", "ZipTorrent")
+--  ]
+
+-- TODO use regexps
+
+-- | Tries to extract meaningful information from peer ID bytes. If
+-- peer id uses unknown coding style then client info returned is
+-- 'def'.
+--
+fingerprint :: PeerId -> Fingerprint
+fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
+  where
+    getCI    = do
+      leading <- BS.w2c <$> getWord8
+      case leading of
+        '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion
+        'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion
+        'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
+        'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
+        c   -> do
+          c1 <- BS.w2c <$> S.lookAhead getWord8
+          if c1 == 'P'
+            then do
+                 _ <- getWord8
+                 Fingerprint <$> pure IOpera            <*> getOperaVersion
+            else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion
+
+    getMainlineVersion = do
+      str <- BC.unpack <$> getByteString 7
+      let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str
+      return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) []
+
+    getAzureusImpl    = parseSoftware <$> getByteString 2
+    getAzureusVersion = mkVer         <$> getByteString 4
+      where
+        mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []
+
+    getBitCometImpl = do
+      bs <- getByteString 3
+      S.lookAhead $ do
+        _  <- getByteString 2
+        lr <- getByteString 4
+        return $
+          if lr == "LORD" then IBitLord  else
+          if bs == "UTB"  then IBitComet else
+          if bs == "xbc"  then IBitComet else def
+
+    getBitCometVersion = do
+      x <- getWord8
+      y <- getWord8
+      return $ Version [fromIntegral x, fromIntegral y] []
+
+    getOperaVersion = do
+      str <- BC.unpack <$> getByteString 4
+      return $ Version [fromMaybe 0 $ readMaybe str] []
+
+    getShadowImpl 'A' = IABC
+    getShadowImpl 'O' = IOspreyPermaseed
+    getShadowImpl 'Q' = IBTQueue
+    getShadowImpl 'R' = ITribler
+    getShadowImpl 'S' = IShadow
+    getShadowImpl 'T' = IBitTornado
+    getShadowImpl  _  = IUnknown
+
+    decodeShadowVerNr :: Char -> Maybe Int
+    decodeShadowVerNr c
+      | '0' < c && c <= '9' = Just  (fromEnum c - fromEnum '0')
+      | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10)
+      | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36)
+      |        otherwise    = Nothing
+
+    getShadowVersion = do
+      str <- BC.unpack <$> getByteString 5
+      return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
+
+
+
+-- | Given a string specifying a port (numeric or service name)
+-- and a flag indicating whether you want to support IPv6, this
+-- function will return a SockAddr to bind to.  If the input
+-- is not understood as a port number, zero will be set in order
+-- to ask the system for an unused port.
+getBindAddress :: String -> Bool -> IO SockAddr
+getBindAddress bindspec enabled6 = do
+    let (host,listenPortString) = case L.break (==':') (L.reverse bindspec) of
+            (rport,':':rhost) -> (Just $ L.reverse rhost, L.reverse rport)
+            _                 -> (Nothing, bindspec)
+    -- Bind addresses for localhost
+    xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] }))
+                      host
+                      (Just listenPortString)
+            `onException` return []
+    -- We prefer IPv6 because that can also handle connections from IPv4
+    -- clients...
+    let (x6s,x4s) = partition (\s -> addrFamily s == AF_INET6) xs
+        listenAddr =
+          case if enabled6 then x6s++x4s else x4s of
+            AddrInfo { addrAddress = addr } : _ -> addr
+            _ -> if enabled6
+                  then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0
+                  else SockAddrInet (parsePort listenPortString) iNADDR_ANY
+                    where parsePort s = fromMaybe 0 $ readMaybe s
+    hPutStrLn stderr $ BS8.pack $ "Listening on " ++ show listenAddr
+    return listenAddr
+
+-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
+-- as defined in RFC 4291.
+is4mapped :: IPv6 -> Bool
+is4mapped ip
+    | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
+                = True
+    | otherwise = False
+
+un4map :: IPv6 -> Maybe IPv4
+un4map ip
+    | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
+                = Just $ toIPv4
+                       $ L.map (.&. 0xFF)
+                               [x `shiftR` 8, x, y `shiftR` 8, y ]
+    | otherwise = Nothing
+
+ipFamily :: IP -> WantIP
+ipFamily ip = case ip of
+    IPv4 _               -> Want_IP4
+    IPv6 a | is4mapped a -> Want_IP4
+           | otherwise   -> Want_IP6
+
+either4or6 :: SockAddr -> Either SockAddr SockAddr
+either4or6 a4@(SockAddrInet port addr)         = Left a4
+either4or6 a6@(SockAddrInet6 port _ addr _)
+    | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
+    | otherwise                                = Right a6
+
+data WantIP = Want_IP4 | Want_IP6 | Want_Both
+ deriving (Eq, Enum, Ord, Show)
+
diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs
new file mode 100644
index 00000000..c8187772
--- /dev/null
+++ b/src/Network/BitTorrent/DHT/ContactInfo.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE BangPatterns #-}
+module Network.BitTorrent.DHT.ContactInfo
+       ( PeerStore
+       , PeerAddr(..)
+       , Network.BitTorrent.DHT.ContactInfo.lookup
+       , Network.BitTorrent.DHT.ContactInfo.freshPeers
+       , Network.BitTorrent.DHT.ContactInfo.insertPeer
+       , knownSwarms
+       ) where
+
+import Control.Applicative
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Data.HashMap.Strict as HM
+import Data.Serialize
+import Data.Wrapper.PSQ as PSQ
+import Data.Time.Clock.POSIX
+import Data.ByteString (ByteString)
+import Data.Word
+import Network.Socket (SockAddr(..))
+
+import Data.Torrent
+import Network.Address
+
+-- {-
+-- import Data.HashMap.Strict as HM
+--
+-- import Data.Torrent.InfoHash
+-- import Network.Address
+--
+-- -- increase prefix when table is too large
+-- -- decrease prefix when table is too small
+-- -- filter outdated peers
+--
+-- {-----------------------------------------------------------------------
+-- --  PeerSet
+-- -----------------------------------------------------------------------}
+--
+-- type PeerSet a = [(PeerAddr, NodeInfo a, Timestamp)]
+--
+-- -- compare PSQueue vs Ordered list
+--
+-- takeNewest :: PeerSet a -> [PeerAddr]
+-- takeNewest = undefined
+--
+-- dropOld :: Timestamp -> PeerSet a -> PeerSet a
+-- dropOld = undefined
+--
+-- insert :: PeerAddr -> Timestamp -> PeerSet a -> PeerSet a
+-- insert = undefined
+--
+-- type Mask = Int
+-- type Size = Int
+-- type Timestamp = Int
+--
+-- {-----------------------------------------------------------------------
+-- --  InfoHashMap
+-- -----------------------------------------------------------------------}
+--
+-- -- compare handwritten prefix tree versus IntMap
+--
+-- data Tree a
+--   = Nil
+--   | Tip !InfoHash !(PeerSet a)
+--   | Bin !InfoHash !Mask !Size !Timestamp (Tree a) (Tree a)
+--
+-- insertTree :: InfoHash -> a -> Tree a -> Tree a
+-- insertTree = undefined
+--
+-- type Prio = Int
+--
+-- --shrink :: ContactInfo ip -> Int
+-- shrink  Nil      = Nil
+-- shrink (Tip _ _) = undefined
+-- shrink (Bin _ _) = undefined
+--
+-- {-----------------------------------------------------------------------
+-- -- InfoHashMap
+-- -----------------------------------------------------------------------}
+--
+-- -- compare new design versus HashMap
+--
+-- data IntMap k p a
+-- type ContactInfo = Map InfoHash Timestamp (Set (PeerAddr IP) Timestamp)
+--
+-- data ContactInfo ip = PeerStore
+--   { maxSize    :: Int
+--   , prefixSize :: Int
+--   , thisNodeId :: NodeId
+--
+--   , count      :: Int  -- ^ Cached size of the 'peerSet'
+--   , peerSet    :: HashMap InfoHash [PeerAddr ip]
+--   }
+--
+-- size :: ContactInfo ip -> Int
+-- size = undefined
+--
+-- prefixSize :: ContactInfo ip -> Int
+-- prefixSize = undefined
+--
+-- lookup :: InfoHash -> ContactInfo ip -> [PeerAddr ip]
+-- lookup = undefined
+--
+-- insert :: InfoHash -> PeerAddr ip -> ContactInfo ip -> ContactInfo ip
+-- insert = undefined
+--
+-- -- | Limit in size.
+-- prune :: NodeId -> Int -> ContactInfo ip -> ContactInfo ip
+-- prune pref targetSize  Nil      = Nil
+-- prune pref targetSize (Tip _ _) = undefined
+--
+-- -- | Remove expired entries.
+-- splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip
+-- splitGT = undefined
+-- -}
+
+-- | Storage used to keep track a set of known peers in client,
+-- tracker or DHT sessions.
+newtype PeerStore = PeerStore (HashMap InfoHash SwarmData)
+
+type Timestamp = POSIXTime
+
+data SwarmData = SwarmData
+    { peers :: !(PSQ PeerAddr Timestamp)
+    , name :: !(Maybe ByteString)
+    }
+
+-- | This wrapper will serialize an ip address with a '4' or '6' prefix byte
+-- to indicate whether it is IPv4 or IPv6.
+--
+-- Note: it does not serialize port numbers.
+newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a }
+
+instance Address a => Serialize (SerializeAddress a) where
+    get = SerializeAddress <$> do
+        c <- get
+        case (c::Word8) of
+            0x34 -> do ip4 <- get
+                       return $ fromJust $ fromAddr (ip4::IPv4)
+            0x36 -> do ip6 <- get
+                       return $ fromJust $ fromAddr (ip6::IPv6)
+            _ -> return $ error "cannot deserialize non-IP SerializeAddress"
+    put (SerializeAddress a)
+        | Just ip4 <- fromAddr a
+                    = put (0x34::Word8) >> put (ip4::IPv4)
+        | Just ip6 <- fromAddr a
+                    = put (0x36::Word8) >> put (ip6::IPv6)
+        | otherwise = return $ error "cannot serialize non-IP SerializeAddress"
+
+
+instance Serialize SwarmData where
+    get = flip SwarmData <$> get
+                         <*> ( PSQ.fromList . L.map parseAddr <$> get )
+     where
+        parseAddr (pid,addr,port) = PeerAddr { peerId = pid
+                                             , peerHost = unserializeAddress addr
+                                             , peerPort = port
+                                             }
+                                      :-> 0
+
+    put SwarmData{..} = do
+        put name
+        put $ L.map (\(addr :-> _) -> (peerId addr, SerializeAddress addr, peerPort addr))
+                -- XXX: should we serialize the timestamp?
+            $ PSQ.toList peers
+
+knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ]
+knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m
+
+swarmSingleton :: PeerAddr -> SwarmData
+swarmSingleton a = SwarmData
+    { peers = PSQ.singleton a 0
+    , name = Nothing }
+
+swarmInsert :: SwarmData -> SwarmData -> SwarmData
+swarmInsert new old = SwarmData
+    { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith newerTimeStamp a t q) (peers old) (PSQ.toList $ peers new)
+    , name = name new <|> name old -- TODO: decodeUtf8' check
+    }
+ where
+    newerTimeStamp newtime oldtime = if newtime > oldtime then newtime else oldtime
+
+isSwarmOccupied :: SwarmData -> Bool
+isSwarmOccupied SwarmData{..} = not $ PSQ.null peers
+
+-- | Empty store.
+instance Default (PeerStore) where
+  def = PeerStore HM.empty
+  {-# INLINE def #-}
+
+-- | Monoid under union operation.
+instance Monoid PeerStore where
+  mempty  = def
+  {-# INLINE mempty #-}
+
+  mappend (PeerStore a) (PeerStore b) =
+    PeerStore (HM.unionWith swarmInsert a b)
+  {-# INLINE mappend #-}
+
+-- | Can be used to store peers between invocations of the client
+-- software.
+instance Serialize PeerStore where
+  get = PeerStore . HM.fromList <$> get
+  put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m)
+
+-- | Returns all peers associated with a given info hash.
+lookup :: InfoHash -> PeerStore -> [PeerAddr]
+lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m
+
+batchSize :: Int
+batchSize = 64
+
+-- | Used in 'get_peers' DHT queries.
+freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore)
+freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do
+    swarm <- HM.lookup ih m
+    let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm)
+        peers' = case reverse ps0 of
+                    (_,psq):_ -> psq
+                    _         -> peers swarm
+        ps = L.map (key . fst) ps0
+        m' = HM.insert ih swarm { peers = L.foldl' (\q p -> PSQ.insert p tm q) peers' ps } m
+    return $! m' `seq` (ps,PeerStore m')
+
+incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x)
+incomp !f !x = do
+   (result,x') <- f x
+   pure $! ( (result,x'), x' )
+
+-- | Used in 'announce_peer' DHT queries.
+insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore
+insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m)
+ where
+    a' = SwarmData { peers = PSQ.singleton a 0
+                   , name = name }
diff --git a/src/Network/BitTorrent/DHT/Readme.md b/src/Network/BitTorrent/DHT/Readme.md
new file mode 100644
index 00000000..e2352f10
--- /dev/null
+++ b/src/Network/BitTorrent/DHT/Readme.md
@@ -0,0 +1,13 @@
+References
+==========
+
+Some good references excluding BEPs:
+
+* [Kademlia wiki page][kademlia-wiki]
+* [Kademlia: A Peer-to-peer Information System Based on the XOR Metric][kademlia-paper]
+* [BitTorrent Mainline DHT Measurement][mldht]
+* Profiling a Million User DHT. (paper)
+
+[kademlia-wiki]: http://en.wikipedia.org/wiki/Kademlia
+[kademlia-paper]: http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf
+[mldht]: http://www.cs.helsinki.fi/u/jakangas/MLDHT/
diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs
new file mode 100644
index 00000000..3da59c53
--- /dev/null
+++ b/src/Network/BitTorrent/DHT/Token.hs
@@ -0,0 +1,202 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+-- The return value for a query for peers includes an opaque value
+-- known as the 'Token'. For a node to announce that its controlling
+-- peer is downloading a torrent, it must present the token received
+-- from the same queried node in a recent query for peers. When a node
+-- attempts to \"announce\" a torrent, the queried node checks the
+-- token against the querying node's 'IP' address. This is to prevent
+-- malicious hosts from signing up other hosts for torrents. Since the
+-- token is merely returned by the querying node to the same node it
+-- received the token from, the implementation is not defined. Tokens
+-- must be accepted for a reasonable amount of time after they have
+-- been distributed.
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}
+module Network.BitTorrent.DHT.Token
+       ( -- * Token
+         Token
+       , maxInterval
+       , toPaddedByteString
+       , fromPaddedByteString
+
+         -- * Session tokens
+       , TokenMap
+       , SessionTokens
+       , nullSessionTokens
+       , checkToken
+       , grantToken
+
+         -- ** Construction
+       , Network.BitTorrent.DHT.Token.tokens
+
+         -- ** Query
+       , Network.BitTorrent.DHT.Token.lookup
+       , Network.BitTorrent.DHT.Token.member
+
+         -- ** Modification
+       , Network.BitTorrent.DHT.Token.defaultUpdateInterval
+       , Network.BitTorrent.DHT.Token.update
+       ) where
+
+import Control.Arrow
+import Control.Monad.State
+#ifdef VERSION_bencoding
+import Data.BEncode (BEncode)
+#endif
+import Data.ByteString as BS
+import Data.ByteString.Char8 as B8
+import Data.ByteString.Lazy as BL
+import Data.ByteString.Lazy.Builder as BS
+import qualified Data.ByteString.Base16 as Base16
+import Data.Default
+import Data.List as L
+import Data.Hashable
+import Data.String
+import Data.Time
+import System.Random
+import Control.Concurrent.STM
+import Network.Address
+
+-- TODO use ShortByteString
+
+-- | An opaque value.
+newtype Token = Token BS.ByteString
+  deriving ( Eq, IsString
+#ifdef VERSION_bencoding
+           , BEncode
+#endif
+           )
+
+instance Show Token where
+    show (Token bs) = B8.unpack $ Base16.encode bs
+
+instance Read Token where
+    readsPrec i s = pure $ (Token *** B8.unpack) $ Base16.decode (B8.pack s)
+
+-- | Meaningless token, for testing purposes only.
+instance Default Token where
+  def = makeToken (0::Int) 0
+
+-- | Prepend token with 0x20 bytes to fill the available width.
+--
+-- If n > 8, then this will also guarantee a nonzero token, which is useful for
+-- Tox ping-id values for announce responses.
+toPaddedByteString :: Int -> Token -> BS.ByteString
+toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs
+
+fromPaddedByteString :: Int -> BS.ByteString -> Token
+fromPaddedByteString n bs = Token $ BS.drop (n - len) bs
+ where
+    len = BS.length tok where Token tok = def
+
+-- | The secret value used as salt.
+type Secret = Int
+
+-- The BitTorrent implementation uses the SHA1 hash of the IP address
+-- concatenated onto a secret, we use hashable instead.
+makeToken :: Hashable a => a -> Secret -> Token
+makeToken n s = Token $ toBS $ hashWithSalt s n
+  where
+    toBS = toStrict . toLazyByteString . int64BE . fromIntegral
+{-# INLINE makeToken #-}
+
+-- | Constant space 'Node' to 'Token' map based on the secret value.
+data TokenMap = TokenMap
+  { prevSecret :: {-# UNPACK #-} !Secret
+  , curSecret  :: {-# UNPACK #-} !Secret
+  , generator  :: {-# UNPACK #-} !StdGen
+  } deriving Show
+
+-- | A new token map based on the specified seed value. Returned token
+-- map should be periodicatically 'update'd.
+--
+-- Normally, the seed value should vary between invocations of the
+-- client software.
+tokens :: Int -> TokenMap
+tokens seed = (`evalState` mkStdGen seed) $
+  TokenMap <$> state next
+           <*> state next
+           <*> get
+
+-- | Get token for the given node. A token becomes invalid after 2
+-- 'update's.
+--
+-- Typically used to handle find_peers query.
+lookup :: Hashable a => a -> TokenMap -> Token
+lookup addr TokenMap {..} = makeToken addr curSecret
+
+-- | Check if token is valid.
+--
+-- Typically used to handle 'Network.DHT.Mainline.Announce'
+-- query. If token is invalid the 'Network.KRPC.ProtocolError' should
+-- be sent back to the malicious node.
+member :: Hashable a => a -> Token -> TokenMap -> Bool
+member addr token TokenMap {..} = token `L.elem` valid
+  where valid = makeToken addr <$> [curSecret, prevSecret]
+
+-- | Secret changes every five minutes and tokens up to ten minutes old
+-- are accepted.
+defaultUpdateInterval :: NominalDiffTime
+defaultUpdateInterval = 5 * 60
+
+-- | Update current tokens.
+update :: TokenMap -> TokenMap
+update TokenMap {..} = TokenMap
+    { prevSecret = curSecret
+    , curSecret  = newSecret
+    , generator  = newGen
+    }
+  where
+    (newSecret, newGen) = next generator
+
+data SessionTokens = SessionTokens
+  { tokenMap    :: !TokenMap
+  , lastUpdate  :: !UTCTime
+  , maxInterval :: !NominalDiffTime
+  }
+
+nullSessionTokens :: IO SessionTokens
+nullSessionTokens = SessionTokens
+  <$> (tokens <$> randomIO)
+  <*> getCurrentTime
+  <*> pure defaultUpdateInterval
+
+-- TODO invalidate *twice* if needed
+invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens
+invalidateTokens curTime ts @ SessionTokens {..}
+  | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens
+    { tokenMap    = update tokenMap
+    , lastUpdate  = curTime
+    , maxInterval = maxInterval
+    }
+  |                  otherwise                     = ts
+
+{-----------------------------------------------------------------------
+-- Tokens
+-----------------------------------------------------------------------}
+
+tryUpdateSecret :: TVar SessionTokens -> IO ()
+tryUpdateSecret toks = do
+  curTime <- getCurrentTime
+  atomically $ modifyTVar' toks (invalidateTokens curTime)
+
+grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token
+grantToken sessionTokens addr = do
+  tryUpdateSecret sessionTokens
+  toks <- readTVarIO sessionTokens
+  return $ Network.BitTorrent.DHT.Token.lookup addr $ tokenMap toks
+
+-- | Throws 'HandlerError' if the token is invalid or already
+-- expired. See 'TokenMap' for details.
+checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool
+checkToken sessionTokens addr questionableToken = do
+  tryUpdateSecret sessionTokens
+  toks <- readTVarIO sessionTokens
+  return $ member addr questionableToken (tokenMap toks)
+
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
new file mode 100644
index 00000000..f43b070c
--- /dev/null
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -0,0 +1,1111 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+module Network.BitTorrent.MainlineDHT where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.Random
+import Data.BEncode                           as BE
+import qualified Data.BEncode.BDict           as BE
+         ;import Data.BEncode.BDict           (BKey)
+import Data.BEncode.Pretty
+import Data.BEncode.Types                     (BDict)
+import Data.Bits
+import Data.Bits.ByteString
+import Data.Bool
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               (ByteArrayAccess)
+import qualified Data.ByteString              as B
+         ;import Data.ByteString              (ByteString)
+import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Char8        as C8
+import Data.ByteString.Lazy                   (toStrict)
+import qualified Data.ByteString.Lazy.Char8   as L8
+import Data.Char
+import Data.Coerce
+import Data.Data
+import Data.Default
+import Data.Digest.CRC32C
+import Data.Function                          (fix)
+import Data.Hashable
+import Data.IP
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import qualified Data.Serialize               as S
+import Data.Set                               (Set)
+import Data.Time.Clock.POSIX                  (POSIXTime)
+import Data.Torrent
+import Data.Typeable
+import Data.Word
+import qualified Data.Wrapper.PSQInt          as Int
+import Debug.Trace
+import Network.BitTorrent.MainlineDHT.Symbols
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Address                        (Address, fromAddr, fromSockAddr,
+                                               setPort, sockAddrPort, testIdBit,
+                                               toSockAddr, genBucketSample', WantIP(..),
+                                               un4map,either4or6,ipFamily)
+import Network.BitTorrent.DHT.ContactInfo     as Peers
+import Network.Kademlia.Search          (Search (..))
+import Network.BitTorrent.DHT.Token           as Token
+import qualified Network.Kademlia.Routing          as R
+         ;import Network.Kademlia.Routing          (Timestamp, getTimestamp)
+import Network.QueryResponse
+import Network.Socket
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe                       (unsafeInterleaveIO)
+import qualified Text.ParserCombinators.ReadP as RP
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Exception    (SomeException (..), handle)
+import qualified Data.Aeson as JSON
+         ;import Data.Aeson (FromJSON, ToJSON, (.=))
+import Text.Read
+import System.Global6
+import Control.TriadCommittee
+
+newtype NodeId = NodeId ByteString
+ deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
+
+instance BEncode NodeId where
+    fromBEncode bval = do
+        bs <- fromBEncode bval
+        if B.length bs /= 20
+            then Left "Invalid length node id."
+            else Right $ NodeId bs
+
+    toBEncode (NodeId bs) = toBEncode bs
+
+instance Show NodeId where
+    show (NodeId bs) = C8.unpack $ Base16.encode bs
+
+instance S.Serialize NodeId where
+    get = NodeId <$> S.getBytes 20
+    put (NodeId bs) = S.putByteString bs
+
+instance FiniteBits NodeId where
+    finiteBitSize _ = 160
+
+instance Read NodeId where
+    readsPrec _ str
+        | (bs, xs) <- Base16.decode $ C8.pack str
+        , B.length bs == 20
+                    = [ (NodeId bs, drop 40 str) ]
+        | otherwise = []
+
+zeroID :: NodeId
+zeroID = NodeId $ B.replicate 20 0
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP   :: IP
+  , nodePort :: PortNumber
+  }
+ deriving (Eq,Ord)
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo nid (IPv4 ip) port)
+        = JSON.object [ "node-id" .= show nid
+                      , "ipv4" .= show ip
+                      , "port" .= (fromIntegral port :: Int)
+                      ]
+    toJSON (NodeInfo nid (IPv6 ip6) port)
+        | Just ip <- un4map ip6
+          = JSON.object [ "node-id" .= show nid
+                        , "ipv4" .= show ip
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+        | otherwise
+          = JSON.object [ "node-id" .= show nid
+                        , "ipv6" .= show ip6
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+instance FromJSON NodeInfo where
+    parseJSON (JSON.Object v) = do
+        nidstr <- v JSON..: "node-id"
+        ip6str <- v JSON..:? "ipv6"
+        ip4str <- v JSON..:? "ipv4"
+        portnum <- v JSON..: "port"
+        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
+              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        let (bs,_) = Base16.decode (C8.pack nidstr)
+        guard (B.length bs == 20)
+        return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 40 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (not . isSpace)
+        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- case Base16.decode $ C8.pack hexhash of
+                              (bs,_) | B.length bs==20 -> return (NodeId bs)
+                              _                        -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    let raddr = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+    (ip,port) <- case RP.readP_to_S raddr addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+
+
+-- The Hashable instance depends only on the IP address and port number.  It is
+-- used to compute the announce token.
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
+
+{-
+
+-- | KRPC 'compact list' compatible encoding: contact information for
+-- nodes is encoded as a 26-byte string. Also known as "Compact node
+-- info" the 20-byte Node ID in network byte order has the compact
+-- IP-address/port info concatenated to the end.
+  get = NodeInfo <$> (NodeId <$> S.getBytes 20 ) <*> S.get <*> S.get
+-}
+
+getNodeInfo4 :: S.Get NodeInfo
+getNodeInfo4 = NodeInfo <$> (NodeId <$> S.getBytes 20)
+                        <*> (IPv4 <$> S.get)
+                        <*> S.get
+
+putNodeInfo4 :: NodeInfo -> S.Put
+putNodeInfo4 (NodeInfo (NodeId nid) ip port)
+    | IPv4 ip4 <- ip                          = put4 ip4
+    | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = put4 ip4
+    | otherwise                               = return ()
+ where
+    put4 ip4 = S.putByteString nid >> S.put ip4 >> S.put port
+
+getNodeInfo6 :: S.Get NodeInfo
+getNodeInfo6 = NodeInfo <$> (NodeId <$> S.getBytes 20)
+                        <*> (IPv6 <$> S.get)
+                        <*> S.get
+
+putNodeInfo6 :: NodeInfo -> S.Put
+putNodeInfo6 (NodeInfo (NodeId nid) (IPv6 ip) port)
+               = S.putByteString nid >> S.put ip >> S.put port
+putNodeInfo6 _ = return ()
+
+
+-- | TODO: This should depend on the bind address to support IPv4-only. For
+-- now, in order to support dual-stack listen, we're going to assume IPv6 is
+-- wanted and map IPv4 addresses accordingly.
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr (NodeInfo _ ip port) =
+    case ip of
+        IPv4 ip4 -> setPort port $ toSockAddr (ipv4ToIPv6 ip4)
+        IPv6 ip6 -> setPort port $ toSockAddr ip6
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+-- | Types of RPC errors.
+data ErrorCode
+    -- | Some error doesn't fit in any other category.
+  = GenericError
+
+    -- | Occurs when server fail to process procedure call.
+  | ServerError
+
+    -- | Malformed packet, invalid arguments or bad token.
+  | ProtocolError
+
+    -- | Occurs when client trying to call method server don't know.
+  | MethodUnknown
+    deriving (Show, Read, Eq, Ord, Bounded, Typeable, Data)
+
+-- | According to the table:
+-- <http://bittorrent.org/beps/bep_0005.html#errors>
+instance Enum ErrorCode where
+  fromEnum GenericError  = 201
+  fromEnum ServerError   = 202
+  fromEnum ProtocolError = 203
+  fromEnum MethodUnknown = 204
+  {-# INLINE fromEnum #-}
+  toEnum 201 = GenericError
+  toEnum 202 = ServerError
+  toEnum 203 = ProtocolError
+  toEnum 204 = MethodUnknown
+  toEnum _   = GenericError
+  {-# INLINE toEnum #-}
+
+instance BEncode ErrorCode where
+  toBEncode = toBEncode . fromEnum
+  {-# INLINE toBEncode #-}
+  fromBEncode b = toEnum <$> fromBEncode b
+  {-# INLINE fromBEncode #-}
+
+data Error = Error
+    { errorCode    :: !ErrorCode  -- ^ The type of error.
+    , errorMessage :: !ByteString -- ^ Human-readable text message.
+    } deriving ( Show, Eq, Ord, Typeable, Data, Read )
+
+newtype TransactionId = TransactionId ByteString
+ deriving (Eq, Ord, Show, BEncode)
+
+newtype Method = Method ByteString
+ deriving (Eq, Ord, Show, BEncode)
+
+data Message a = Q { msgOrigin   :: NodeId
+                   , msgID       :: TransactionId
+                   , qryPayload  :: a
+                   , qryMethod   :: Method
+                   , qryReadOnly :: Bool }
+
+               | R { msgOrigin      :: NodeId
+                   , msgID          :: TransactionId
+                   , rspPayload     :: Either Error a
+                   , rspReflectedIP :: Maybe SockAddr }
+
+showBE :: BValue -> String
+showBE bval = L8.unpack (showBEncode bval)
+
+instance BE.BEncode (Message BValue) where
+    toBEncode m = encodeMessage m
+                  {-
+                  in case m of
+                        Q {} -> trace ("encoded(query): "++showBE r) r
+                        R {} -> trace ("encoded(response): "++showBE r) r -}
+    fromBEncode bval = decodeMessage bval
+                       {-
+                       in case r of
+                            Left e -> trace (show e) r
+                            Right (Q {}) -> trace ("decoded(query): "++showBE bval) r
+                            Right (R {}) -> trace ("decoded(response): "++showBE bval) r -}
+
+decodeMessage :: BValue -> Either String (Message BValue)
+decodeMessage = fromDict $ do
+    key <- lookAhead (field (req "y"))
+    let _ = key :: BKey
+    f <- case key of
+        "q" -> do a <- field (req "a")
+                  g <- either fail return $ flip fromDict a $ do
+                    who <- field (req "id")
+                    ro  <- fromMaybe False <$> optional (field (req "ro"))
+                    return $ \meth tid -> Q who tid a meth ro
+                  meth <- field (req "q")
+                  return $ g meth
+        "r" -> do ip <- do
+                        ipstr <- optional (field (req "ip"))
+                        mapM (either fail return . decodeAddr) ipstr
+                  vals <- field (req "r")
+                  either fail return $ flip fromDict vals $ do
+                    who <- field (req "id")
+                    return $ \tid -> R who tid (Right vals) ip
+        "e" -> do (ecode,emsg) <- field (req "e")
+                  ip <- do
+                        ipstr <- optional (field (req "ip"))
+                        mapM (either fail return . decodeAddr) ipstr
+                  -- FIXME:Spec does not give us the NodeId of the sender.
+                  --       Using 'zeroID' as place holder.
+                  --       We should ignore the msgOrigin for errors in 'updateRouting'.
+                  --       We should consider making msgOrigin a Maybe value.
+                  return $ \tid -> R zeroID tid (Left (Error ecode emsg)) ip
+        _   -> fail $ "Mainline message is not a query, response, or an error: "
+                        ++ show key
+    tid <- field (req "t")
+    return $ f (tid :: TransactionId)
+
+
+encodeMessage :: Message BValue -> BValue
+encodeMessage (Q origin tid a meth ro)
+    = case a of
+        BDict args -> encodeQuery tid meth (BDict $ genericArgs origin ro `BE.union` args)
+        _          -> encodeQuery tid meth a -- XXX: Not really a valid query.
+encodeMessage (R origin tid v ip)
+    = case v of
+        Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip
+        Left  err          -> encodeError tid err
+
+
+encodeAddr :: SockAddr -> ByteString
+encodeAddr = either encode4 encode6 . either4or6
+ where
+    encode4 (SockAddrInet port addr)
+              = S.runPut (S.putWord32host addr >> S.putWord16be (fromIntegral port))
+
+    encode6 (SockAddrInet6 port _ addr _)
+              = S.runPut (S.put addr >> S.putWord16be (fromIntegral port))
+    encode6 _ = B.empty
+
+decodeAddr :: ByteString -> Either String SockAddr
+decodeAddr bs = S.runGet g bs
+ where
+    g | (B.length bs == 6) = flip SockAddrInet <$> S.getWord32host <*> (fromIntegral <$> S.getWord16be)
+      | otherwise          = do host <- S.get -- TODO: Is this right?
+                                port <- fromIntegral <$> S.getWord16be
+                                return $ SockAddrInet6 port 0 host 0
+
+genericArgs :: BEncode a => a -> Bool -> BDict
+genericArgs nodeid ro =
+       "id" .=! nodeid
+    .: "ro" .=? bool Nothing (Just (1 :: Int)) ro
+    .: endDict
+
+encodeError :: BEncode a => a -> Error -> BValue
+encodeError tid (Error ecode emsg) = encodeAny tid "e" (ecode,emsg) id
+
+encodeResponse :: (BEncode tid, BEncode vals) =>
+                  tid -> vals -> Maybe SockAddr -> BValue
+encodeResponse tid rvals rip =
+    encodeAny tid "r" rvals ("ip" .=? (BString . encodeAddr <$> rip) .:)
+
+encodeQuery :: (BEncode args, BEncode tid, BEncode method) =>
+               tid -> method -> args -> BValue
+encodeQuery tid qmeth qargs = encodeAny tid "q" qmeth ("a" .=! qargs .:)
+
+encodeAny ::
+    (BEncode tid, BEncode a) =>
+    tid -> BKey -> a -> (BDict -> BDict) -> BValue
+encodeAny tid key val aux = toDict $
+    aux $  key .=! val
+        .: "t" .=! tid
+        .: "y" .=! key
+        .: endDict
+
+
+showPacket :: ([L8.ByteString] -> [L8.ByteString]) -> SockAddr -> L8.ByteString -> ByteString -> String
+showPacket f addr flow bs = L8.unpack $ L8.unlines es
+ where
+    es = map (L8.append prefix) (f $ L8.lines pp)
+
+    prefix = L8.pack (either show show $ either4or6 addr) <> flow
+
+    pp = either L8.pack showBEncode $ BE.decode bs
+
+-- Add detailed printouts for every packet.
+addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
+addVerbosity tr =
+    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
+            forM_ m $ mapM_ $ \(msg,addr) -> do
+                hPutStrLn stderr (showPacket id addr " --> " msg)
+            kont m
+       , sendMessage = \addr msg -> do
+            hPutStrLn stderr (showPacket id addr " <-- " msg)
+            sendMessage tr addr msg
+       }
+
+
+showParseError :: ByteString -> SockAddr -> String -> String
+showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs
+
+parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo)
+parsePacket bs addr = left (showParseError bs addr) $ do
+    pkt <- BE.decode bs
+    -- TODO: Error packets do not include a valid msgOrigin.
+    --       The BE.decode method is using 'zeroID' as a placeholder.
+    ni <- nodeInfo (msgOrigin pkt) addr
+    return (pkt, ni)
+
+encodePacket :: Message BValue -> NodeInfo -> (ByteString, SockAddr)
+encodePacket msg ni = ( toStrict $ BE.encode msg
+                      , nodeAddr ni )
+
+classify :: Message BValue -> MessageClass String Method TransactionId NodeInfo (Message BValue)
+classify (Q { msgID = tid, qryMethod = meth }) = IsQuery meth tid
+classify (R { msgID = tid                   }) = IsResponse tid
+
+encodeResponsePayload :: BEncode a => TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue
+encodeResponsePayload tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest)
+
+encodeQueryPayload :: BEncode a =>
+    Method -> Bool -> TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue
+encodeQueryPayload meth isReadonly tid self dest b = Q (nodeId self) tid (BE.toBEncode b) meth isReadonly
+
+errorPayload :: TransactionId -> NodeInfo -> NodeInfo -> Error -> Message a
+errorPayload tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest)
+
+decodePayload :: BEncode a => Message BValue -> Either String a
+decodePayload msg = BE.fromBEncode $ qryPayload msg
+
+type Handler = MethodHandler String TransactionId NodeInfo (Message BValue)
+
+handler :: ( BEncode a
+           , BEncode b
+           ) =>
+           (NodeInfo -> a -> IO b) -> Maybe Handler
+handler f = Just $ MethodHandler decodePayload encodeResponsePayload f
+
+
+handlerE :: ( BEncode a
+            , BEncode b
+            ) =>
+            (NodeInfo -> a -> IO (Either Error b)) -> Maybe Handler
+handlerE f = Just $ MethodHandler decodePayload enc f
+ where
+    enc tid self dest (Left e)  = errorPayload  tid self dest e
+    enc tid self dest (Right b) = encodeResponsePayload tid self dest b
+
+type AnnounceSet = Set (InfoHash, PortNumber)
+
+data SwarmsDatabase = SwarmsDatabase
+    { contactInfo   :: !( TVar PeerStore     ) -- ^ Published by other nodes.
+    , sessionTokens :: !( TVar SessionTokens ) -- ^ Query session IDs.
+    , announceInfo  :: !( TVar AnnounceSet   ) -- ^ To publish by this node.
+    }
+
+newSwarmsDatabase :: IO SwarmsDatabase
+newSwarmsDatabase = do
+    toks <- nullSessionTokens
+    atomically
+        $ SwarmsDatabase <$> newTVar def
+                    <*> newTVar toks
+                    <*> newTVar def
+
+data Routing = Routing
+    { tentativeId :: NodeInfo
+    , committee4  :: TriadCommittee NodeId SockAddr
+    , committee6  :: TriadCommittee NodeId SockAddr
+    , refresher4  :: BucketRefresher NodeId NodeInfo
+    , refresher6  :: BucketRefresher NodeId NodeInfo
+    }
+
+sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
+
+sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
+
+routing4 :: Routing -> TVar (R.BucketList NodeInfo)
+routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+routing6 :: Routing -> TVar (R.BucketList NodeInfo)
+routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+traced :: Show tid => TableMethods t tid -> TableMethods t tid
+traced (TableMethods ins del lkup)
+            = TableMethods (\tid mvar t -> trace ("insert "++show tid) $ ins tid mvar t)
+                           (\tid t -> trace ("del "++show tid) $ del tid t)
+                           (\tid t -> trace ("lookup "++show tid) $ lkup tid t)
+
+
+type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue)
+
+-- | Like 'nodeInfo' but falls back to 'iNADDR_ANY' for nodeIP' and 'nodePort'.
+mkNodeInfo :: NodeId -> SockAddr -> NodeInfo
+mkNodeInfo nid addr = NodeInfo
+    { nodeId   = nid
+    , nodeIP   = fromMaybe (toEnum 0) $ fromSockAddr addr
+    , nodePort = fromMaybe 0 $ sockAddrPort addr
+    }
+
+newClient :: SwarmsDatabase -> SockAddr
+    -> IO ( MainlineClient
+          , Routing
+          , [NodeInfo] -> [NodeInfo] -> IO ()
+          , [NodeInfo] -> [NodeInfo] -> IO ()
+          )
+newClient swarms addr = do
+    udp <- udpTransport addr
+    nid <- NodeId <$> getRandomBytes 20
+    let tentative_info = mkNodeInfo nid addr
+    tentative_info6 <-
+        maybe tentative_info
+              (\ip6 -> tentative_info { nodeId = fromMaybe (nodeId tentative_info)
+                                                    $ bep42 (toSockAddr ip6) (nodeId tentative_info)
+                                      , nodeIP = IPv6 ip6
+                                      })
+            <$> global6
+    addr4 <- atomically $ newTChan
+    addr6 <- atomically $ newTChan
+    mkrouting <- atomically $ do
+        -- We defer initializing the refreshSearch and refreshPing until we
+        -- have a client to send queries with.
+        let nullPing = const $ return False
+            nullSearch = mainlineSearch $ \_ _ -> return Nothing
+        refresher4 <- newBucketRefresher tentative_info nullSearch nullPing
+        refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing
+        let tbl4 = refreshBuckets refresher4
+            tbl6 = refreshBuckets refresher6
+            updateIPVote tblvar addrvar a = do
+                bkts <- readTVar tblvar
+                case bep42 a (nodeId $ R.thisNode bkts) of
+                    Just nid -> do
+                        let tbl = R.nullTable (comparing nodeId)
+                                              (\s -> hashWithSalt s . nodeId)
+                                              (mkNodeInfo nid a)
+                                              (R.defaultBucketCount)
+                        writeTVar tblvar tbl
+                        writeTChan addrvar (a,map fst $ concat $ R.toList bkts)
+                    Nothing -> return ()
+        committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4
+        committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
+        return $ \client ->
+            -- Now we have a client, so tell the BucketRefresher how to search and ping.
+            let updIO r = updateRefresherIO (nodeSearch client) (ping client) r
+            in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6)
+    map_var <- atomically $ newTVar (0, mempty)
+
+    let routing = mkrouting outgoingClient
+
+        net = onInbound (updateRouting outgoingClient routing)
+              $ layerTransport parsePacket encodePacket
+              $ udp
+
+        -- Paranoid: It's safe to define /net/ and /client/ to be mutually
+        -- recursive since 'updateRouting' does not invoke 'awaitMessage' which
+        -- which was modified by 'onInbound'.  However, I'm going to avoid the
+        -- mutual reference just to be safe.
+        outgoingClient = client { clientNet = net { awaitMessage = ($ Nothing) } }
+
+        dispatch = DispatchMethods
+            { classifyInbound = classify -- :: x -> MessageClass err meth tid addr x
+            , lookupHandler   = handlers -- :: meth -> Maybe (MethodHandler err tid addr x)
+            , tableMethods    = mapT     -- :: TransactionMethods tbl tid x
+            }
+
+        handlers :: Method -> Maybe Handler
+        handlers ( Method "ping"          ) = handler pingH
+        handlers ( Method "find_node"     ) = handler $ findNodeH routing
+        handlers ( Method "get_peers"     ) = handler $ getPeersH routing swarms
+        handlers ( Method "announce_peer" ) = handlerE $ announceH swarms
+        handlers ( Method meth            ) = Just $ defaultHandler meth
+
+        mapT = transactionMethods mapMethods gen
+
+        gen :: Word16 -> (TransactionId, Word16)
+        gen cnt = (TransactionId $ S.encode cnt, cnt+1)
+
+        ignoreParseError :: String -> IO ()
+        ignoreParseError _ = return ()
+
+        client = Client
+            { clientNet           = addHandler ignoreParseError (handleMessage client) net
+            , clientDispatcher    = dispatch
+            , clientErrorReporter = ignoreErrors -- printErrors stderr
+            , clientPending       = map_var
+            , clientAddress       = \maddr -> atomically $ do
+                let var = case flip prefer4or6 Nothing <$> maddr of
+                            Just Want_IP6 -> routing6 routing
+                            _             -> routing4 routing
+                R.thisNode <$> readTVar var
+            , clientResponseId    = return
+            }
+
+    -- TODO: Provide some means of shutting down these four auxillary threads:
+
+    fork $ fix $ \again -> do
+        myThreadId >>= flip labelThread "addr4"
+        (addr, ns) <- atomically $ readTChan addr4
+        hPutStrLn stderr $ "External IPv4: "++show (addr, length ns)
+        forM_ ns $ \n -> do
+            hPutStrLn stderr $ "Change IP, ping: "++show n
+            ping outgoingClient n
+        -- TODO: trigger bootstrap ipv4
+        again
+    fork $ fix $ \again -> do
+        myThreadId >>= flip labelThread "addr6"
+        (addr,ns) <- atomically $ readTChan addr6
+        hPutStrLn stderr $ "External IPv6: "++show (addr, length ns)
+        forM_ ns $ \n -> do
+            hPutStrLn stderr $ "Change IP, ping: "++show n
+            ping outgoingClient n
+        -- TODO: trigger bootstrap ipv6
+        again
+
+
+    refresh_thread4 <- forkPollForRefresh $ refresher4 routing
+    refresh_thread6 <- forkPollForRefresh $ refresher6 routing
+
+    return (client, routing, bootstrap (refresher4 routing), bootstrap (refresher6 routing))
+
+-- | Modifies a purely random 'NodeId' to one that is related to a given
+-- routable address in accordance with BEP 42.
+--
+-- Test vectors from the spec:
+--
+-- IP           rand  example node ID
+-- ============ ===== ==========================================
+-- 124.31.75.21   1   5fbfbf f10c5d6a4ec8a88e4c6ab4c28b95eee4 01
+-- 21.75.31.124  86   5a3ce9 c14e7a08645677bbd1cfe7d8f956d532 56
+-- 65.23.51.170  22   a5d432 20bc8f112a3d426c84764f8c2a1150e6 16
+-- 84.124.73.14  65   1b0321 dd1bb1fe518101ceef99462b947a01ff 41
+-- 43.213.53.83  90   e56f6c bf5b7c4be0237986d5243b87aa6d5130 5a
+bep42 :: SockAddr -> NodeId -> Maybe NodeId
+bep42 addr0 (NodeId r)
+ | let addr = either id id $ either4or6 addr0 -- unmap 4mapped SockAddrs
+ , Just ip <- fmap S.encode (fromSockAddr addr :: Maybe IPv4)
+              <|> fmap S.encode (fromSockAddr addr :: Maybe IPv6)
+    = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
+ | otherwise
+    = Nothing
+ where
+    ip4mask = "\x03\x0f\x3f\xff" :: ByteString
+    ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
+    nbhood_select = B.last r .&. 7
+    retr n = pure $ B.drop (B.length r - n) r
+    crc = S.encode . crc32c . B.pack
+    applyMask ip = case B.zipWith (.&.) msk ip of
+                    (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
+                    bs     -> bs
+        where msk | B.length ip == 4  =  ip4mask
+                  | otherwise         =  ip6mask
+
+
+
+defaultHandler :: ByteString -> Handler
+defaultHandler meth = MethodHandler decodePayload errorPayload returnError
+ where
+    returnError :: NodeInfo -> BValue -> IO Error
+    returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth)
+
+mainlineKademlia :: MainlineClient
+                    -> TriadCommittee NodeId SockAddr
+                    -> BucketRefresher NodeId NodeInfo
+                    -> Kademlia NodeId NodeInfo
+mainlineKademlia client committee refresher
+    = Kademlia quietInsertions
+               mainlineSpace
+               (vanillaIO (refreshBuckets refresher) $ ping client)
+                   { tblTransition = \tr -> do
+                        io1 <- transitionCommittee committee tr
+                        io2 <- touchBucket refresher tr
+                        return $ do
+                            io1 >> io2
+                            {-  noisy (timestamp updates are currently reported as transitions to Accepted)
+                            hPutStrLn stderr $ unwords
+                                [ show (transitionedTo tr)
+                                , show (transitioningNode tr)
+                                ] -}
+                   }
+
+
+mainlineSpace :: R.KademliaSpace NodeId NodeInfo
+mainlineSpace = R.KademliaSpace
+    { R.kademliaLocation = nodeId
+    , R.kademliaTestBit  = testIdBit
+    , R.kademliaXor      = xor
+    , R.kademliaSample   = genBucketSample'
+    }
+
+transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
+transitionCommittee committee (RoutingTransition ni Stranger) = do
+    delVote committee (nodeId ni)
+    return $ do
+        hPutStrLn stderr $ "delVote "++show (nodeId ni)
+transitionCommittee committee _ = return $ return ()
+
+updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO ()
+updateRouting client routing naddr msg = do
+    case prefer4or6 naddr Nothing of
+        Want_IP4 -> go (committee4 routing) (refresher4 routing)
+        Want_IP6 -> go (committee6 routing) (refresher6 routing)
+ where
+    go committee refresher = do
+        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
+        when (nodeIP self /= nodeIP naddr) $ do
+            case msg of
+                R { rspReflectedIP = Just sockaddr }
+                    -> do
+                        -- hPutStrLn stderr $ "External: "++show (nodeId naddr,sockaddr)
+                        atomically $ addVote committee (nodeId naddr) sockaddr
+                _   -> return ()
+            insertNode (mainlineKademlia client committee refresher) naddr
+
+data Ping = Ping deriving Show
+
+-- Pong is the same as Ping.
+type Pong = Ping
+pattern Pong = Ping
+
+instance BEncode Ping where
+  toBEncode Ping = toDict endDict
+  fromBEncode _  = pure Ping
+
+wantList :: WantIP -> [ByteString]
+wantList Want_IP4  = ["ip4"]
+wantList Want_IP6  = ["ip6"]
+wantList Want_Both = ["ip4","ip6"]
+
+instance BEncode WantIP where
+    toBEncode w = toBEncode $ wantList w
+    fromBEncode bval = do
+        wants <- fromBEncode bval
+        let _ = wants :: [ByteString]
+        case (elem "ip4" wants, elem "ip6" wants) of
+             (True,True)  -> Right Want_Both
+             (True,False) -> Right Want_IP4
+             (False,True) -> Right Want_IP6
+             _            -> Left "Unrecognized IP type."
+
+data FindNode = FindNode NodeId (Maybe WantIP)
+
+instance BEncode FindNode where
+  toBEncode (FindNode nid iptyp) = toDict   $ target_key .=! nid
+                                              .: want_key .=? iptyp
+                                              .: endDict
+  fromBEncode                    = fromDict $ FindNode  <$>! target_key
+                                                        <*>? want_key
+
+data NodeFound = NodeFound
+    { nodes4 :: [NodeInfo]
+    , nodes6 :: [NodeInfo]
+    }
+
+instance BEncode NodeFound where
+  toBEncode (NodeFound ns ns6) = toDict $
+       nodes_key .=?
+        (if Prelude.null ns then Nothing
+                            else Just (S.runPut (mapM_ putNodeInfo4 ns)))
+    .: nodes6_key .=?
+        (if Prelude.null ns6 then Nothing
+                             else Just (S.runPut (mapM_ putNodeInfo6 ns6)))
+    .: endDict
+
+  fromBEncode bval = NodeFound <$> ns4 <*> ns6
+   where
+    opt ns = fromMaybe [] <$> optional ns
+    ns4 = opt $ fromDict (binary getNodeInfo4 nodes_key) bval
+    ns6 = opt $ fromDict (binary getNodeInfo6 nodes6_key) bval
+
+binary :: S.Get a -> BKey -> BE.Get [a]
+binary get k = field (req k) >>= either (fail . format) return .
+    S.runGet (many get)
+  where
+    format str = "fail to deserialize " ++ show k ++ " field: " ++ str
+
+pingH :: NodeInfo -> Ping -> IO Pong
+pingH _ Ping = return Pong
+
+prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
+prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
+
+findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound
+findNodeH routing addr (FindNode node iptyp) = do
+    let preferred = prefer4or6 addr iptyp
+
+    (append4,append6) <- atomically $ do
+        ni4 <- R.thisNode <$> readTVar (routing4 routing)
+        ni6 <- R.thisNode <$> readTVar (routing6 routing)
+        return $ case ipFamily (nodeIP addr) of
+            Want_IP4 -> (id, (++ [ni6]))
+            Want_IP6 -> ((++ [ni4]), id)
+    ks  <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6)
+    ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4)
+    return $ NodeFound ks ks6
+ where
+    go f var = f . R.kclosest mainlineSpace k node <$> atomically (readTVar var)
+
+    k = R.defaultK
+
+
+data GetPeers = GetPeers InfoHash (Maybe WantIP)
+
+instance BEncode GetPeers where
+  toBEncode (GetPeers ih iptyp)
+              = toDict   $ info_hash_key .=! ih
+                        .: want_key .=? iptyp
+                        .: endDict
+  fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key
+
+
+data GotPeers = GotPeers
+  { -- | If the queried node has no peers for the infohash, returned
+    -- the K nodes in the queried nodes routing table closest to the
+    -- infohash supplied in the query.
+    peers        :: [PeerAddr]
+
+  , nodes        :: NodeFound
+
+    -- | The token value is a required argument for a future
+    -- announce_peer query.
+  , grantedToken :: Token
+  } -- deriving (Show, Eq, Typeable)
+
+nodeIsIPv6 :: NodeInfo -> Bool
+nodeIsIPv6 (NodeInfo _ (IPv6 _) _) = True
+nodeIsIPv6 _                       = False
+
+instance BEncode GotPeers where
+  toBEncode GotPeers { nodes = NodeFound ns4 ns6, ..} = toDict $
+       nodes_key  .=? (if null ns4 then Nothing
+                                   else Just $ S.runPut (mapM_ putNodeInfo4 ns4))
+    .: nodes6_key .=? (if null ns6 then Nothing
+                                   else Just $ S.runPut (mapM_ putNodeInfo4 ns6))
+    .: token_key .=! grantedToken
+    .: peers_key .=! map S.encode peers
+    .: endDict
+
+  fromBEncode = fromDict $ do
+    ns4 <- fromMaybe [] <$> optional (binary getNodeInfo4 nodes_key)        -- "nodes"
+    ns6 <- fromMaybe [] <$> optional (binary getNodeInfo6 nodes6_key)       -- "nodes6"
+    -- TODO: BEP 42...
+    --
+    -- Once enforced, responses to get_peers requests whose node ID does not
+    -- match its external IP should be considered to not contain a token and
+    -- thus not be eligible as storage target.  Implementations should take
+    -- care that they find the closest set of nodes which return a token and
+    -- whose IDs matches their IPs before sending a store request to those
+    -- nodes.
+    --
+    -- Sounds like something to take care of at peer-search time, so I'll
+    -- ignore it for now.
+    tok <- field    (req    token_key)                                      -- "token"
+    ps <- fromMaybe [] <$> optional (field (req peers_key) >>= decodePeers) -- "values"
+    pure $ GotPeers ps (NodeFound ns4 ns6) tok
+     where
+       decodePeers = either fail pure . mapM S.decode
+
+getPeersH :: Routing -> SwarmsDatabase -> NodeInfo -> GetPeers -> IO GotPeers
+getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do
+    ps <- do
+        tm <- getTimestamp
+        atomically $ do
+          (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers
+          writeTVar peers store'
+          return ps
+    -- Filter peer results to only a single address family, IPv4 or IPv6, as
+    -- per BEP 32.
+    let notboth  = iptyp >>= \case Want_Both -> Nothing
+                                   specific  -> Just specific
+        selected = prefer4or6 naddr notboth
+        ps'      = filter ( (== selected) . ipFamily . peerHost ) ps
+    tok <- grantToken toks naddr
+    ns <- findNodeH routing naddr (FindNode (coerce ih) iptyp)
+    return $ GotPeers ps' ns tok
+
+-- | Announce that the peer, controlling the querying node, is
+-- downloading a torrent on a port.
+data Announce = Announce
+  { -- | If set, the 'port' field should be ignored and the source
+    -- port of the UDP packet should be used as the peer's port
+    -- instead. This is useful for peers behind a NAT that may not
+    -- know their external port, and supporting uTP, they accept
+    -- incoming connections on the same port as the DHT port.
+    impliedPort :: Bool
+
+    -- | infohash of the torrent;
+  , topic    :: InfoHash
+
+    -- | some clients announce the friendly name of the torrent here.
+  , announcedName :: Maybe ByteString
+
+    -- | the port /this/ peer is listening;
+  , port     :: PortNumber
+
+    -- TODO: optional boolean "seed" key
+
+    -- | received in response to a previous get_peers query.
+  , sessionToken :: Token
+
+  } deriving (Show, Eq, Typeable)
+
+mkAnnounce :: PortNumber -> InfoHash -> Token -> Announce
+mkAnnounce portnum info token = Announce
+    { topic = info
+    , port = portnum
+    , sessionToken = token
+    , announcedName = Nothing
+    , impliedPort = False
+    }
+
+
+instance BEncode Announce where
+  toBEncode Announce {..} = toDict $
+       implied_port_key .=? flagField impliedPort
+    .: info_hash_key    .=! topic
+    .: name_key         .=? announcedName
+    .: port_key         .=! port
+    .: token_key        .=! sessionToken
+    .: endDict
+    where
+      flagField flag = if flag then Just (1 :: Int) else Nothing
+
+  fromBEncode = fromDict $ do
+    Announce <$> (boolField <$> optional (field (req implied_port_key)))
+             <*>! info_hash_key
+             <*>? name_key
+             <*>! port_key
+             <*>! token_key
+    where
+      boolField = maybe False (/= (0 :: Int))
+
+
+
+-- | The queried node must verify that the token was previously sent
+-- to the same IP address as the querying node. Then the queried node
+-- should store the IP address of the querying node and the supplied
+-- port number under the infohash in its store of peer contact
+-- information.
+data Announced = Announced
+  deriving (Show, Eq, Typeable)
+
+instance BEncode Announced where
+  toBEncode   _ = toBEncode Ping
+  fromBEncode _ = pure  Announced
+
+announceH :: SwarmsDatabase -> NodeInfo -> Announce -> IO (Either Error Announced)
+announceH (SwarmsDatabase peers toks _) naddr announcement = do
+  checkToken toks naddr (sessionToken announcement)
+    >>= bool (Left  <$> return (Error ProtocolError "invalid parameter: token"))
+             (Right <$> go)
+ where
+    go = atomically $ do
+        modifyTVar' peers
+            $ insertPeer (topic announcement) (announcedName announcement)
+            $ PeerAddr
+                { peerId = Nothing
+                -- Avoid storing IPv4-mapped addresses.
+                , peerHost = case nodeIP naddr of
+                    IPv6 ip6 | Just ip4 <- un4map ip6 -> IPv4 ip4
+                    a                                 -> a
+                , peerPort = if impliedPort announcement
+                                then nodePort naddr
+                                else port announcement
+                }
+        return Announced
+
+isReadonlyClient :: MainlineClient -> Bool
+isReadonlyClient client = False -- TODO
+
+mainlineSend :: ( BEncode a
+                , BEncode a2
+                ) => Method
+                  -> (a2 -> b)
+                  -> (t -> a)
+                  -> MainlineClient
+                  -> t
+                  -> NodeInfo
+                  -> IO (Maybe b)
+mainlineSend meth unwrap msg client nid addr = do
+    reply <- sendQuery client serializer (msg nid) addr
+    -- sendQuery will return (Just (Left _)) on a parse error.  We're going to
+    -- blow it away with the join-either sequence.
+    -- TODO: Do something with parse errors.
+    return $ join $ either (const Nothing) Just <$> reply
+ where
+    serializer = MethodSerializer
+        { methodTimeout  = \_ ni -> return (ni, 5000000)
+        , method         = meth
+        , wrapQuery      = encodeQueryPayload meth (isReadonlyClient client)
+        , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
+                                       (Right . unwrap)
+                                       . BE.fromBEncode)
+                           . rspPayload
+        }
+
+ping :: MainlineClient -> NodeInfo -> IO Bool
+ping client addr =
+    fromMaybe False
+    <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr
+
+-- searchQuery        :: ni -> IO (Maybe [ni], [r], tok))
+getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
+
+unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ())
+unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ())
+
+getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token))
+getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
+
+unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token)
+unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok)
+
+mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok)))
+                  -> Search NodeId (IP, PortNumber) tok NodeInfo r
+mainlineSearch qry = Search
+    { searchSpace       = mainlineSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = qry
+    }
+
+nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
+nodeSearch client = mainlineSearch (getNodes client)
+
+peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr
+peerSearch client = mainlineSearch (getPeers client)
+
+-- | List of bootstrap nodes maintained by different bittorrent
+-- software authors.
+bootstrapNodes :: WantIP -> IO [NodeInfo]
+bootstrapNodes want = unsafeInterleaveIO $ do
+    let wellknowns =
+          [ "router.bittorrent.com:6881" -- by BitTorrent Inc.
+
+            -- doesn't work at the moment (use git blame)  of commit
+          , "dht.transmissionbt.com:6881" -- by Transmission project
+
+          , "router.utorrent.com:6881"
+          ]
+    nss <- forM wellknowns $ \hostAndPort -> do
+        e <- resolve want hostAndPort
+        case e of
+            Left  _        -> return []
+            Right sockaddr -> either (const $ return [])
+                                     (return . (: []))
+                                     $ nodeInfo zeroID sockaddr
+    return $ concat nss
+
+-- | Resolve either a numeric network address or a hostname to a
+-- numeric IP address of the node.
+resolve :: WantIP -> String -> IO (Either IOError SockAddr)
+resolve want hostAndPort = do
+    let hints = defaultHints { addrSocketType = Datagram
+                             , addrFamily = case want of
+                                  Want_IP4 -> AF_INET
+                                  _        -> AF_INET6
+                             }
+        (rport,rhost) = span (/= ':') $ reverse hostAndPort
+        (host,port) = case rhost of
+                        []     -> (hostAndPort, Nothing)
+                        (_:hs) -> (reverse hs, Just (reverse rport))
+    tryIOError $ do
+        -- getAddrInfo throws exception on empty list, so this
+        --  pattern matching never fails.
+        info : _ <- getAddrInfo (Just hints) (Just host) port
+        return $ addrAddress info
+
+
+announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced)
+announce client msg addr = do
+    mainlineSend (Method "announce_peer") id (\() -> msg) client () addr
diff --git a/src/Network/BitTorrent/MainlineDHT/Symbols.hs b/src/Network/BitTorrent/MainlineDHT/Symbols.hs
new file mode 100644
index 00000000..05a64014
--- /dev/null
+++ b/src/Network/BitTorrent/MainlineDHT/Symbols.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module Network.BitTorrent.MainlineDHT.Symbols where
+
+import Data.BEncode.BDict
+
+peer_ip_key      =  "ip"           :: BKey
+peer_id_key      =  "peer id"      :: BKey
+peer_port_key    =  "port"         :: BKey
+msg_type_key     =  "msg_type"     :: BKey
+piece_key        =  "piece"        :: BKey
+total_size_key   =  "total_size"   :: BKey
+node_id_key      =  "id"           :: BKey
+read_only_key    =  "ro"           :: BKey
+want_key         =  "want"         :: BKey
+target_key       =  "target"       :: BKey
+nodes_key        =  "nodes"        :: BKey
+nodes6_key       =  "nodes6"       :: BKey
+info_hash_key    =  "info_hash"    :: BKey
+peers_key        =  "values"       :: BKey
+token_key        =  "token"        :: BKey
+name_key         =  "name"         :: BKey
+port_key         =  "port"         :: BKey
+implied_port_key =  "implied_port" :: BKey
+
diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs
new file mode 100644
index 00000000..8956df2c
--- /dev/null
+++ b/src/Network/Kademlia.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, PartialTypeSignatures, FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DeriveFunctor, DeriveTraversable #-}
+-- {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Network.Kademlia where
+
+import Data.Function
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Time.Clock       (getCurrentTime)
+import Data.Time.Clock.POSIX (getPOSIXTime, utcTimeToPOSIXSeconds)
+import Network.Kademlia.Routing   as R
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Bits
+import Data.Hashable
+import Data.IP
+import Data.Monoid
+import Data.Serialize                 (Serialize)
+import Data.Time.Clock.POSIX          (POSIXTime)
+import qualified Data.Wrapper.PSQInt  as Int
+         ;import Data.Wrapper.PSQInt  (pattern (:->))
+import Network.Address                (bucketRange,genBucketSample)
+import Network.Kademlia.Search
+import System.Entropy
+import System.Timeout
+import Text.PrettyPrint               as PP hiding (($$), (<>))
+import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
+import System.IO
+import Control.Concurrent.Tasks
+
+-- | The status of a given node with respect to a given routint table.
+data RoutingStatus
+    = Stranger  -- ^ The node is unknown to the Kademlia routing table.
+    | Applicant -- ^ The node may be inserted pending a ping timeout.
+    | Accepted  -- ^ The node has a slot in one of the Kademlia buckets.
+    deriving (Eq,Ord,Enum,Show,Read)
+
+-- | A change occured in the kademlia routing table.
+data RoutingTransition ni = RoutingTransition
+    { transitioningNode :: ni
+    , transitionedTo    :: !RoutingStatus
+    }
+    deriving (Eq,Ord,Show,Read)
+
+data InsertionReporter ni = InsertionReporter
+    { -- | Called on every inbound packet. Accepts:
+      --
+      --   * Origin of packet.
+      --
+      --   * List of nodes to be pinged as a result.
+      reportArrival :: POSIXTime
+                       -> ni
+                       -> [ni]
+                       -> IO ()
+      -- | Called on every ping probe. Accepts:
+      --
+      --    * Who was pinged.
+      --
+      --    * True Bool value if they ponged.
+    , reportPingResult :: POSIXTime
+                          -> ni
+                          -> Bool
+                          -> IO ()
+    }
+
+quietInsertions :: InsertionReporter ni
+quietInsertions = InsertionReporter
+    { reportArrival = \_ _ _ -> return ()
+    , reportPingResult = \_ _ _ -> return ()
+    }
+
+contramapIR :: (t -> ni) -> InsertionReporter ni -> InsertionReporter t
+contramapIR f ir = InsertionReporter
+    { reportArrival = \tm ni nis -> reportArrival ir tm (f ni) (map f nis)
+    , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b
+    }
+
+-- | All the IO operations neccessary to maintain a Kademlia routing table.
+data TableStateIO ni = TableStateIO
+    { -- | Write the routing table.  Typically 'writeTVar'.
+      tblWrite :: R.BucketList ni -> STM ()
+
+      -- | Read the routing table.  Typically 'readTVar'.
+    , tblRead :: STM (R.BucketList ni)
+
+      -- | Issue a ping to a remote node and report 'True' if the node
+      -- responded within an acceptable time and 'False' otherwise.
+    , tblPing :: ni -> IO Bool
+
+      -- | Convenience method provided to assist in maintaining state
+      -- consistent with the routing table.  It will be invoked in the same
+      -- transaction that 'tblRead'\/'tblWrite' occured but only when there was
+      -- an interesting change.  The returned IO action will be triggered soon
+      -- afterward.
+      --
+      -- It is not necessary to do anything interesting here.  The following
+      -- trivial implementation is fine:
+      --
+      -- > tblTransition = const $ return $ return ()
+    , tblTransition :: RoutingTransition ni -> STM (IO ())
+    }
+
+vanillaIO :: TVar (BucketList ni) -> (ni -> IO Bool) -> TableStateIO ni
+vanillaIO var ping = TableStateIO
+    { tblRead    = readTVar var
+    , tblWrite   = writeTVar var
+    , tblPing    = ping
+    , tblTransition = const $ return $ return ()
+    }
+
+-- | Everything neccessary to maintain a routing table of /ni/ (node
+-- information) entries.
+data Kademlia nid ni = Kademlia (InsertionReporter ni)
+                                (KademliaSpace nid ni)
+                                (TableStateIO ni)
+
+
+-- Helper to 'insertNode'.
+--
+-- Adapt return value from 'updateForPingResult' into a
+-- more easily groked list of transitions.
+transition :: (ni,Maybe (t,ni)) -> [RoutingTransition ni]
+transition (x,m) =
+    -- Just _  <- m  =  Node transition:  Accepted  --> Stranger
+    -- Nothing <- m  =  Node transition:  Applicant --> Stranger
+    RoutingTransition x Stranger
+       : maybeToList (accepted <$> m)
+
+-- Helper to 'transition'
+--
+-- Node transition: Applicant --> Accepted
+accepted :: (t,ni) -> RoutingTransition ni
+accepted (_,y) = RoutingTransition y Accepted
+
+
+insertNode :: Kademlia nid ni -> ni -> IO ()
+insertNode (Kademlia reporter space io) node = do
+
+  tm <- utcTimeToPOSIXSeconds <$> getCurrentTime
+
+  (ps,reaction) <- atomically $ do
+    tbl <- tblRead io
+    let (inserted, ps,t') = R.updateForInbound space tm node tbl
+    tblWrite io t'
+    reaction <- case ps of
+        _ | inserted -> -- Node transition: Stranger --> Accepted
+                        tblTransition io $ RoutingTransition node Accepted
+        (_:_)        -> -- Node transition: Stranger --> Applicant
+                        tblTransition io $ RoutingTransition node Applicant
+        _            -> return $ return ()
+    return (ps, reaction)
+
+  reportArrival reporter tm node ps
+  reaction
+
+  _ <- fork $ do
+    myThreadId >>= flip labelThread "pingResults"
+    forM_ ps $ \n -> do
+        b <- tblPing io n
+        reportPingResult reporter tm n b -- XXX: tm is timestamp of original triggering packet, not result
+        join $ atomically $ do
+            tbl <- tblRead io
+            let (replacements, t') = R.updateForPingResult space n b tbl
+            tblWrite io t'
+            ios <- sequence $ concatMap
+                                (map (tblTransition io) . transition)
+                                replacements
+            return $ sequence_ ios
+
+  return ()
+
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
new file mode 100644
index 00000000..93cf08f3
--- /dev/null
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -0,0 +1,432 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+module Network.Kademlia.Bootstrap where
+
+import Data.Function
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Time.Clock       (getCurrentTime)
+import Data.Time.Clock.POSIX (getPOSIXTime, utcTimeToPOSIXSeconds)
+import Network.Kademlia.Routing   as R
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Bits
+import Data.Hashable
+import Data.IP
+import Data.Monoid
+import Data.Serialize                 (Serialize)
+import Data.Time.Clock.POSIX          (POSIXTime)
+import Data.Ord
+import System.Entropy
+import System.Timeout
+import Text.PrettyPrint               as PP hiding (($$), (<>))
+import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
+import System.IO
+
+import qualified Data.Wrapper.PSQInt  as Int
+         ;import Data.Wrapper.PSQInt  (pattern (:->))
+import Network.Address                (bucketRange,genBucketSample)
+import Network.Kademlia.Search
+import Control.Concurrent.Tasks
+import Network.Kademlia
+
+type SensibleNodeId nid ni =
+                 ( Show nid
+                 , Ord nid
+                 , Ord ni
+                 , Hashable nid
+                 , Hashable ni )
+
+data BucketRefresher nid ni = forall tok addr. Ord addr =>  BucketRefresher
+    { -- | A staleness threshold (if a bucket goes this long without being
+      -- touched, a refresh will be triggered).
+      refreshInterval  :: POSIXTime
+      -- | A TVar with the time-to-refresh schedule for each bucket.
+      --
+      -- To "touch" a bucket and prevent it from being refreshed, reschedule
+      -- its refresh time to some time into the future by modifying its
+      -- priority in this priority search queue.
+    , refreshQueue     :: TVar (Int.PSQ POSIXTime)
+      -- | This is the kademlia node search specification.
+    , refreshSearch    :: Search nid addr tok ni ni
+      -- | The current kademlia routing table buckets.
+    , refreshBuckets   :: TVar (R.BucketList ni)
+      -- | Action to ping a node.  This is used only during initial bootstrap
+      -- to get some nodes in our table.  A 'True' result is interpreted as a a
+      -- pong, where 'False' is a non-response.
+    , refreshPing      :: ni -> IO Bool
+    , -- | Timestamp of last bucket event.
+      refreshLastTouch :: TVar POSIXTime
+    , -- | This variable indicates whether or not we are in bootstrapping mode.
+      bootstrapMode   :: TVar Bool
+    , -- | When this countdown reaches 0, we exit bootstrap mode.  It is decremented on
+      -- every finished refresh.
+      bootstrapCountdown :: TVar (Maybe Int)
+    }
+
+newBucketRefresher :: ( Ord addr, Hashable addr
+                      , SensibleNodeId nid ni )
+                    => ni
+                    -> Search nid addr tok ni ni
+                    -> (ni -> IO Bool)
+                    -> STM (BucketRefresher nid ni)
+newBucketRefresher template_ni sch ping = do
+    let spc    = searchSpace sch
+        nodeId = kademliaLocation spc
+    bkts <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) template_ni R.defaultBucketCount
+    sched <- newTVar Int.empty
+    lasttouch <- newTVar 0 -- Would use getPOSIXTime here, or minBound, but alas...
+    bootstrapVar <- newTVar True -- Start in bootstrapping mode.
+    bootstrapCnt <- newTVar Nothing
+    return  BucketRefresher
+                    { refreshInterval    = 15 * 60
+                    , refreshQueue       = sched
+                    , refreshSearch      = sch
+                    , refreshBuckets     = bkts
+                    , refreshPing        = ping
+                    , refreshLastTouch   = lasttouch
+                    , bootstrapMode      = bootstrapVar
+                    , bootstrapCountdown = bootstrapCnt
+                    }
+
+-- | This was added to avoid the compile error "Record update for
+-- insufficiently polymorphic field" when trying to update the existentially
+-- quantified field 'refreshSearch'.
+updateRefresherIO :: Ord addr
+                     => Search nid addr tok ni ni
+                     -> (ni -> IO Bool)
+                     -> BucketRefresher nid ni ->  BucketRefresher nid ni
+updateRefresherIO sch ping BucketRefresher{..} = BucketRefresher
+    { refreshSearch      = sch
+    , refreshPing        = ping
+    , refreshInterval    = refreshInterval
+    , refreshBuckets     = refreshBuckets
+    , refreshQueue       = refreshQueue
+    , refreshLastTouch   = refreshLastTouch
+    , bootstrapMode      = bootstrapMode
+    , bootstrapCountdown = bootstrapCountdown
+    }
+
+-- | Fork a refresh loop.  Kill the returned thread to terminate it.
+forkPollForRefresh :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ThreadId
+forkPollForRefresh r@BucketRefresher{ refreshInterval
+                                    , refreshQueue
+                                    , refreshBuckets
+                                    , refreshSearch   } = fork $ do
+      myThreadId >>= flip labelThread "pollForRefresh"
+      fix $ \again -> do
+        join $ atomically $ do
+            nextup <- Int.findMin <$> readTVar refreshQueue
+            maybe retry (return . go again) nextup
+ where
+    refresh :: Int -> IO Int
+    refresh n = do
+        -- hPutStrLn stderr $ "Refresh time! "++ show n
+        refreshBucket r n
+
+    go again ( bktnum :-> refresh_time ) = do
+        now <- getPOSIXTime
+        case fromEnum (refresh_time - now) of
+            x | x <= 0 -> do -- Refresh time!
+                             -- Move it to the back of the refresh queue.
+                             atomically $ do
+                                interval <- effectiveRefreshInterval r bktnum
+                                modifyTVar' refreshQueue
+                                            $ Int.insert bktnum (now + interval)
+                             -- Now fork the refresh operation.
+                             -- TODO: We should probably propogate the kill signal to this thread.
+                             fork $ do myThreadId >>= flip labelThread ("refresh."++show bktnum)
+                                       _ <- refresh bktnum
+                                       return ()
+                             return ()
+            picoseconds -> do
+                -- hPutStrLn stderr $ show (picoseconds `div` 10^12) ++ " seconds until refresh " ++ show bktnum
+                threadDelay ( picoseconds `div` 10^6 )
+        again
+
+
+-- | This is a helper to 'refreshBucket' which does some book keeping to decide
+-- whether or not a bucket is sufficiently refreshed or not.  It will return
+-- false when we can terminate a node search.
+checkBucketFull :: Ord ni => KademliaSpace nid ni   -- ^ Obtain a node id from a node.
+                            -> TVar (BucketList ni) -- ^ The current routing table.
+                            -> TVar (Set.Set ni)    -- ^ In-range nodes found so far.
+                            -> TVar Bool            -- ^ The result will also be written here.
+                            -> Int                  -- ^ The bucket number of interest.
+                            -> ni                   -- ^ A newly found node.
+                            -> STM Bool
+checkBucketFull space var resultCounter fin n found_node = do
+    let fullcount = R.defaultBucketSize
+        saveit True = writeTVar fin True >> return True
+        saveit _    = return False
+    tbl <- readTVar var
+    let counts = R.shape tbl
+        nid = kademliaLocation space found_node
+    -- Update the result set with every found node that is in the
+    -- bucket of interest.
+    when (n == R.bucketNumber space nid tbl)
+         $ modifyTVar' resultCounter (Set.insert found_node)
+    resultCount <- readTVar resultCounter
+    saveit $ case drop (n - 1) counts of
+        (cnt:_) | cnt < fullcount            -> True  -- bucket not full, keep going
+        _ | Set.size resultCount < fullcount -> True  -- we haven't got many results, keep going
+        _                                    -> False -- okay, good enough, let's quit.
+
+-- | Called from 'refreshBucket' with the current time when a refresh of the
+-- supplied bucket number finishes.
+onFinishedRefresh :: BucketRefresher nid ni -> Int -> POSIXTime -> STM (IO ())
+onFinishedRefresh BucketRefresher { bootstrapCountdown
+                                  , bootstrapMode
+                                  , refreshQueue
+                                  , refreshBuckets     } num now = do
+    bootstrapping <- readTVar bootstrapMode
+    if not bootstrapping then return $ return () -- hPutStrLn stderr $ "Finished non-boostrapping refresh: "++show num
+                         else do
+    tbl <- readTVar refreshBuckets
+    action <-
+      if num /= R.bktCount tbl - 1
+        then do modifyTVar' bootstrapCountdown (fmap pred)
+                return $ return () -- hPutStrLn stderr $ "BOOTSTRAP decrement"
+        else do
+            -- The last bucket finished.
+            cnt <- readTVar bootstrapCountdown
+            case cnt of
+                Nothing -> do
+                    let fullsize = R.defaultBucketSize
+                        notfull (n,len) | n==num         = False
+                                        | len>=fullsize  = False
+                                        | otherwise      = True
+                        unfull = case filter notfull $ zip [0..] (R.shape tbl) of
+                                    [] -> [(0,0)] -- Schedule at least 1 more refresh.
+                                    xs -> xs
+                    forM_ unfull $ \(n,_) -> do
+                        -- Schedule immediate refresh for unfull buckets (other than this one).
+                        modifyTVar' refreshQueue $ Int.insert n (now - 1)
+                    writeTVar bootstrapCountdown $! Just $! length unfull
+                    return $ return () -- hPutStrLn stderr $ "BOOTSTRAP scheduling: "++show unfull
+                Just n  -> do writeTVar bootstrapCountdown $! Just $! pred n
+                              return $ return () -- hPutStrLn stderr "BOOTSTRAP decrement (last bucket)"
+    cnt <- readTVar bootstrapCountdown
+    if (cnt == Just 0)
+    then do
+        -- Boostrap finished!
+        writeTVar bootstrapMode False
+        writeTVar bootstrapCountdown Nothing
+        return $ do action ; hPutStrLn stderr $ "BOOTSTRAP complete (" ++ show (R.shape tbl) ++ ")."
+    else return $ do action ; hPutStrLn stderr $ "BOOTSTRAP progress " ++ show (num,R.shape tbl,cnt)
+
+refreshBucket :: (Show nid, Ord ni, Ord nid, Hashable nid, Hashable ni) =>
+                 BucketRefresher nid ni -> Int -> IO Int
+refreshBucket r@BucketRefresher{ refreshSearch  = sch
+                               , refreshBuckets = var }
+              n = do
+    tbl <- atomically (readTVar var)
+    let count = bktCount tbl
+        nid = kademliaLocation (searchSpace sch) (thisNode tbl)
+    sample <- if n+1 >= count                         -- Is this the last bucket?
+                then return nid                       -- Yes? Search our own id.
+                else kademliaSample (searchSpace sch) -- No? Generate a random id.
+                        getEntropy
+                        nid
+                        (bucketRange n (n + 1 < count))
+    fin <- atomically $ newTVar False
+    resultCounter <- atomically $ newTVar Set.empty
+
+    hPutStrLn stderr $ "Start refresh " ++ show (n,sample)
+
+    -- Set 15 minute timeout in order to avoid overlapping refreshes.
+    s <- search sch tbl sample $ if n+1 == R.defaultBucketCount
+                                    then const $ return True -- Never short-circuit the last bucket.
+                                    else checkBucketFull (searchSpace sch) var resultCounter fin n
+    _ <- timeout (15*60*1000000) $ do
+            atomically $ searchIsFinished s >>= check
+    atomically $ searchCancel s
+    hPutStrLn stderr $ "Finish refresh " ++ show (n,sample)
+    now <- getPOSIXTime
+    join $ atomically $ onFinishedRefresh r n now
+    rcount <- atomically $ do
+        c <- Set.size <$> readTVar resultCounter
+        b <- readTVar fin
+        return $ if b then 1 else c
+    return rcount
+
+refreshLastBucket :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ()
+refreshLastBucket r@BucketRefresher { refreshBuckets
+                                    , refreshQueue   } = do
+
+    now <- getPOSIXTime
+    atomically $ do
+    cnt <- bktCount <$> readTVar refreshBuckets
+    -- Schedule immediate refresh.
+    modifyTVar' refreshQueue $ Int.insert (cnt-1) (now - 1)
+
+restartBootstrap :: (Hashable ni, Hashable nid, Ord ni, Ord nid, Show nid) =>
+                 BucketRefresher nid ni -> STM (IO ())
+restartBootstrap r@BucketRefresher{ bootstrapMode, bootstrapCountdown } = do
+    unchanged <- readTVar bootstrapMode
+    writeTVar bootstrapMode True
+    writeTVar bootstrapCountdown Nothing
+    if not unchanged then return $ do
+                            hPutStrLn stderr "BOOTSTRAP entered bootstrap mode"
+                            refreshLastBucket r
+                     else return $ hPutStrLn stderr "BOOTSTRAP already bootstrapping"
+
+bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) =>
+             BucketRefresher nid ni
+             -> t1 ni -- ^ Nodes to bootstrap from.
+             -> t ni  -- ^ Fallback nodes; used only if the others are unresponsive.
+             -> IO ()
+bootstrap r@BucketRefresher { refreshSearch  = sch
+                            , refreshBuckets = var
+                            , refreshPing    = ping
+                            , bootstrapMode         } ns ns0 = do
+    gotPing <- atomically $ newTVar False
+
+    -- First, ping the given nodes so that they are added to
+    -- our routing table.
+    withTaskGroup "bootstrap.resume" 20 $ \g -> do
+        forM_ ns $ \n -> do
+            let lbl = show $ kademliaLocation (searchSpace sch) n
+            forkTask g lbl $ do
+                b <- ping n
+                when b $ atomically $ writeTVar gotPing True
+
+    -- We resort to the hardcoded fallback nodes only when we got no
+    -- responses.  This is to lesson the burden on well-known boostrap
+    -- nodes.
+    fallback <- atomically (readTVar gotPing) >>= return . when . not
+    fallback $ withTaskGroup "bootstrap.ping" 20 $ \g -> do
+        forM_ ns0 $ \n -> do
+            forkTask g (show $ kademliaLocation (searchSpace sch) n)
+                       (void $ ping n)
+    hPutStrLn stderr "Finished bootstrap pings."
+    -- Now search our own Id by entering bootstrap mode from non-bootstrap mode.
+    join $ atomically $ do
+        writeTVar bootstrapMode False
+        restartBootstrap r
+    --
+    -- Hopefully 'forkPollForRefresh' was invoked and can take over
+    -- maintenance.
+
+
+effectiveRefreshInterval :: BucketRefresher nid ni -> Int -> STM POSIXTime
+effectiveRefreshInterval BucketRefresher{ refreshInterval
+                                        , refreshBuckets
+                                        , bootstrapMode   } num = do
+    tbl <- readTVar refreshBuckets
+    bootstrapping <- readTVar bootstrapMode
+    case bootstrapping of
+        False -> return refreshInterval
+        True  -> do
+            -- When bootstrapping, refresh interval for non-full buckets is only 15 seconds.
+            let fullcount = R.defaultBucketSize
+                count = fromMaybe fullcount $ listToMaybe $ drop (num - 1) $ R.shape tbl
+            if count == fullcount
+                then return refreshInterval
+                else return 15 -- seconds
+
+
+
+-- | Reschedule a bucket's refresh-time.  It should be called whenever a bucket
+-- changes.  This will typically be invoked from 'tblTransition'.
+--
+-- From BEP 05:
+--
+-- > Each bucket should maintain a "last changed" property to indicate how
+-- > "fresh" the contents are.
+--
+-- We will use a "time to next refresh" property instead and store it in
+-- a priority search queue.
+--
+-- In detail using an expository (not actually implemented) type
+-- 'BucketTouchEvent'...
+--
+-- >>> data BucketTouchEvent = RoutingStatus :--> RoutingStatus
+-- >>> bucketEvents =
+-- >>>  [ Applicant :--> Stranger -- a node in a bucket is pinged and it responds,
+-- >>>
+-- >>>  , Stranger  :--> Accepted -- or a node is added to a bucket,
+-- >>>
+-- >>>  , Accepted  :--> Stranger -- or a node in a bucket is replaced
+-- >>>  , Applicant :--> Accepted -- with another node,
+-- >>>  ]
+--
+-- the bucket's last changed property should be updated. Buckets that have not
+-- been changed in 15 minutes (see 'refreshInterval') should be "refreshed."
+-- This is done by picking a random ID in the range of the bucket and
+-- performing a find_nodes search on it.
+--
+-- The only other possible BucketTouchEvents are as follows:
+--
+-- >>> not_handled =
+-- >>>   , Stranger :--> Applicant -- A ping is pending, it's result is covered:
+-- >>>                             --     (Applicant :--> Stranger)
+-- >>>                             --     (Applicant :--> Accepted)
+-- >>>   , Accepted :--> Applicant -- Never happens
+-- >>>   ]
+--
+-- Because this BucketTouchEvent type is not actually implemented and we only
+-- receive notifications of a node's new state, it suffices to reschedule the
+-- bucket refresh 'touchBucket' on every transition to a state other than
+-- 'Applicant'.
+--
+-- XXX: Unfortunately, this means redundantly triggering twice upon every node
+-- replacement because we do not currently distinguish between standalone
+-- insertion/deletion events and an insertion/deletion pair constituting
+-- replacement.
+--
+-- It might also be better to pass the timestamp of the transition here and
+-- keep the refresh queue in better sync with the routing table by updating it
+-- within the STM monad.
+--
+-- We embed the result in the STM monad but currently, no STM state changes
+-- occur until the returned IO action is invoked.  TODO: simplify?
+touchBucket :: SensibleNodeId nid ni
+            => BucketRefresher nid ni
+            -> RoutingTransition ni     -- ^ What happened to the bucket?
+            -> STM (IO ())
+touchBucket r@BucketRefresher{ refreshSearch
+                             , refreshInterval
+                             , refreshBuckets
+                             , refreshQueue
+                             , refreshLastTouch
+                             , bootstrapMode
+                             , bootstrapCountdown }
+            RoutingTransition{ transitionedTo
+                             , transitioningNode }
+    = case transitionedTo of
+        Applicant -> return $ return () -- Ignore transition to applicant.
+        _         -> return $ do        -- Reschedule for any other transition.
+         now <- getPOSIXTime
+         join $ atomically $ do
+            let space = searchSpace refreshSearch
+                nid = kademliaLocation space transitioningNode
+            tbl <- readTVar refreshBuckets
+            let num = R.bucketNumber space nid tbl
+            stamp <- readTVar refreshLastTouch
+            action <- case stamp /= 0 && (now - stamp > 60) of
+                True -> do
+                    -- It's been one minute since any bucket has been touched, re-enter bootstrap mode.
+                    restartBootstrap r
+                False -> return $ return ()
+            interval <- effectiveRefreshInterval r num
+            modifyTVar' refreshQueue $ Int.insert num (now + interval)
+            writeTVar refreshLastTouch now
+            return action
diff --git a/src/Network/Kademlia/Routing.hs b/src/Network/Kademlia/Routing.hs
new file mode 100644
index 00000000..a52cca73
--- /dev/null
+++ b/src/Network/Kademlia/Routing.hs
@@ -0,0 +1,808 @@
+-- |
+--   Copyright   :  (c) Sam Truzjan 2013
+--                  (c) Joe Crayne 2017
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
+--   Every node maintains a routing table of known good nodes. The
+--   nodes in the routing table are used as starting points for
+--   queries in the DHT. Nodes from the routing table are returned in
+--   response to queries from other nodes.
+--
+--   For more info see:
+--   <http://www.bittorrent.org/beps/bep_0005.html#routing-table>
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns    #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns    #-}
+{-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.Kademlia.Routing
+       {-
+       ( -- * BucketList
+         BucketList
+       , Info(..)
+
+         -- * Attributes
+       , BucketCount
+       , defaultBucketCount
+       , BucketSize
+       , defaultBucketSize
+       , NodeCount
+
+         -- * Query
+       , Network.Kademlia.Routing.null
+       , Network.Kademlia.Routing.full
+       , thisId
+       , shape
+       , Network.Kademlia.Routing.size
+       , Network.Kademlia.Routing.depth
+       , compatibleNodeId
+
+         -- * Lookup
+       , K
+       , defaultK
+       , TableKey (..)
+       , kclosest
+
+         -- * Construction
+       , Network.Kademlia.Routing.nullTable
+       , Event(..)
+       , CheckPing(..)
+       , Network.Kademlia.Routing.insert
+
+         -- * Conversion
+       , Network.Kademlia.Routing.TableEntry
+       , Network.Kademlia.Routing.toList
+
+         -- * Routing
+       , Timestamp
+       , getTimestamp
+       ) -} where
+
+import Control.Applicative as A
+import Control.Arrow
+import Control.Monad
+import Data.Function
+import Data.Functor.Contravariant
+import Data.Functor.Identity
+import Data.List as L hiding (insert)
+import Data.Maybe
+import Data.Monoid
+import Data.Wrapper.PSQ as PSQ
+import Data.Serialize as S hiding (Result, Done)
+import qualified Data.Sequence as Seq
+import Data.Time
+import Data.Time.Clock.POSIX
+import Data.Word
+import GHC.Generics
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass (pPrint,Pretty)
+import qualified Data.ByteString as BS
+import Data.Bits
+import Data.Ord
+import Data.Reflection
+import Network.Address
+import Data.Typeable
+import Data.Coerce
+import Data.Hashable
+
+
+-- | Last time the node was responding to our queries.
+--
+--   Not all nodes that we learn about are equal. Some are \"good\" and
+--   some are not. Many nodes using the DHT are able to send queries
+--   and receive responses, but are not able to respond to queries
+--   from other nodes. It is important that each node's routing table
+--   must contain only known good nodes. A good node is a node has
+--   responded to one of our queries within the last 15 minutes. A
+--   node is also good if it has ever responded to one of our queries
+--   and has sent us a query within the last 15 minutes. After 15
+--   minutes of inactivity, a node becomes questionable. Nodes become
+--   bad when they fail to respond to multiple queries in a row. Nodes
+--   that we know are good are given priority over nodes with unknown
+--   status.
+--
+type Timestamp = POSIXTime
+
+getTimestamp :: IO Timestamp
+getTimestamp = do
+  utcTime <- getCurrentTime
+  return $ utcTimeToPOSIXSeconds utcTime
+
+
+
+{-----------------------------------------------------------------------
+    Bucket
+-----------------------------------------------------------------------}
+--
+-- When a k-bucket is full and a new node is discovered for that
+-- k-bucket, the least recently seen node in the k-bucket is
+-- PINGed. If the node is found to be still alive, the new node is
+-- place in a secondary list, a replacement cache. The replacement
+-- cache is used only if a node in the k-bucket stops responding. In
+-- other words: new nodes are used only when older nodes disappear.
+
+-- | Timestamp - last time this node is pinged.
+type NodeEntry ni = Binding ni Timestamp
+
+
+-- | Maximum number of 'NodeInfo's stored in a bucket. Most clients
+-- use this value.
+defaultBucketSize :: Int
+defaultBucketSize = 8
+
+data QueueMethods m elem fifo = QueueMethods
+    { pushBack :: elem -> fifo -> m fifo
+    , popFront :: fifo -> m (Maybe elem, fifo)
+    , emptyQueue :: m fifo
+    }
+
+{-
+fromQ :: Functor m =>
+       ( a -> b )
+       -> ( b -> a )
+       -> QueueMethods m elem a
+       -> QueueMethods m elem b
+fromQ embed project QueueMethods{..} =
+    QueueMethods { pushBack = \e -> fmap embed . pushBack e . project
+                 , popFront = fmap (second embed) . popFront . project
+                 , emptyQueue = fmap embed emptyQueue
+                 }
+-}
+
+seqQ :: QueueMethods Identity ni (Seq.Seq ni)
+seqQ = QueueMethods
+    { pushBack = \e fifo -> pure (fifo Seq.|> e)
+    , popFront = \fifo -> case Seq.viewl fifo of
+                            e Seq.:< fifo' -> pure (Just e, fifo')
+                            Seq.EmptyL     -> pure (Nothing, Seq.empty)
+    , emptyQueue = pure Seq.empty
+    }
+
+type BucketQueue ni = Seq.Seq ni
+
+bucketQ :: QueueMethods Identity ni (BucketQueue ni)
+bucketQ = seqQ
+
+
+data Compare a = Compare (a -> a -> Ordering) (Int -> a -> Int)
+
+contramapC :: (b -> a) -> Compare a -> Compare b
+contramapC f (Compare cmp hsh) = Compare (\a b -> cmp (f a) (f b))
+                                         (\s x -> hsh s (f x))
+
+newtype Ordered' s a = Ordered a
+ deriving (Show)
+
+-- | Hack to avoid UndecidableInstances
+newtype Shrink a = Shrink a
+ deriving (Show)
+
+type Ordered s a = Ordered' s (Shrink a)
+
+instance Reifies s (Compare a) => Eq (Ordered' s (Shrink a)) where
+    a == b   = (compare a b == EQ)
+
+instance Reifies s (Compare a) => Ord (Ordered' s (Shrink a)) where
+    compare a b = cmp (coerce a) (coerce b)
+     where Compare cmp _ = reflect (Proxy :: Proxy s)
+
+instance Reifies s (Compare a) => Hashable (Ordered' s (Shrink a)) where
+    hashWithSalt salt x = hash salt (coerce x)
+     where Compare _ hash = reflect (Proxy :: Proxy s)
+
+-- | Bucket is also limited in its length — thus it's called k-bucket.
+--   When bucket becomes full, we should split it in two lists by
+--   current span bit. Span bit is defined by depth in the routing
+--   table tree. Size of the bucket should be choosen such that it's
+--   very unlikely that all nodes in bucket fail within an hour of
+--   each other.
+data Bucket s ni = Bucket
+    { bktNodes :: !(PSQ (Ordered s ni) Timestamp)           -- current routing nodes
+    , bktQ     :: !(BucketQueue (Timestamp,ni)) -- replacements pending time-outs
+    } deriving (Generic)
+
+#define CAN_SHOW_BUCKET 0
+
+#if CAN_SHOW_BUCKET
+deriving instance Show ni => Show (Bucket s ni)
+#endif
+
+bucketCompare :: forall p ni s. Reifies s (Compare ni) => p (Bucket s ni) -> Compare ni
+bucketCompare _ = reflect (Proxy :: Proxy s)
+
+mapBucket :: ( Reifies s (Compare a)
+             , Reifies t (Compare ni)
+             ) => (a -> ni) -> Bucket s a -> Bucket t ni
+mapBucket f (Bucket ns q) = Bucket (PSQ.fromList $ map (\(ni :-> tm) -> (f' ni :-> tm)) $ PSQ.toList ns)
+                                   (fmap (second f) q)
+ where f' = coerce . f . coerce
+
+
+#if 0
+
+{-
+getGenericNode :: ( Serialize (NodeId)
+                  , Serialize ip
+                  , Serialize u
+                  ) => Get (NodeInfo)
+getGenericNode = do
+    nid <- get
+    naddr <- get
+    u <- get
+    return NodeInfo
+        { nodeId = nid
+        , nodeAddr = naddr
+        , nodeAnnotation = u
+        }
+
+putGenericNode :: ( Serialize (NodeId)
+                  , Serialize ip
+                  , Serialize u
+                  ) => NodeInfo -> Put
+putGenericNode (NodeInfo nid naddr u) = do
+    put nid
+    put naddr
+    put u
+
+instance (Eq ip, Ord (NodeId), Serialize (NodeId), Serialize ip, Serialize u) => Serialize (Bucket) where
+    get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ)
+    put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes
+-}
+
+#endif
+
+psqFromPairList :: (Ord p, PSQKey k) => [(k, p)] -> PSQ k p
+psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs
+
+psqToPairList :: ( PSQKey t, Ord t1 ) => PSQ t t1 -> [(t, t1)]
+psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq
+
+-- | Update interval, in seconds.
+delta :: NominalDiffTime
+delta = 15 * 60
+
+-- | Should maintain a set of stable long running nodes.
+--
+-- Note: pings are triggerd only when a bucket is full.
+updateBucketForInbound :: ( Coercible t1 t
+                          , Alternative f
+                          , Reifies s (Compare t1)
+                          ) => NominalDiffTime -> t1 -> Bucket s t1 -> f ([t], Bucket s t1)
+updateBucketForInbound curTime info bucket
+  -- Just update timestamp if a node is already in bucket.
+  --
+  -- Note PingResult events should only occur for nodes we requested a ping for,
+  -- and those will always already be in the routing queue and will get their
+  -- timestamp updated here, since 'TryInsert' is called on every inbound packet,
+  -- including ping results.
+  | already_have
+    = pure ( [], map_ns $ PSQ.insertWith max (coerce info) curTime )
+  -- bucket is good, but not full => we can insert a new node
+  | PSQ.size (bktNodes bucket) < defaultBucketSize
+    = pure ( [], map_ns $ PSQ.insert (coerce info) curTime )
+  -- If there are any questionable nodes in the bucket have not been
+  -- seen in the last 15 minutes, the least recently seen node is
+  -- pinged. If any nodes in the bucket are known to have become bad,
+  -- then one is replaced by the new node in the next insertBucket
+  -- iteration.
+  | not (L.null stales)
+    = pure ( stales
+           , bucket { -- Update timestamps so that we don't redundantly ping.
+                      bktNodes = updateStamps curTime (coerce stales) $ bktNodes bucket
+                      -- Update queue with the pending NodeInfo in case of ping fail.
+                    , bktQ     = runIdentity $ pushBack bucketQ (curTime,info) $ bktQ bucket } )
+  -- When the bucket is full of good nodes, the new node is simply discarded.
+  -- We must return 'A.empty' here to ensure that bucket splitting happens
+  -- inside 'modifyBucket'.
+  | otherwise = A.empty
+ where
+    -- We (take 1) to keep a 1-to-1 correspondence between pending pings and
+    -- waiting nodes in the bktQ.  This way, we don't have to worry about what
+    -- to do with failed pings for which there is no ready replacements.
+    stales = -- One stale:
+             do (n :-> t) <- maybeToList $ PSQ.findMin (bktNodes bucket)
+                guard (t < curTime - delta)
+                return $ coerce n
+             -- All stale:
+             -- map key \$ PSQ.atMost (curTime - delta) $ bktNodes bucket
+
+    already_have = maybe False (const True) $ PSQ.lookup (coerce info) (bktNodes bucket)
+
+    map_ns f = bucket { bktNodes = f (bktNodes bucket) }
+    -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) }
+
+updateBucketForPingResult :: (Applicative f, Reifies s (Compare a)) =>
+                            a -> Bool -> Bucket s a -> f ([(a, Maybe (Timestamp, a))], Bucket s a)
+updateBucketForPingResult bad_node got_response bucket
+    = pure ( map (,Nothing) forgotten
+             ++ map (second Just) replacements
+           , Bucket (foldr replace
+                           (bktNodes bucket)
+                           replacements)
+                    popped
+           )
+ where
+    (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket)
+
+    -- Dropped from accepted, replaced by pending.
+    replacements | got_response     = [] -- Timestamp was already updated by TryInsert.
+                 | Just info <- top = do
+                                         -- Insert only if there's a removal.
+                                         _ <- maybeToList $ PSQ.lookup (coerce bad_node) (bktNodes bucket)
+                                         return (bad_node, info)
+                 | otherwise        = []
+
+    -- Dropped from the pending queue without replacing.
+    forgotten | got_response = maybeToList $ fmap snd top
+              | otherwise    = []
+
+
+    replace (bad_node, (tm, info)) =
+                 PSQ.insert (coerce info) tm
+                 . PSQ.delete (coerce bad_node)
+
+
+updateStamps :: PSQKey ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp
+updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
+
+type BitIx = Word
+
+partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b)
+partitionQ imp test q0 = do
+    pass0 <- emptyQueue imp
+    fail0 <- emptyQueue imp
+    let flipfix a b f = fix f a b
+    flipfix q0 (pass0,fail0) $ \rec q qs -> do
+        (mb,q') <- popFront imp q
+        case mb of
+            Nothing -> return qs
+            Just e  -> do qs' <- select (pushBack imp e) qs
+                          rec q' qs'
+                where
+                    select :: Functor f => (b -> f b) -> (b, b) -> f (b, b)
+                    select f = if test e then \(a,b) -> flip (,) b <$> f a
+                                         else \(a,b) ->      (,) a <$> f b
+
+
+
+split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+    forall ni s. ( Reifies s (Compare ni) ) =>
+    (ni -> Word -> Bool)
+    -> BitIx -> Bucket s ni -> (Bucket s ni, Bucket s ni)
+split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs)
+  where
+    (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . coerce . key) . PSQ.toList $ bktNodes b
+    (qs,rs) = runIdentity $ partitionQ bucketQ (spanBit . snd) $ bktQ b
+
+    spanBit :: ni -> Bool
+    spanBit entry = testNodeIdBit entry i
+
+
+{-----------------------------------------------------------------------
+--  BucketList
+-----------------------------------------------------------------------}
+
+defaultBucketCount :: Int
+defaultBucketCount = 20
+
+defaultMaxBucketCount :: Word
+defaultMaxBucketCount = 24
+
+data Info ni nid = Info
+    { myBuckets :: BucketList ni
+    , myNodeId :: nid
+    , myAddress :: SockAddr
+    }
+ deriving Generic
+
+deriving instance (Eq ni, Eq nid) => Eq (Info ni nid)
+deriving instance (Show ni, Show nid) => Show (Info ni nid)
+
+-- instance (Eq ip, Serialize ip) => Serialize (Info ip)
+
+-- | The routing table covers the entire 'NodeId' space from 0 to 2 ^
+-- 160. The routing table is subdivided into 'Bucket's that each cover
+-- a portion of the space. An empty table has one bucket with an ID
+-- space range of @min = 0, max = 2 ^ 160@. When a node with ID \"N\"
+-- is inserted into the table, it is placed within the bucket that has
+-- @min <= N < max@. An empty table has only one bucket so any node
+-- must fit within it. Each bucket can only hold 'K' nodes, currently
+-- eight, before becoming 'Full'. When a bucket is full of known good
+-- nodes, no more nodes may be added unless our own 'NodeId' falls
+-- within the range of the 'Bucket'. In that case, the bucket is
+-- replaced by two new buckets each with half the range of the old
+-- bucket and the nodes from the old bucket are distributed among the
+-- two new ones. For a new table with only one bucket, the full bucket
+-- is always split into two new buckets covering the ranges @0..2 ^
+-- 159@ and @2 ^ 159..2 ^ 160@.
+--
+data BucketList ni = forall s. Reifies s (Compare ni) =>
+    BucketList { thisNode :: !ni
+                 -- | Non-empty list of buckets.
+               , buckets :: [Bucket s ni]
+               }
+
+mapTable :: (b -> t) -> (t -> b) -> BucketList t -> BucketList b
+mapTable g f tbl@(BucketList self bkts) = reify (contramapC g $ bucketCompare bkts)
+    $ \p -> BucketList
+        { thisNode = f self
+        , buckets = map (resolve p . mapBucket f) bkts
+        }
+ where
+    resolve :: Proxy s -> Bucket s ni -> Bucket s ni
+    resolve = const id
+
+instance (Eq ni) => Eq (BucketList ni) where
+  (==) = (==) `on` Network.Kademlia.Routing.toList
+
+#if 0
+
+instance Serialize NominalDiffTime where
+  put = putWord32be . fromIntegral   . fromEnum
+  get = (toEnum     . fromIntegral) <$> getWord32be
+
+#endif
+
+#if CAN_SHOW_BUCKET
+deriving instance (Show ni) => Show (BucketList ni)
+#else
+instance Show ni => Show (BucketList ni) where
+    showsPrec d (BucketList self bkts) =
+        mappend "BucketList "
+        . showsPrec (d+1) self
+        . mappend " (fromList "
+        . showsPrec (d+1) (L.map (L.map tableEntry . PSQ.toList . bktNodes) $ bkts)
+        . mappend ") "
+#endif
+
+#if 0
+
+-- | Normally, routing table should be saved between invocations of
+-- the client software. Note that you don't need to store /this/
+-- 'NodeId' since it is already included in routing table.
+instance (Eq ip, Serialize ip, Ord (NodeId), Serialize (NodeId), Serialize u) => Serialize (BucketList)
+
+#endif
+
+-- | Shape of the table.
+instance Pretty (BucketList ni) where
+  pPrint t
+    | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
+    |    otherwise    = brackets $
+      PP.int (L.sum    ss) <> " nodes, " <>
+      PP.int bucketCount   <> " buckets"
+    where
+      bucketCount = L.length ss
+      ss = shape t
+
+-- | Empty table with specified /spine/ node id.
+--
+-- XXX: The comparison function argument is awkward here.
+nullTable :: (ni -> ni -> Ordering) -> (Int -> ni -> Int) -> ni -> Int -> BucketList ni
+nullTable cmp hsh ni n =
+    reify (Compare cmp hsh)
+        $ \p -> BucketList
+                    ni
+                    [Bucket (empty p) (runIdentity $ emptyQueue bucketQ)]
+  where
+    empty :: Reifies s (Compare ni) => Proxy s -> PSQ (Ordered s ni) Timestamp
+    empty = const $ PSQ.empty
+
+#if 0
+
+-- | Test if table is empty. In this case DHT should start
+-- bootstrapping process until table becomes 'full'.
+null :: BucketList -> Bool
+null (Tip _ _ b) = PSQ.null $ bktNodes b
+null  _          = False
+
+-- | Test if table have maximum number of nodes. No more nodes can be
+-- 'insert'ed, except old ones becomes bad.
+full :: BucketList -> Bool
+full (Tip  _ n _) = n == 0
+full (Zero   t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t
+full (One    b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t
+
+-- | Get the /spine/ node id.
+thisId :: BucketList -> NodeId
+thisId (Tip  nid _ _) = nid
+thisId (Zero table _) = thisId table
+thisId (One _  table) = thisId table
+
+-- | Number of nodes in a bucket or a table.
+type NodeCount   = Int
+
+#endif
+
+-- | Internally, routing table is similar to list of buckets or a
+-- /matrix/ of nodes. This function returns the shape of the matrix.
+shape :: BucketList ni -> [Int]
+shape (BucketList _ tbl) = map (PSQ.size . bktNodes) tbl
+
+#if 0
+
+-- | Get number of nodes in the table.
+size :: BucketList -> NodeCount
+size = L.sum . shape
+
+-- | Get number of buckets in the table.
+depth :: BucketList -> BucketCount
+depth = L.length . shape
+
+#endif
+
+lookupBucket :: forall ni nid x.
+                ( -- FiniteBits nid
+                 Ord nid
+                ) => KademliaSpace nid ni -> nid -> (forall s. Reifies s (Compare ni) => [Bucket s ni] -> x) -> BucketList ni -> x
+lookupBucket space nid kont (BucketList self bkts) = kont $ go 0 [] bkts
+  where
+    d = kademliaXor space nid (kademliaLocation space self)
+
+    go :: Word -> [Bucket s ni] -> [Bucket s ni] -> [Bucket s ni]
+    go i bs (bucket : buckets)
+      |  kademliaTestBit space d i = bucket : buckets ++ bs
+      |     otherwise              = go (succ i) (bucket:bs) buckets
+    go _ bs []         = bs
+
+bucketNumber :: forall ni nid.
+                KademliaSpace nid ni -> nid -> BucketList ni -> Int
+bucketNumber space nid (BucketList self bkts) = fromIntegral $ go 0 bkts
+  where
+    d = kademliaXor space nid (kademliaLocation space self)
+
+    go :: Word -> [Bucket s ni] -> Word
+    go i (bucket : buckets)
+      |  kademliaTestBit space d i = i
+      |     otherwise              = go (succ i) buckets
+    go i []                        = i
+
+
+compatibleNodeId :: forall ni nid.
+                    ( Serialize nid, FiniteBits nid) =>
+                    (ni -> nid) -> BucketList ni -> IO nid
+compatibleNodeId nodeId tbl = genBucketSample prefix br
+ where
+    br = bucketRange (L.length (shape tbl) - 1) True
+    nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
+    bs = BS.pack $ take nodeIdSize $ tablePrefix (testIdBit . nodeId) tbl ++ repeat 0
+    prefix = either error id $ S.decode bs
+
+tablePrefix :: (ni -> Word -> Bool) -> BucketList ni -> [Word8]
+tablePrefix testbit = map (packByte . take 8 . (++repeat False))
+                      . chunksOf 8
+                      . tableBits testbit
+ where
+    packByte = foldl1' (.|.) . zipWith bitmask [7,6 .. 0]
+    bitmask ix True = bit ix
+    bitmask _  _    = 0
+
+tableBits :: (ni -> Word -> Bool) -> BucketList ni -> [Bool]
+tableBits testbit (BucketList self bkts) =
+    zipWith const (map (testbit self) [0..])
+                  bkts
+
+selfNode :: BucketList ni -> ni
+selfNode (BucketList self _) = self
+
+chunksOf :: Int -> [e] -> [[e]]
+chunksOf i ls = map (take i) (build (splitter ls)) where
+  splitter :: [e] -> ([e] -> a -> a) -> a -> a
+  splitter [] _ n = n
+  splitter l c n  = l `c` splitter (drop i l) c n
+
+build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
+build g = g (:) []
+
+
+
+-- | Count of closest nodes in find_node reply.
+type K = Int
+
+-- | Default 'K' is equal to 'defaultBucketSize'.
+defaultK :: K
+defaultK = 8
+
+#if 0
+class TableKey dht k where
+  toNodeId :: k -> NodeId
+
+instance TableKey dht (NodeId) where
+  toNodeId = id
+
+#endif
+
+-- | In Kademlia, the distance metric is XOR and the result is
+-- interpreted as an unsigned integer.
+newtype NodeDistance nodeid = NodeDistance nodeid
+  deriving (Eq, Ord)
+
+-- | distance(A,B) = |A xor B| Smaller values are closer.
+distance :: Bits nid => nid -> nid -> NodeDistance nid
+distance a b = NodeDistance $ xor a b
+
+-- | Order by closeness: nearest nodes first.
+rank :: ( Ord nid
+        ) => KademliaSpace nid ni -> nid -> [ni] -> [ni]
+rank space nid = L.sortBy (comparing (kademliaXor space nid . kademliaLocation space))
+
+
+-- | Get a list of /K/ closest nodes using XOR metric. Used in
+-- 'find_node' and 'get_peers' queries.
+kclosest :: ( -- FiniteBits nid
+             Ord nid
+            ) =>
+            KademliaSpace nid ni -> Int -> nid -> BucketList ni -> [ni]
+kclosest space k nid tbl = take k $ rank space nid (L.concat bucket)
+                              ++ rank space nid (L.concat everyone)
+ where
+    (bucket,everyone) =
+        L.splitAt 1
+        . lookupBucket space nid (L.map (coerce . L.map PSQ.key . PSQ.toList . bktNodes))
+        $ tbl
+
+
+
+{-----------------------------------------------------------------------
+--  Routing
+-----------------------------------------------------------------------}
+
+splitTip :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+            ( Reifies s (Compare ni) ) =>
+            (ni -> Word -> Bool)
+            -> ni -> BitIx -> Bucket s ni -> [ Bucket s ni ]
+splitTip testNodeBit ni i bucket
+  | testNodeBit ni i = [zeros , ones ]
+  |    otherwise     = [ones , zeros ]
+  where
+    (ones, zeros) = split testNodeBit i bucket
+
+-- | Used in each query.
+--
+-- TODO: Kademlia non-empty subtrees should should split if they have less than
+-- k nodes in them.  Which subtrees I mean is illustrated in Fig 1. of Kademlia
+-- paper.  The rule requiring additional splits is in section 2.4.
+modifyBucket
+  :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+    forall ni nid xs.
+    KademliaSpace nid ni
+    -> nid -> (forall s. Reifies s (Compare ni) => Bucket s ni -> Maybe (xs, Bucket s ni)) -> BucketList ni -> Maybe (xs,BucketList ni)
+modifyBucket space nid f (BucketList self bkts)
+    = second (BucketList self) <$> go (0 :: BitIx) bkts
+  where
+    d = kademliaXor space nid (kademliaLocation space self)
+
+    -- go :: BitIx -> [Bucket s ni] -> Maybe (xs, [Bucket s ni])
+
+    go !i (bucket : buckets@(_:_))
+      | kademliaTestBit space d i = second (: buckets) <$> f bucket
+      |       otherwise           = second (bucket :)  <$> go (succ i) buckets
+
+    go !i [bucket] = second (: []) <$> f bucket <|> gosplit
+     where
+        gosplit | i < defaultMaxBucketCount = go i (splitTip ( kademliaTestBit space
+                                                             . kademliaLocation space )
+                                                             self
+                                                             i
+                                                             bucket)
+                | otherwise = Nothing -- Limit the number of buckets.
+
+
+bktCount :: BucketList ni -> Int
+bktCount (BucketList _ bkts) = L.length bkts
+
+-- | Triggering event for atomic table update
+data Event ni = TryInsert  { foreignNode :: ni }
+              | PingResult { foreignNode :: ni , ponged :: Bool }
+
+#if 0
+deriving instance Eq (NodeId) => Eq (Event)
+deriving instance ( Show ip
+                  , Show (NodeId)
+                  , Show u
+                  ) => Show (Event)
+
+#endif
+
+eventId :: (ni -> nid) -> Event ni -> nid
+eventId nodeId (TryInsert ni)    = nodeId ni
+eventId nodeId (PingResult ni _) = nodeId ni
+
+
+-- | Actions requested by atomic table update
+data CheckPing ni = CheckPing [ni]
+
+#if 0
+
+deriving instance Eq (NodeId) => Eq (CheckPing)
+deriving instance ( Show ip
+                  , Show (NodeId)
+                  , Show u
+                  ) => Show (CheckPing)
+
+#endif
+
+
+-- | Call on every inbound packet (including requested ping results).
+-- Returns a triple (was_inserted, to_ping, tbl') where
+--
+--  [ /was_inserted/ ] True if the node was added to the routing table.
+--
+--  [ /to_ping/ ]      A list of nodes to ping and then run 'updateForPingResult'.
+--                     This will be empty if /was_inserted/, but a non-inserted node
+--                     may be added to a replacement queue and will be inserted if
+--                     one of the items in this list time out.
+--
+--  [ /tbl'/ ]         The updated routing 'BucketList'.
+--
+updateForInbound ::
+    KademliaSpace nid ni
+    -> Timestamp -> ni -> BucketList ni -> (Bool, [ni], BucketList ni)
+updateForInbound space tm ni tbl@(BucketList _ bkts) =
+    maybe (False, [],tbl) (\(ps,tbl') -> (True, ps, tbl'))
+                   $ modifyBucket space
+                                   (kademliaLocation space ni)
+                                   (updateBucketForInbound tm ni)
+                                   tbl
+
+-- | Update the routing table with the results of a ping.
+--
+-- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the
+-- routing table and the  node /b/, with timestamp /tm/, has taken its place.
+updateForPingResult ::
+    KademliaSpace nid ni
+    -> ni            -- ^ The pinged node.
+    -> Bool          -- ^ True if we got a reply, False if it timed out.
+    -> BucketList ni -- ^ The routing table.
+    -> ( [(ni,Maybe (Timestamp, ni))], BucketList ni )
+updateForPingResult space ni got_reply tbl =
+    fromMaybe ([],tbl)
+                   $ modifyBucket space
+                                  (kademliaLocation space ni)
+                                  (updateBucketForPingResult ni got_reply)
+                                  tbl
+
+
+{-----------------------------------------------------------------------
+--  Conversion
+-----------------------------------------------------------------------}
+
+type TableEntry ni = (ni, Timestamp)
+
+tableEntry :: NodeEntry ni -> TableEntry ni
+tableEntry (a :-> b) = (a, b)
+
+toList :: BucketList ni -> [[TableEntry ni]]
+toList (BucketList _ bkts) = coerce $ L.map (L.map tableEntry . PSQ.toList . bktNodes) bkts
+
+data KademliaSpace nid ni = KademliaSpace
+    { -- | Given a node record (probably including IP address), yields a
+      -- kademlia xor-metric location.
+      kademliaLocation :: ni -> nid
+      -- | Used when comparing locations.  This is similar to
+      -- 'Data.Bits.testBit' except that the ordering of bits is reversed, so
+      -- that 0 is the most significant bit.
+    , kademliaTestBit :: nid -> Word -> Bool
+      -- | The Kademlia xor-metric.
+    , kademliaXor :: nid -> nid -> nid
+
+    , kademliaSample :: forall m. Applicative m => (Int -> m BS.ByteString) -> nid -> (Int,Word8,Word8) -> m nid
+    }
+
+instance Contravariant (KademliaSpace nid) where
+    contramap f ks = ks
+        { kademliaLocation = kademliaLocation ks . f
+        }
+
diff --git a/src/Network/Kademlia/Search.hs b/src/Network/Kademlia/Search.hs
new file mode 100644
index 00000000..593470c3
--- /dev/null
+++ b/src/Network/Kademlia/Search.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+module Network.Kademlia.Search where
+
+import Control.Concurrent.Tasks
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Data.Bool
+import Data.Function
+import Data.List
+import qualified Data.Map.Strict     as Map
+         ;import Data.Map.Strict     (Map)
+import Data.Maybe
+import qualified Data.Set            as Set
+         ;import Data.Set            (Set)
+import Data.Hashable                 (Hashable(..)) -- for type sigs
+import System.IO
+import System.IO.Error
+
+import qualified Data.MinMaxPSQ   as MM
+         ;import Data.MinMaxPSQ   (MinMaxPSQ, MinMaxPSQ')
+import qualified Data.Wrapper.PSQ as PSQ
+         ;import Data.Wrapper.PSQ (pattern (:->), Binding, pattern Binding, Binding', PSQ, PSQKey)
+import Network.Address hiding (NodeId)
+import Network.Kademlia.Routing as R
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+data Search nid addr tok ni r = Search
+    { searchSpace        :: KademliaSpace nid ni
+    , searchNodeAddress  :: ni -> addr
+    , searchQuery        :: nid -> ni -> IO (Maybe ([ni], [r], Maybe tok))
+    }
+
+data SearchState nid addr tok ni r = SearchState
+    {-
+    { searchParams :: Search nid addr ni r
+
+    , searchTarget       :: nid
+      -- | This action will be performed at least once on each search result.
+      -- It may be invoked multiple times since different nodes may report the
+      -- same result.  If the action returns 'False', the search will be
+      -- aborted, otherwise it will continue until it is decided that we've
+      -- asked the closest K nodes to the target.
+    , searchResult      :: r -> STM Bool
+
+    -}
+
+    { -- | The number of pending queries.  Incremented before any query is sent
+      -- and decremented when we get a reply.
+      searchPendingCount :: TVar Int
+      -- | Nodes scheduled to be queried.
+    , searchQueued       :: TVar (MinMaxPSQ ni nid)
+      -- | The nearest (K - α) nodes that issued a reply.
+    , searchInformant    :: TVar (MinMaxPSQ' ni nid (Maybe tok))
+      -- | This tracks already-queried addresses so we avoid bothering them
+      -- again. XXX: We could probably keep only the pending queries in this
+      -- set.  It also can be a bounded 'MinMaxPSQ', although searchAlpha
+      -- should limit the number of outstanding queries.
+    , searchVisited      :: TVar (Set addr)
+    }
+
+newSearch :: ( Ord addr
+             , PSQKey nid
+             , PSQKey ni
+             ) =>
+             {-
+             KademliaSpace nid ni
+             -> (ni -> addr)
+             -> (ni -> IO ([ni], [r])) -- the query action.
+             -> (r -> STM Bool)        -- receives search results.
+             -> nid                    -- target of search
+             -}
+             Search nid addr tok ni r
+             -> nid
+             -> [ni]                   -- Initial nodes to query.
+             -> STM (SearchState nid addr tok ni r)
+newSearch (Search space nAddr qry) target ns = do
+    c <- newTVar 0
+    q <- newTVar $ MM.fromList
+                 $ map (\n -> n :-> kademliaXor space target (kademliaLocation space n))
+                 $ ns
+    i <- newTVar MM.empty
+    v <- newTVar Set.empty
+    return -- (Search space nAddr qry) , r , target
+           ( SearchState c q i v )
+
+-- | Discard a value from a key-priority-value tuple. This is useful for
+-- swaping items from a "MinMaxPSQ'" to a "MinMaxPSQ".
+stripValue :: Binding' k p v -> Binding k p
+stripValue (Binding ni _ nid) = (ni :-> nid)
+
+-- | Reset a 'SearchState' object to ready it for a repeated search.
+reset :: (Ord ni, Ord nid, Hashable ni, Hashable nid) =>
+       TVar (BucketList ni)
+       -> Search nid addr1 tok1 ni r1
+       -> nid
+       -> SearchState nid addr tok ni r
+       -> STM (SearchState nid addr tok ni r)
+reset bkts qsearch target st = do
+    searchIsFinished st >>= check -- Wait for a search to finish before resetting.
+    bktNodes <- map (\ni -> ni :-> kademliaLocation (searchSpace qsearch) ni)
+                . R.kclosest (searchSpace qsearch) searchK target
+                <$> readTVar bkts
+    priorInformants <- map stripValue . MM.toList <$> readTVar (searchInformant  st)
+    writeTVar (searchQueued       st) $ MM.fromList $ priorInformants ++ bktNodes
+    writeTVar (searchInformant    st) MM.empty
+    writeTVar (searchVisited      st) Set.empty
+    writeTVar (searchPendingCount st) 0
+    return st
+
+searchAlpha :: Int
+searchAlpha = 8
+
+-- | 'searchK' should be larger than 'searchAlpha'.  How much larger depends on
+-- how fast the queries are.  For Tox's much slower onion-routed queries, we
+-- need to ensure that closer non-responding queries don't completely push out
+-- farther away queries.
+--
+-- For BitTorrent, setting them both 8 was not an issue, but that is no longer
+-- supported because now the number of remembered informants is now the
+-- difference between these two numbers.  So, if searchK = 16 and searchAlpha =
+-- 4, then the number of remembered query responses is 12.
+searchK :: Int
+searchK = 16
+
+sendQuery :: forall addr nid tok ni r.
+            ( Ord addr
+            , PSQKey nid
+            , PSQKey ni
+            , Show nid
+            ) =>
+            Search nid addr tok ni r
+            -> nid
+            -> (r -> STM Bool) -- ^ return False to terminate the search.
+            -> SearchState nid addr tok ni r
+            -> Binding ni nid
+            -> IO ()
+sendQuery Search{..} searchTarget searchResult sch@SearchState{..} (ni :-> d) = do
+    myThreadId >>= flip labelThread ("searchQuery." ++ show searchTarget)
+    reply <- searchQuery searchTarget ni `catchIOError` const (return Nothing)
+    -- (ns,rs)
+    let tok = error "TODO: token"
+    atomically $ do
+        modifyTVar searchPendingCount pred
+        maybe (return ()) go reply
+ where
+    go (ns,rs,tok) = do
+        vs <- readTVar searchVisited
+        -- We only queue a node if it is not yet visited
+        let insertFoundNode :: Int
+                           -> ni
+                           -> MinMaxPSQ ni nid
+                           -> MinMaxPSQ ni nid
+            insertFoundNode k n q
+             | searchNodeAddress n `Set.member` vs
+                         = q
+             | otherwise = MM.insertTake k n ( kademliaXor searchSpace searchTarget
+                                               $ kademliaLocation searchSpace n )
+                                                   q
+        qsize0 <- MM.size <$> readTVar searchQueued
+        let qsize = if qsize0 < searchK then searchK else qsize0
+        modifyTVar searchQueued    $ \q -> foldr (insertFoundNode qsize) q ns
+        modifyTVar searchInformant $ MM.insertTake' (searchK - searchAlpha) ni tok d
+        flip fix rs $ \loop -> \case
+            r:rs' -> do
+                wanting <- searchResult r
+                if wanting then loop rs'
+                           else searchCancel sch
+            [] -> return ()
+
+
+searchIsFinished :: ( PSQKey nid
+                    , PSQKey ni
+                    ) => SearchState nid addr tok ni r -> STM Bool
+searchIsFinished SearchState{ ..} = do
+    q <- readTVar searchQueued
+    cnt <- readTVar searchPendingCount
+    informants <- readTVar searchInformant
+    return $ cnt == 0
+             && ( MM.null q
+                  || ( MM.size informants >= (searchK - searchAlpha)
+                       && ( PSQ.prio (fromJust $ MM.findMax informants)
+                            <= PSQ.prio (fromJust $ MM.findMin q))))
+
+searchCancel :: SearchState nid addr tok ni r -> STM ()
+searchCancel SearchState{..} = do
+    writeTVar searchPendingCount 0
+    writeTVar searchQueued MM.empty
+
+search ::
+    ( Ord r
+    , Ord addr
+    , PSQKey nid
+    , PSQKey ni
+    , Show nid
+    ) => Search nid addr tok ni r -> R.BucketList ni -> nid -> (r -> STM Bool) -> IO (SearchState nid addr tok ni r)
+search sch buckets target result = do
+    let ns = R.kclosest (searchSpace sch) searchK target buckets
+    st <- atomically $ newSearch sch target ns
+    fork $ searchLoop sch target result st
+    return st
+
+searchLoop :: ( Ord addr, Ord nid, Ord ni, Show nid, Hashable nid, Hashable ni )
+           => Search nid addr tok ni r      -- ^ Query and distance methods.
+           -> nid                           -- ^ The target we are searching for.
+           -> (r -> STM Bool)               -- ^ Invoked on each result.  Return False to quit searching.
+           -> SearchState nid addr tok ni r -- ^ Search-related state.
+           -> IO ()
+searchLoop sch@Search{..} target result s@SearchState{..} = do
+    myThreadId >>= flip labelThread ("search."++show target)
+    withTaskGroup ("search.g."++show target) searchAlpha $ \g -> fix $ \again -> do
+        join $ atomically $ do
+            cnt <- readTVar $ searchPendingCount
+            informants <- readTVar searchInformant
+            found <- MM.minView <$> readTVar searchQueued
+            case found of
+                Just (ni :-> d, q)
+                  | -- If there's fewer than /k/ informants and there's any
+                    -- node we haven't yet got a response from.
+                    (MM.size informants < searchK - searchAlpha) && (cnt > 0 || not (MM.null q))
+                    -- Or there's no informants yet at all.
+                    || MM.null informants
+                    -- Or if the closest scheduled node is nearer than the
+                    -- nearest /k/ informants.
+                    || (d < PSQ.prio (fromJust $ MM.findMax informants))
+                  -> -- Then the search continues, send a query.
+                     do writeTVar searchQueued q
+                        modifyTVar searchVisited $ Set.insert (searchNodeAddress ni)
+                        modifyTVar searchPendingCount succ
+                        return $ do
+                            forkTask g
+                                     "searchQuery"
+                                     $ sendQuery sch target result s (ni :-> d)
+                            again
+                _ -> -- Otherwise, we are finished.
+                     do check (cnt == 0)
+                        return $ return ()
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
new file mode 100644
index 00000000..0345dd88
--- /dev/null
+++ b/src/Network/QueryResponse.hs
@@ -0,0 +1,549 @@
+-- | 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.Function
+import Data.Functor.Contravariant
+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.Word
+import Data.Maybe
+import Data.Typeable
+import Network.Socket
+import Network.Socket.ByteString    as B
+import System.Endian
+import System.IO
+import System.IO.Error
+import System.Timeout
+
+-- | Three methods are required to implement a datagram based query\/response protocol.
+data Transport err addr x = Transport
+    { -- | Blocks until an inbound packet is available. Returns 'Nothing' when
+      -- no more packets are expected due to a shutdown or close event.
+      -- Otherwise, the packet will be parsed as type /x/ and an origin address
+      -- /addr/.  Parse failure is indicated by the type 'err'.
+      awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a
+      -- | Send an /x/ packet to the given destination /addr/.
+    , sendMessage :: addr -> x -> IO ()
+      -- | Shutdown and clean up any state related to this 'Transport'.
+    , closeTransport :: IO ()
+    }
+
+-- | 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.
+        -> (x' -> addr' -> IO (x, addr))
+        -- ^ Function to encode a high-level address/packet into a lower level
+        -- representation.
+        -> Transport err addr x
+        -- ^ The low-level transport to be transformed.
+        -> Transport err addr' x'
+layerTransportM parse encode tr =
+    tr { awaitMessage = \kont ->
+                awaitMessage tr $ \m -> mapM (mapM $ uncurry parse) m >>= kont . fmap join
+       , 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.
+        -> (x' -> addr' -> (x, addr))
+        -- ^ Function to encode a high-level address/packet into a lower level
+        -- representation.
+        -> Transport err addr x
+        -- ^ The low-level transport to be transformed.
+        -> Transport err addr' x'
+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: An 'MVar'
+-- 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))
+                      -> ((x,xaddr) -> Maybe (b,a))
+                      -> Transport err a b
+                      -> IO (Transport err xaddr x, Transport err a b)
+partitionTransport parse encodex tr =
+    partitionTransportM (return . parse) (return . encodex) tr
+
+-- | Paritions a 'Transport' into two higher-level transports.  Note: An 'MVar'
+-- 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)))
+                      -> ((x,xaddr) -> IO (Maybe (b,a)))
+                      -> Transport err a b
+                      -> IO (Transport err xaddr x, Transport err a b)
+partitionTransportM parse encodex tr = do
+    mvar <- newEmptyMVar
+    let xtr = tr { awaitMessage = \kont -> fix $ \again -> do
+                    awaitMessage tr $ \m -> case m of
+                        Just (Right msg) -> parse msg >>=
+                                                either (kont . Just . Right)
+                                                       (\y -> putMVar mvar y >> again)
+                        Just (Left e)    -> kont $ Just (Left e)
+                        Nothing          -> kont Nothing
+                 , sendMessage = \addr' msg' -> do
+                    msg_addr <- encodex (msg',addr')
+                    mapM_ (uncurry . flip $ sendMessage tr) msg_addr
+                 }
+        ytr = Transport
+                { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right
+                , sendMessage = sendMessage tr
+                , closeTransport = return ()
+                }
+    return (xtr, ytr)
+
+-- |
+--      * 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
+addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x
+addHandler onParseError f tr = tr
+    { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \m -> do
+        case m of
+            Just (Right (x, addr)) -> f addr x >>= maybe eat (kont . Just . Right . (, addr) . ($ x))
+            Just (Left  e        ) -> onParseError e >> kont (Just $ Left e)
+            Nothing                -> kont $ Nothing
+    }
+
+-- | 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
+    thread_id <- forkIO $ do
+        myThreadId >>= flip labelThread ("listener."++name)
+        fix $ awaitMessage client . const
+    return $ do
+        closeTransport client
+        killThread thread_id
+
+-- | 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 (Client net d err pending whoami _) meth q addr0 = do
+    mvar <- newEmptyMVar
+    (tid,addr,expiry) <- atomically $ do
+        tbl <- readTVar pending
+        (tid, tbl') <- dispatchRegister (tableMethods d) mvar addr0 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)
+               timeout expiry $ takeMVar mvar
+            `catchIOError` (\e -> return Nothing)
+    case mres of
+        Just x -> return $ Just $ unwrapResponse meth x
+        Nothing -> do
+            atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending
+            reportTimeout err (method meth) tid addr
+            return Nothing
+
+-- * Implementing a query\/response 'Client'.
+
+-- | All inputs required to implement a query\/response client.
+data Client err meth tid addr x = forall tbl. Client
+    { -- | The 'Transport' used to dispatch and receive packets.
+      clientNet :: Transport err addr x
+      -- | Methods for handling inbound packets.
+    , clientDispatcher :: DispatchMethods tbl err meth tid addr x
+      -- | 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
+    }
+
+-- | 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_.
+data MethodHandler err tid addr x = 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 -> x
+      -- | Fully typed action to perform upon the query.  The remote origin
+      -- address of the query is provided to the handler.
+    , 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 ()
+    }
+
+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)
+
+
+-- | 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 :: MethodHandler err tid addr x -- ^ 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 x))
+dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr =
+    fmap (\a -> Just . wrapR tid self addr <$> f addr a) $ unwrapQ x
+dispatchQuery (NoReply unwrapQ f) tid self x addr =
+    fmap (\a -> f addr a >> return Nothing) $ unwrapQ x
+
+-- | 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 MethodSerializer tid addr x 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 :: tid -> 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 :: x -> b
+    }
+
+
+-- | 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 tid addr x = TransactionMethods
+    {
+      -- | Before a query is sent, this function stores an 'MVar' to which the
+      -- response will be written too.  The returned /tid/ is a transaction id
+      -- that can be used to forget the 'MVar' if the remote peer is not
+      -- responding.
+      dispatchRegister :: MVar x -> addr -> d -> STM (tid, d)
+      -- | This method is invoked when an incoming packet /x/ indicates it is
+      -- a response to the transaction with id /tid/.  The returned IO action
+      -- will write the packet to the correct 'MVar' thus completing the
+      -- dispatch.
+    , dispatchResponse :: tid -> x -> d -> STM (d, IO ())
+      -- | When a timeout interval elapses, this method is called to remove the
+      -- transaction from the table.
+    , dispatchCancel :: tid -> d -> STM d
+    }
+
+-- | The standard lookup table methods for use as input to 'transactionMethods'
+-- in lieu of directly implementing 'TransactionMethods'.
+data TableMethods t tid = TableMethods
+    { -- | Insert a new /tid/ entry into the transaction table.
+      tblInsert :: forall a. tid -> a -> 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
+    }
+
+-- | Methods for using 'Data.IntMap'.
+intMapMethods :: TableMethods IntMap Int
+intMapMethods = TableMethods IntMap.insert IntMap.delete IntMap.lookup
+
+-- | Methods for using 'Data.Word64Map'.
+w64MapMethods :: TableMethods Word64Map Word64
+w64MapMethods = TableMethods W64Map.insert W64Map.delete W64Map.lookup
+
+-- | Methods for using 'Data.Map'
+mapMethods :: Ord tid => TableMethods (Map tid) tid
+mapMethods = TableMethods Map.insert Map.delete Map.lookup
+
+-- | 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 v t -> ins (f k) v t)
+                     (\k t   -> del (f k) t)
+                     (\k t   -> lookup (f k) t)
+
+-- | 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 (MVar x)) tid addr x
+transactionMethods (TableMethods insert delete lookup) generate = TransactionMethods
+    { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
+    , dispatchRegister = \v _ (g,t) ->
+        let (tid,g') = generate g
+            t' = insert tid v t
+        in 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 $ tryPutMVar v x)
+            Nothing -> return ((g,t), return ())
+    }
+
+-- | A set of methods necessary for dispatching incoming packets.
+data DispatchMethods tbl err meth tid addr x = 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 (MethodHandler err tid addr x)
+      -- | Methods for handling incoming responses.
+    , tableMethods :: TransactionMethods tbl tid addr x
+    }
+
+-- | 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 ()
+      -- | Outgoing: remote peer is not responding.
+    , reportTimeout :: meth -> tid -> addr -> IO ()
+    }
+
+ignoreErrors :: ErrorReporter addr x meth tid err
+ignoreErrors = ErrorReporter
+    { reportParseError = \_ -> return ()
+    , reportMissingHandler = \_ _ _ -> return ()
+    , reportUnknown = \_ _ _ -> return ()
+    , reportTimeout = \_ _ _ -> return ()
+    }
+
+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
+    , reportTimeout = \meth tid addr -> hPutStrLn h $ show addr ++ " --> Timeout ("++show meth++")"
+    }
+
+-- 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 tim)
+        = ErrorReporter (\e -> pe (f e))
+                        mh
+                        (\addr x e -> unk addr x (f e))
+                        tim
+
+-- | 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 ::
+    Client err meth tid addr x
+    -> 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
+sockAddrFamily (SockAddrCan _        ) = AF_CAN
+
+-- | Packets with an empty payload may trigger EOF exception.
+-- 'udpTransport' uses this function to avoid throwing in that
+-- case.
+ignoreEOF :: a -> IOError -> IO a
+ignoreEOF def e | isEOFError e = pure def
+                | otherwise    = 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
+
+-- | 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 :: SockAddr -> IO (Transport err SockAddr ByteString)
+udpTransport bind_address = do
+  let family = sockAddrFamily bind_address
+  sock <- socket family Datagram defaultProtocol
+  when (family == AF_INET6) $ do
+    setSocketOption sock IPv6Only 0
+  bind sock bind_address
+  return Transport
+    { awaitMessage = \kont -> do
+        r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do
+                Just . Right <$!> B.recvFrom sock udpBufferSize
+        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.
+                -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4)
+                saferSendTo sock bs (SockAddrInet port host4)
+            addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr)
+            addr4 -> \bs -> saferSendTo sock bs addr4
+        _ -> \addr bs -> saferSendTo sock bs addr
+    , closeTransport = close sock
+    }
diff --git a/src/Network/SocketLike.hs b/src/Network/SocketLike.hs
new file mode 100644
index 00000000..d533dd7f
--- /dev/null
+++ b/src/Network/SocketLike.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# 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)
+
+-- | 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)
+    -- | See 'NS.socketPort'
+    socketPort    :: sock -> IO PortNumber
+    -- | See 'NS.sIsConnected'
+    --
+    -- __Warning__: Don't rely on this method if it's possible the socket was
+    -- converted into a 'Handle'.
+    sIsConnected  :: sock -> IO Bool
+    -- | See 'NS.sIsBound'
+    sIsBound      :: sock -> IO Bool
+    -- | See 'NS.sIsListening'
+    sIsListening  :: sock -> IO Bool
+    -- | See 'NS.sIsReadable'
+    sIsReadable   :: sock -> IO Bool
+    -- | See 'NS.sIsWritable'
+    sIsWritable   :: sock -> IO Bool
+
+    -- | This is the only exposed write-access method to the
+    -- underlying state.  Usually implemented by 'NS.close'
+    sClose        :: sock -> IO ()
+
+instance SocketLike NS.Socket where
+    getSocketName = NS.getSocketName
+    getPeerName   = NS.getPeerName
+    getPeerCred   = NS.getPeerCred
+    socketPort    = NS.socketPort
+#if MIN_VERSION_network(2,4,0)
+    sIsConnected  = NS.isConnected -- warning: this is always False if the socket
+                                   --          was converted to a Handle
+    sIsBound      = NS.isBound
+    sIsListening  = NS.isListening
+    sIsReadable   = NS.isReadable
+    sIsWritable   = NS.isWritable
+    sClose        = NS.close
+#else
+    sIsConnected  = NS.sIsConnected -- warning: this is always False if the socket
+                                    --          was converted to a Handle
+    sIsBound      = NS.sIsBound
+    sIsListening  = NS.sIsListening
+    sIsReadable   = NS.sIsReadable
+    sIsWritable   = NS.sIsWritable
+    sClose        = NS.sClose
+#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
+    socketPort    (Restricted mb sock) = NS.socketPort sock
+#if MIN_VERSION_network(2,4,0)
+    sIsConnected  (Restricted mb sock) = maybe (NS.isConnected sock) (hIsOpen) mb
+    sIsBound      (Restricted mb sock) = NS.isBound sock
+    sIsListening  (Restricted mb sock) = NS.isListening sock
+    sIsReadable   (Restricted mb sock) = NS.isReadable sock
+    sIsWritable   (Restricted mb sock) = NS.isWritable sock
+    sClose        (Restricted mb sock) = maybe (NS.close sock) (\h -> hClose h >> NS.close sock) mb
+#else
+    sIsConnected  (Restricted mb sock) = maybe (NS.sIsConnected sock) (hIsOpen) mb
+    sIsBound      (Restricted mb sock) = NS.sIsBound sock
+    sIsListening  (Restricted mb sock) = NS.sIsListening sock
+    sIsReadable   (Restricted mb sock) = NS.sIsReadable sock
+    sIsWritable   (Restricted mb sock) = NS.sIsWritable sock
+    sClose        (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb
+#endif
+
+-- | 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/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
new file mode 100644
index 00000000..34b9388e
--- /dev/null
+++ b/src/Network/StreamServer.hs
@@ -0,0 +1,153 @@
+-- | 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
+    , ServerConfig(..)
+    , withSession
+    , quitListening
+    , dummyServerHandle
+    ) where
+
+import Data.Monoid
+import Network.Socket as Socket
+import Data.ByteString.Char8
+    ( hGetNonBlocking
+    )
+import qualified Data.ByteString.Char8 as S
+    ( hPutStrLn
+    )
+import System.Directory (removeFile)
+import System.IO
+    ( IOMode(..)
+    , hSetBuffering
+    , BufferMode(..)
+    , hWaitForInput
+    , hClose
+    , hIsEOF
+    , hPutStrLn
+    , stderr
+    , hFlush
+    )
+import Control.Monad
+import Control.Monad.Fix (fix)
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument (forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId)
+#else
+import GHC.Conc (labelThread)
+import Control.Concurrent (forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId)
+#endif
+import Control.Exception (catch,handle,try,finally)
+import System.IO.Error (tryIOError)
+import System.Mem.Weak
+import System.IO.Error
+
+-- import Data.Conduit
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.ByteString as S (ByteString)
+import System.IO (Handle)
+import Control.Concurrent.MVar (newMVar)
+
+import Network.SocketLike
+
+data ServerHandle = ServerHandle Socket (Weak ThreadId)
+
+
+-- | 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 _) =
+    finally (Socket.getSocketName socket >>= removeSocketFile)
+            (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 = hPutStrLn stderr str >> hFlush stderr
+
+data ServerConfig = ServerConfig
+    { serverWarn    :: String -> IO ()
+    -- ^ Action to report warnings and errors.
+    , serverSession :: RestrictedSocket -> Int -> Handle -> IO ()
+    -- ^ Action to handle interaction with a client
+    }
+
+-- | Initialize a 'ServerConfig' using the provided session handler.
+withSession :: (RestrictedSocket -> 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 incomming 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 addr = do
+    let warn   = serverWarn cfg
+        family = case addr of
+                    SockAddrInet  {} -> AF_INET
+                    SockAddrInet6 {} -> AF_INET6
+                    SockAddrUnix  {} -> AF_UNIX
+    sock <- socket family Stream 0
+    setSocketOption sock ReuseAddr 1
+    fix $ \loop ->
+        tryIOError (removeSocketFile addr) >> bind sock addr
+        `catchIOError` \e -> do warn $ "bind-error: " <> bshow addr <> " " <> bshow e
+                                threadDelay 5000000
+                                loop
+    listen sock maxListenQueue
+    thread <- mkWeakThreadId <=< forkIO $ do
+        myThreadId >>= flip labelThread "StreamServer.acceptLoop"
+        acceptLoop cfg sock 0
+    return (ServerHandle sock thread)
+
+-- | Not exported.  This, combined with 'acceptException' form a mutually recursive
+-- loop that handles incomming 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 <- accept sock
+    let conkey = n + 1
+    h <- socketToHandle (fst con) ReadWriteMode
+    forkIO $ do
+        myThreadId >>= flip labelThread "StreamServer.session"
+        serverSession cfg (restrictHandleSocket h (fst con)) conkey h
+    acceptLoop cfg sock (n + 1)
+
+acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO ()
+acceptException cfg n sock ioerror = do
+    Socket.close sock
+    case show (ioeGetErrorType ioerror) of
+      "resource exhausted" -> do -- try again
+                                 serverWarn cfg $ ("acceptLoop: resource exhasted")
+                                 threadDelay 500000
+                                 acceptLoop cfg sock (n + 1)
+      "invalid argument"   -> do -- quit on closed socket
+                                 return ()
+      message              -> do -- unexpected exception
+                                 serverWarn cfg $ ("acceptLoop: "<>bshow message)
+                                 return ()
+
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
new file mode 100644
index 00000000..37802e3c
--- /dev/null
+++ b/src/Network/Tox.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+module Network.Tox where
+
+import Debug.Trace
+import Control.Exception hiding (Handler)
+import Control.Applicative
+import Control.Arrow
+import Control.Concurrent                     (MVar)
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Fix
+import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
+import qualified Crypto.Cipher.Salsa          as Salsa
+import qualified Crypto.Cipher.XSalsa         as XSalsa
+import Crypto.ECC.Class
+import qualified Crypto.Error                 as Cryptonite
+import Crypto.Error.Types
+import qualified Crypto.MAC.Poly1305          as Poly1305
+import Crypto.PubKey.Curve25519
+import Crypto.PubKey.ECC.Types
+import Crypto.Random
+import qualified Data.Aeson                   as JSON
+         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
+import Data.Bitraversable                     (bisequence)
+import Data.Bits
+import Data.Bits.ByteString                   ()
+import Data.Bool
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               (ByteArrayAccess, Bytes)
+import qualified Data.ByteString              as B
+         ;import Data.ByteString              (ByteString)
+import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Char8        as C8
+import Data.ByteString.Lazy                   (toStrict)
+import Data.Char
+import Data.Data
+import Data.Functor.Contravariant
+import Data.Hashable
+import Data.IP
+import Data.Maybe
+import qualified Data.MinMaxPSQ               as MinMaxPSQ
+         ;import Data.MinMaxPSQ               (MinMaxPSQ')
+import Data.Monoid
+import Data.Ord
+import qualified Data.Serialize               as S
+import Data.Time.Clock.POSIX                  (POSIXTime, getPOSIXTime)
+import Data.Typeable
+import Data.Word
+import qualified Data.Wrapper.PSQ             as PSQ
+         ;import Data.Wrapper.PSQ             (PSQ)
+import qualified Data.Wrapper.PSQInt          as Int
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import GHC.Generics                           (Generic)
+import System.Global6
+import Network.Kademlia
+import Network.Address                        (Address, WantIP (..), either4or6,
+                                               fromSockAddr, ipFamily, setPort,
+                                               sockAddrPort, testIdBit,
+                                               toSockAddr, un4map)
+import Network.Kademlia.Search          (Search (..))
+import qualified Network.Kademlia.Routing          as R
+import Network.QueryResponse
+import Network.Socket
+import System.Endian
+import System.IO
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.Printf
+import Text.Read
+import Control.TriadCommittee
+import Network.BitTorrent.DHT.Token           as Token
+import GHC.TypeLits
+
+import Crypto.Tox
+import Data.Word64Map                        (fitsInInt)
+import qualified Data.Word64Map              (empty)
+import Network.Kademlia.Bootstrap            (forkPollForRefresh, bootstrap)
+import Network.Tox.Crypto.Transport          (NetCrypto)
+import Network.Tox.Crypto.Handlers           (cryptoNetHandler, newSessionsState, defaultUnRecHook, defaultCryptoDataHooks, NetCryptoSessions(..))
+import qualified Network.Tox.DHT.Handlers    as DHT
+import qualified Network.Tox.DHT.Transport   as DHT
+import Network.Tox.NodeId
+import qualified Network.Tox.Onion.Handlers  as Onion
+import qualified Network.Tox.Onion.Transport as Onion
+import Network.Tox.Transport
+import OnionRouter
+import Roster
+import Text.XXD
+
+newCrypto :: IO TransportCrypto
+newCrypto = do
+    secret <- generateSecretKey
+    alias <- generateSecretKey
+    ralias <- generateSecretKey
+    let pubkey    = toPublic secret
+        aliaspub  = toPublic alias
+        raliaspub = toPublic ralias
+    ukeys <- atomically $ newTVar []
+    (symkey, drg) <- do
+        drg0 <- getSystemDRG
+        return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
+    noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
+    cookieKeys <- atomically $ newTVar []
+    cache <- newSecretsCache
+    hPutStrLn stderr $ "secret(tox) = " ++ DHT.showHex secret
+    hPutStrLn stderr $ "public(tox) = " ++ DHT.showHex pubkey
+    hPutStrLn stderr $ "symmetric(tox) = " ++ DHT.showHex symkey
+    return TransportCrypto
+        { transportSecret = secret
+        , transportPublic = pubkey
+        , onionAliasSecret = alias
+        , onionAliasPublic = aliaspub
+        , rendezvousSecret = ralias
+        , rendezvousPublic = raliaspub
+        , transportSymmetric = return $ SymmetricKey symkey
+        , transportNewNonce = do
+            drg1 <- readTVar noncevar
+            let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
+            writeTVar noncevar drg2
+            return nonce
+        , userKeys = ukeys
+        , pendingCookies = cookieKeys
+        , secretsCache = cache
+        }
+
+updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
+updateIP tblvar a = do
+    bkts <- readTVar tblvar
+    case nodeInfo (nodeId (R.thisNode bkts)) a of
+        Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
+        Left _   -> return ()
+
+genNonce24 :: DRG g =>
+              TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
+genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
+    (g,pending) <- readTVar var
+    let (bs, g') = randomBytesGenerate 24 g
+    writeTVar var (g',pending)
+    return $ DHT.TransactionId nonce8 (Nonce24 bs)
+
+
+gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen)
+gen g = let (bs, g')  = randomBytesGenerate 24 g
+            (ws, g'') = randomBytesGenerate 8 g'
+            Right w   = S.runGet S.getWord64be ws
+        in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' )
+
+intKey :: DHT.TransactionId -> Int
+intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w
+
+w64Key :: DHT.TransactionId -> Word64
+w64Key (DHT.TransactionId (Nonce8 w) _) = w
+
+nonceKey :: DHT.TransactionId -> Nonce8
+nonceKey (DHT.TransactionId n _) = n
+
+-- | Return my own address.
+myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
+       -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
+       -> Maybe NodeInfo             -- ^ Interested remote address
+       -> IO NodeInfo
+myAddr routing4 routing6 maddr = atomically $ do
+    let var = case flip DHT.prefer4or6 Nothing <$> maddr of
+                Just Want_IP6 -> routing4
+                _             -> routing6
+    a <- readTVar var
+    return $ R.thisNode a
+
+newClient :: (DRG g, Show addr, Show meth) =>
+              g -> Transport String addr x
+                -> (Client String meth DHT.TransactionId addr x -> x -> MessageClass String meth DHT.TransactionId addr x)
+                -> (Maybe addr -> IO addr)
+                -> (Client String meth DHT.TransactionId addr x -> meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
+                -> (forall d. TransactionMethods d DHT.TransactionId addr x -> TransactionMethods d DHT.TransactionId addr x)
+                -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x)
+                -> IO (Client String meth DHT.TransactionId addr x)
+newClient drg net classify selfAddr handlers modifytbl modifynet = do
+    -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
+    -- Otherwise, use ordinary Map.  The details of which will be hidden by an
+    -- existential closure (see mkclient below).
+    --
+    tblvar <-
+      if fitsInInt (Proxy :: Proxy Word64)
+        then do
+            let intmapT = transactionMethods (contramap intKey intMapMethods) gen
+            intmap_var <- atomically $ newTVar (drg, mempty)
+            return $ Right (intmapT,intmap_var)
+         else do
+            let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen
+            map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
+            return $ Left (word64mapT,map_var)
+    let dispatch tbl var handlers client = DispatchMethods
+                { classifyInbound = classify client
+                , lookupHandler = handlers -- var
+                , tableMethods = modifytbl tbl
+                }
+        eprinter = printErrors stderr
+        mkclient (tbl,var) handlers =
+            let client = Client
+                    { clientNet           = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
+                    , clientDispatcher    = dispatch tbl var (handlers client) client
+                    , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors }
+                    , clientPending       = var
+                    , clientAddress       = selfAddr
+                    , clientResponseId    = genNonce24 var
+                    }
+            in client
+    return $ either mkclient mkclient tblvar handlers
+
+data Tox = Tox
+    { toxDHT :: DHT.Client
+    , toxOnion :: Onion.Client RouteId
+    , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
+    , toxCrypto :: Transport String SockAddr NetCrypto
+    , toxCryptoSessions :: NetCryptoSessions
+    , toxCryptoKeys :: TransportCrypto
+    , toxRouting :: DHT.Routing
+    , toxTokens :: TVar SessionTokens
+    , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
+    , toxOnionRoutes :: OnionRouter
+    , toxRoster :: Roster
+    }
+
+getContactInfo :: Tox -> IO DHT.DHTPublicKey
+getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
+    r4 <- readTVar $ DHT.routing4 toxRouting
+    r6 <- readTVar $ DHT.routing6 toxRouting
+    nonce <- transportNewNonce toxCryptoKeys
+    let self = nodeId n4
+        n4 = R.thisNode r4
+        n6 = R.thisNode r6
+        n4s = R.kclosest DHT.toxSpace 4 self r4
+        n6s = R.kclosest DHT.toxSpace 4 self r6
+        ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
+              ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
+    return $ do
+        timestamp <- round . (* 1000000) <$> getPOSIXTime
+        return DHT.DHTPublicKey
+            { dhtpkNonce = timestamp
+            , dhtpk      = id2key self
+            , dhtpkNodes = DHT.SendNodes $ take 4 ns
+            }
+
+isLocalHost :: SockAddr -> Bool
+isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
+isLocalHost _                       = False
+
+addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
+addVerbosity tr =
+    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
+            forM_ m $ mapM_ $ \(msg,addr) -> do
+                when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
+                    mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x))
+                          $ xxd 0 msg
+            kont m
+       , sendMessage = \addr msg -> do
+            when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
+                mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " <-- " ++ x))
+                      $ xxd 0 msg
+            sendMessage tr addr msg
+       }
+
+newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
+newKeysDatabase =
+    atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty
+
+
+getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r)
+getOnionAlias crypto dhtself remoteNode = atomically $ do
+    ni <- dhtself
+    let alias = case remoteNode of
+            Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _)
+              -> ni { nodeId = key2id uk }
+            _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
+    return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
+
+
+newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox
+newTox keydb addr mbSessionsState suppliedDHTKey = do
+    udp <- {- addVerbosity <$> -} udpTransport addr
+    (crypto0,sessionsState) <- case mbSessionsState of
+                                 Nothing -> do
+                                    crypto <- newCrypto
+                                    sessionsState <- newSessionsState crypto defaultUnRecHook defaultCryptoDataHooks
+                                    return (crypto,sessionsState)
+                                 Just s -> return (transportCrypto s, s)
+
+    let crypto = fromMaybe crypto0 $do
+            k <- suppliedDHTKey
+            return crypto0
+                { transportSecret = k
+                , transportPublic = toPublic k
+                }
+    forM_ suppliedDHTKey $ \k -> do
+        maybe (hPutStrLn stderr "failed to encode suppliedDHTKey")
+              (C8.hPutStrLn stderr . C8.append "Using suppliedDHTKey: ")
+              $ encodeSecret k
+
+    drg <- drgNew
+    let lookupClose _ = return Nothing
+
+    mkrouting <- DHT.newRouting addr crypto updateIP updateIP
+    let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building.
+    orouter <- newOnionRouter ignoreErrors
+    (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
+    let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
+        tbl4 = DHT.routing4 $ mkrouting (error "missing client")
+        tbl6 = DHT.routing6 $ mkrouting (error "missing client")
+    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
+                    $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net
+
+    orouter <- forkRouteBuilder orouter $ \nid ni -> fmap (\(_,ns,_)->ns) <$> DHT.getNodes dhtclient nid ni
+
+    toks <- do
+        nil <- nullSessionTokens
+        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
+    oniondrg <- drgNew
+    let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
+    onionclient <- newClient oniondrg onionnet (const Onion.classify)
+                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient))
+                    (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb)
+                    (hookQueries orouter DHT.transactionKey)
+                    (const id)
+
+    roster <- newRoster
+    return Tox
+        { toxDHT = dhtclient
+        , toxOnion = onionclient
+        , toxToRoute = onInbound (updateRoster roster) dtacrypt
+        , toxCrypto = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet
+        , toxCryptoSessions = sessionsState
+        , toxCryptoKeys = crypto
+        , toxRouting = mkrouting dhtclient
+        , toxTokens = toks
+        , toxAnnouncedKeys = keydb
+        , toxOnionRoutes = orouter
+        , toxRoster = roster
+        }
+
+onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
+onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od
+
+forkTox :: Tox -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
+forkTox tox = do
+    _ <- forkListener "toxCrypto" (toxCrypto tox)
+    _ <- forkListener "toxToRoute" (toxToRoute tox)
+    _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
+    quit <- forkListener "toxDHT" (clientNet $ toxDHT tox)
+    forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
+    forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
+    return ( quit
+           , bootstrap (DHT.refresher4 $ toxRouting tox)
+           , bootstrap (DHT.refresher6 $ toxRouting tox)
+           )
+
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
new file mode 100644
index 00000000..ac3d1ef0
--- /dev/null
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -0,0 +1,285 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+module Network.Tox.Crypto.Handlers where
+
+import Network.Tox.Crypto.Transport
+import Network.Tox.DHT.Transport (Cookie(..),CookieData(..))
+import Crypto.Tox
+import Control.Concurrent.STM
+import Network.Address
+import qualified Data.Map.Strict as Map
+import Crypto.Hash
+import Control.Applicative
+import Control.Monad
+import Data.Time.Clock.POSIX
+import qualified Data.ByteString  as B
+import Control.Lens
+import Data.Function
+import Data.Serialize             as S
+import Data.Word
+import GHC.Conc (unsafeIOToSTM)
+import qualified Data.Set         as Set
+
+-- util, todo: move to another module
+maybeToEither :: Maybe b -> Either String b
+maybeToEither (Just x) = Right x
+maybeToEither Nothing  = Left "maybeToEither"
+
+data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed
+    deriving (Eq,Ord,Show,Enum)
+
+
+type IOHook addr x = addr -> x -> IO (Maybe (x -> x))
+type NetCryptoHook = IOHook NetCryptoSession CryptoData
+
+
+data NetCryptoSession = NCrypto { ncState         :: TVar NetCryptoSessionStatus
+                                , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number
+                                , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
+                                , ncHandShake     :: TVar (Maybe (Handshake Encrypted))
+                                , ncCookie        :: TVar (Maybe Cookie)
+                                , ncTheirDHTKey   :: PublicKey
+                                , ncTheirSessionPublic :: Maybe PublicKey
+                                , ncSessionSecret :: SecretKey
+                                , ncSockAddr      :: SockAddr
+                                , ncHooks         :: TVar (Map.Map MessageType [NetCryptoHook])
+                                , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook)
+                                , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session
+                                                                     --   needs to possibly start another, as is
+                                                                     --   the case in group chats
+                                , ncGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
+                                }
+
+data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
+                                    , transportCrypto :: TransportCrypto
+                                    , defaultHooks :: Map.Map MessageType [NetCryptoHook]
+                                    , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
+                                    }
+
+newSessionsState :: TransportCrypto -> (MessageType -> NetCryptoHook) -> Map.Map MessageType [NetCryptoHook] -> IO NetCryptoSessions
+newSessionsState crypto unrechook hooks = do
+    x <- atomically $ newTVar Map.empty
+    return NCSessions { netCryptoSessions = x
+                      , transportCrypto = crypto
+                      , defaultHooks = hooks
+                      , defaultUnrecognizedHook = unrechook
+                      }
+
+data HandshakeParams
+        = HParam
+            { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
+            , hpOtherCookie :: Maybe Cookie
+            , hpTheirSessionKeyPublic :: PublicKey
+            , hpMySecretKey :: SecretKey
+            , hpCookieRemotePubkey :: PublicKey
+            , hpCookieRemoteDhtkey :: PublicKey
+            }
+newHandShakeData :: TransportCrypto -> HandshakeParams -> HandshakeData
+newHandShakeData = error "todo"
+
+-- | called when we recieve a crypto handshake with valid cookie
+freshCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> IO ()
+freshCryptoSession  sessions
+                    addr
+                    hp@(HParam
+                              { hpTheirBaseNonce = Just theirBaseNonce
+                              , hpOtherCookie    = Just otherCookie
+                              , hpTheirSessionKeyPublic = theirSessionKey
+                              , hpMySecretKey        = key
+                              , hpCookieRemotePubkey = remotePublicKey
+                              , hpCookieRemoteDhtkey = remoteDhtPublicKey
+                              }) = do
+    let crypto = transportCrypto sessions
+        allsessions = netCryptoSessions sessions
+    ncState0 <- atomically $ newTVar Accepted
+    ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce
+    n24 <- atomically $ transportNewNonce crypto
+    state <- lookupSharedSecret crypto key remoteDhtPublicKey n24
+    let myhandshakeData = newHandShakeData crypto hp
+        plain = encodePlain myhandshakeData
+        encrypted = encrypt state plain
+        myhandshake = Handshake { handshakeCookie = otherCookie
+                                , handshakeNonce = n24
+                                , handshakeData = encrypted
+                                }
+    ncMyPacketNonce0 <- atomically $ newTVar (baseNonce myhandshakeData)
+    ncHandShake0 <- atomically $ newTVar (Just myhandshake)
+    cookie0 <- atomically $ newTVar (Just otherCookie)
+    newsession <- generateSecretKey
+    ncHooks0 <- atomically $ newTVar (defaultHooks sessions)
+    ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions)
+    ncGroups0 <- atomically $ newTVar (Map.empty)
+    let netCryptoSession =
+            NCrypto { ncState         = ncState0
+                    , ncTheirBaseNonce= ncTheirBaseNonce0
+                    , ncMyPacketNonce   = ncMyPacketNonce0
+                    , ncHandShake     = ncHandShake0
+                    , ncCookie        = cookie0
+                    , ncTheirDHTKey   = remoteDhtPublicKey
+                    , ncTheirSessionPublic = Just theirSessionKey
+                    , ncSessionSecret = newsession
+                    , ncSockAddr      = addr
+                    , ncHooks         = ncHooks0
+                    , ncUnrecognizedHook = ncUnrecognizedHook0
+                    , ncAllSessions = sessions
+                    , ncGroups = ncGroups0
+                    }
+    atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession)
+
+-- | Called when we get a handshake, but there's already a session entry.
+updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> IO ()
+updateCryptoSession sessions addr hp session = do
+    ncState0 <- atomically $ readTVar (ncState session)
+    ncTheirBaseNonce0 <- atomically $ readTVar (ncTheirBaseNonce session)
+    if (ncState0 >= Accepted)
+        -- If the nonce in the handshake and the dht key are both the same as
+        -- the ones we have saved, assume we already handled this and this is a
+        -- duplicate handshake packet, otherwise disregard everything, and
+        -- refresh all state.
+        --
+     then when (  Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp
+               || ncTheirDHTKey session /= hpCookieRemoteDhtkey hp
+               ) $ freshCryptoSession sessions addr hp
+     else if ( Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp)
+            then freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh
+            else atomically $ writeTVar (ncState session) Accepted
+
+
+cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto))
+cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do
+    -- Handle Handshake Message
+    let crypto = transportCrypto sessions
+        allsessions = netCryptoSessions sessions
+        anyRight [] f     = return $ Left "missing key"
+        anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
+    seckeys <- map fst <$> atomically (readTVar (userKeys crypto))
+    symkey <- atomically $ transportSymmetric crypto
+    now <- getPOSIXTime
+    lr <- fmap join . sequence $ do -- Either Monad
+            (CookieData cookieTime remotePubkey remoteDhtkey) <- (decodePlain =<< decryptSymmetric symkey n24 ecookie)
+            Right $ do -- IO Monad
+            decrypted <- anyRight seckeys $ \key -> do
+                            secret <- lookupSharedSecret crypto key remotePubkey nonce24
+                            return $ (key,) <$> (decodePlain =<< decrypt secret encrypted)
+            return $ do -- Either Monad
+            (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
+            -- check cookie time < 15 seconds ago
+            guard (now - fromIntegral cookieTime < 15)
+            -- cookie hash is valid? sha512 of ecookie
+            let hinit = hashInit
+                hctx = hashUpdate hinit n24
+                hctx' = hashUpdate hctx ecookie
+                digest = hashFinalize hctx'
+            guard (cookieHash == digest)
+            -- known friend?
+            -- todo
+            return
+             HParam
+                { hpTheirBaseNonce = Just baseNonce
+                , hpOtherCookie    = Just otherCookie
+                , hpTheirSessionKeyPublic =  sessionKey
+                , hpMySecretKey        = key
+                , hpCookieRemotePubkey = remotePubkey
+                , hpCookieRemoteDhtkey = remoteDhtkey
+                }
+    case lr of
+        Left _ -> return ()
+        Right hp@(HParam
+                      { hpTheirBaseNonce = Just theirBaseNonce
+                      , hpOtherCookie    = Just otherCookie
+                      , hpTheirSessionKeyPublic = theirSessionKey
+                      , hpMySecretKey        = key
+                      , hpCookieRemotePubkey = remotePublicKey
+                      , hpCookieRemoteDhtkey = remoteDhtPublicKey
+                      }) -> do
+            sessionsmap <- atomically $ readTVar allsessions
+            -- Do a lookup, so we can handle the update case differently
+            case Map.lookup addr sessionsmap of
+                Nothing -> freshCryptoSession sessions addr hp -- create new session
+                Just session -> updateCryptoSession sessions addr hp session -- update existing session
+    return Nothing
+
+
+cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
+    let crypto = transportCrypto sessions
+        allsessions = netCryptoSessions sessions
+    sessionsmap <- atomically $ readTVar allsessions
+    -- Handle Encrypted Message
+    case Map.lookup addr sessionsmap of
+        Nothing -> return Nothing -- drop packet, we have no session
+        Just session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do
+            theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
+            -- Try to decrypt message
+            let diff :: Word16
+                diff = nonce16 - fromIntegral (last2Bytes theirBaseNonce) -- truncating to Word16
+            tempNonce <- addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word
+            lr <- fmap join $ sequence $ do -- Either Monad --
+                        pubkey <- maybeToEither ncTheirSessionPublic
+                        Right $ do -- IO Monad
+                        secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce
+                        return $ decodePlain =<< decrypt secret encrypted
+            case lr of
+                Left _ -> return Nothing -- decryption failed, ignore packet
+                Right cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) -> do -- decryption succeeded,
+                    -- TODO: Why do I need bufferStart & bufferEnd?
+                    --
+                    --   buffer_start = highest packet number handled + 1
+                    --                , recvbuffers buffer_start
+                    --
+                    --   bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number
+                    -- update ncTheirBaseNonce if necessary
+                    when (diff > 2 * dATA_NUM_THRESHOLD)$
+                        atomically $ do
+                            y <- readTVar ncTheirBaseNonce
+                            -- all because Storable forces IO...
+                            x <- unsafeIOToSTM $ addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD)
+                            writeTVar ncTheirBaseNonce y
+                    -- then set session confirmed,
+                    atomically $ writeTVar ncState Confirmed
+                    hookmap <- atomically $ readTVar ncHooks
+                    -- run hook
+                    flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do
+                        let msgTyp = cd ^. messageType
+                        case Map.lookup msgTyp hookmap of
+                                Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
+                                             unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
+                                             mbConsume <- unrecognize msgTyp session cd
+                                             case mbConsume of
+                                                Just f -> do
+                                                           -- ncUnrecognizedHook0 may have updated the hookmap
+                                                           hookmap' <- atomically $ readTVar ncHooks
+                                                           lookupAgain (f cd,hookmap')
+                                                Nothing -> return Nothing
+                                Just hooks -> flip fix (hooks,cd,msgTyp) $ \loop (hooks,cd,typ) -> do
+                                                let _ = cd :: CryptoData
+                                                case (hooks,cd) of
+                                                    ([],_) ->  return Nothing
+                                                    (hook:more,cd) -> do
+                                                        r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData))
+                                                        case r of
+                                                            Just f -> let newcd = f cd
+                                                                          newtyp = newcd ^. messageType
+                                                                          in if newtyp == typ then loop (more,newcd,newtyp)
+                                                                                              else lookupAgain (newcd,hookmap)
+                                                            Nothing -> return Nothing -- message consumed
+    where
+        last2Bytes :: Nonce24 -> Word
+        last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
+                                    Right n -> n
+                                    _ -> error "unreachable-last2Bytes"
+        dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3
+
+-- | handles nothing
+defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
+defaultCryptoDataHooks = Map.empty
+
+-- | discards all unrecognized packets
+defaultUnRecHook :: MessageType -> NetCryptoHook
+defaultUnRecHook _ _ _ = return Nothing
+
+-- | use to add a single hook to a specific session.
+addCryptoDataHook1 :: Map.Map MessageType [NetCryptoHook] -> MessageType -> NetCryptoHook -> Map.Map MessageType [NetCryptoHook]
+addCryptoDataHook1 mp typ hook = case Map.lookup typ mp of
+                                    Nothing -> Map.insert typ [hook] mp
+                                    Just hooks -> Map.insert typ (hook:hooks) mp
+
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
new file mode 100644
index 00000000..8739c853
--- /dev/null
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -0,0 +1,1172 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+module Network.Tox.Crypto.Transport
+    ( parseNetCrypto
+    , encodeNetCrypto
+    -- CryptoTransport
+    , NetCrypto(..)
+    , CryptoData(..)
+    , CryptoMessage(..)
+    , MessageName(..)
+    , CryptoPacket(..)
+    , HandshakeData(..)
+    , Handshake(..)
+    , PeerInfo(..)
+    , MessageID(..)
+    , UserStatus(..)
+    , TypingStatus(..)
+    , GroupChatId(..)
+    , MessageType(..)
+    -- feild name classes
+    , HasGroupChatID(..)
+    , HasGroupNumber(..)
+    , HasPeerNumber(..)
+    , HasMessageNumber(..)
+    , HasMessageName(..)
+    , HasMessageData(..)
+    , HasName(..)
+    , HasTitle(..)
+    , HasMessage(..)
+    , HasMessageType(..)
+    -- lenses
+    , userStatus, nick, statusMessage, typingStatus, action, groupChatID
+    , groupNumber, groupNumberToJoin, peerNumber, messageNumber
+    , messageName, messageData, name, title, message, messageType
+    -- constructor
+    , msg
+    , leaveMsg
+    , peerQueryMsg
+    -- utils
+    , sizedN
+    , sizedAtLeastN
+    , isIndirectGrpChat
+    , LossyOrLossless(..)
+    , lossyness
+    ) where
+
+import Crypto.Tox
+import Network.Tox.DHT.Transport (Cookie)
+import Network.Tox.NodeId
+
+import Network.Socket
+import Data.ByteArray
+
+import Data.ByteString as B
+import Data.Maybe
+import Data.Monoid
+import Data.Word
+import Crypto.Hash
+import Control.Lens
+import Data.Text as T
+import Data.Text.Encoding as T
+import Data.Serialize as S
+import Control.Arrow
+
+
+data NetCrypto
+    = NetHandshake (Handshake Encrypted)
+    | NetCrypto (CryptoPacket Encrypted)
+
+parseNetCrypto :: ByteString -> SockAddr -> Either String (NetCrypto, SockAddr)
+parseNetCrypto pkt@(B.uncons -> Just (0x1a,_)) saddr = left ("parseNetCrypto: "++) $ (,saddr) . NetHandshake <$> runGet get pkt
+parseNetCrypto pkt@(B.uncons -> Just (0x1b,_)) saddr = left ("parseNetCrypto: "++) $ (,saddr) . NetCrypto    <$> runGet get pkt
+parseNetCrypto _ _ = Left "parseNetCrypto: ?"
+
+encodeNetCrypto :: NetCrypto -> SockAddr -> (ByteString, SockAddr)
+encodeNetCrypto (NetHandshake x)  saddr = (B.cons 0x1a (runPut $ put x),saddr)
+encodeNetCrypto (NetCrypto x)     saddr = (B.cons 0x1b (runPut $ put x),saddr)
+
+data Handshake (f :: * -> *) = Handshake
+    { -- The cookie is a cookie obtained by
+      -- sending a cookie request packet to the peer and getting a cookie
+      -- response packet with a cookie in it.  It may also be obtained in the
+      -- handshake packet by a peer receiving a handshake packet (Other
+      -- Cookie).
+      handshakeCookie :: Cookie
+      -- The nonce is a nonce used to encrypt the encrypted part of the handshake
+      -- packet.
+    , handshakeNonce :: Nonce24
+      -- The encrypted part of the handshake packet is encrypted with the long
+      -- term user-keys of both peers.
+    , handshakeData :: f HandshakeData
+    }
+
+instance Serialize (Handshake Encrypted) where
+    get = Handshake <$> get <*> get <*> get
+    put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta
+
+data HandshakeData = HandshakeData
+    { baseNonce :: Nonce24
+    , sessionKey :: PublicKey
+    , cookieHash :: Digest SHA512
+    , otherCookie :: Cookie
+    }
+
+instance Sized HandshakeData where
+    size = contramap baseNonce size
+            <> contramap (key2id . sessionKey) size
+            <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512)
+            <> contramap otherCookie size
+
+instance Serialize HandshakeData where
+    get = HandshakeData <$> get
+                        <*> (id2key <$> get)
+                        <*> (fromJust . digestFromByteString <$> getBytes 64)
+                        <*> get
+    put (HandshakeData n k h c) = do
+        put n
+        put $ key2id k
+        putByteString (convert h)
+        put c
+
+data CryptoPacket (f :: * -> *) = CryptoPacket
+    { -- | The last 2 bytes of the nonce used to encrypt 'pktData'
+      pktNonce :: Word16
+      -- The payload is encrypted with the session key and 'baseNonce' set by
+      -- the receiver in their handshake + packet number (starting at 0, big
+      -- endian math).
+    , pktData :: f CryptoData
+    }
+
+instance Sized CryptoData where
+    size = contramap bufferStart size
+            <> contramap bufferEnd size
+            <> contramap bufferData size
+
+instance Serialize (CryptoPacket Encrypted) where
+    get = CryptoPacket <$> get <*> get
+    put (CryptoPacket n16 dta) = put n16 >> put dta
+
+data CryptoData = CryptoData
+    { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
+      bufferStart :: Word32
+      -- | [  uint32_t packet number if lossless
+      --   , sendbuffer buffer_end  if lossy   , (big endian)]
+    , bufferEnd :: Word32
+      -- | [data]
+    , bufferData :: CryptoMessage
+    }
+
+instance Serialize CryptoData where
+    get = CryptoData <$> get <*> get <*> get
+    put (CryptoData start end dta) = put start >> put end >> put dta
+
+-- The 'UserStatus' equivalent in Presence is:
+--
+-- data JabberShow = Offline
+--                 | ExtendedAway
+--                 | Away           -- Tox equiv: Away (1)
+--                 | DoNotDisturb   -- Tox equiv: Busy (2)
+--                 | Available      -- Tox equiv: Online (0)
+--                 | Chatty
+--  deriving (Show,Enum,Ord,Eq,Read)
+--
+-- The Enum instance on 'UserStatus' is not arbitrary.  It corresponds
+-- to on-the-wire id numbers.
+data UserStatus = Online | Away | Busy deriving (Show,Eq,Ord,Enum)
+
+data TypingStatus = NotTyping | Typing deriving (Show,Eq,Ord,Enum)
+
+data CryptoMessage
+        = OneByte  { msgID :: MessageID }
+        | TwoByte  { msgID :: MessageID, msgByte  :: Word8 }
+        | UpToN    { msgID :: MessageID, msgBytes :: ByteString } -- length < N
+    deriving (Eq,Show)
+
+instance Sized CryptoMessage where
+    size = VarSize $ \case
+        OneByte {}              -> 1
+        TwoByte {}              -> 2
+        UpToN { msgBytes = bs } -> 1 + B.length bs
+
+instance Serialize CryptoMessage where
+    get = do
+        i <- get :: Get MessageID
+        n <- remaining
+        case msgSizeParam i of
+            Just (True,1) -> return $ OneByte i
+            Just (True,2) -> TwoByte i <$> get
+            _ -> UpToN i <$> getByteString n
+
+    put (OneByte i)   =    putWord8 (fromIntegral . fromEnum $ i)
+    put (TwoByte i b) = do putWord8 (fromIntegral . fromEnum $ i)
+                           putWord8 b 
+    put (UpToN i x)   = do putWord8 (fromIntegral . fromEnum $ i)
+                           putByteString x
+
+instance Serialize MessageID where
+    get = toEnum . fromIntegral <$> getWord8
+    put x = putWord8 (fromIntegral . fromEnum $ x)
+    
+erCompat :: String -> a
+erCompat lens = error $ "Use of '" ++ lens ++ "'  lens on incompatible CryptoMessage type"
+
+typingStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
+typingStatus = lens getter setter
+  where
+    getter :: CryptoMessage -> UserStatus
+    getter (TwoByte TYPING status) = toEnum $ fromIntegral status
+    getter _                       = erCompat "typingStatus"
+    setter :: CryptoMessage -> UserStatus -> CryptoMessage
+    setter (TwoByte TYPING _) status = TwoByte TYPING (fromIntegral . fromEnum $ status)
+    setter _ _                       = erCompat "typingStatus"
+
+userStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
+userStatus = lens getter setter
+  where
+    getter (TwoByte USERSTATUS status) = toEnum $ fromIntegral status
+    getter _                           = erCompat "userStatus"
+    setter (TwoByte USERSTATUS _) status = TwoByte USERSTATUS (fromIntegral . fromEnum $ status)
+    setter _ _                           = erCompat "userStatus"
+
+nick :: Functor f => (Text -> f Text)-> (CryptoMessage -> f CryptoMessage)
+nick = lens getter setter
+  where
+    getter (UpToN NICKNAME bstr) = T.decodeUtf8 bstr
+    getter _                     = erCompat "nick"
+    setter (UpToN NICKNAME _) nick = UpToN NICKNAME (T.encodeUtf8 $ nick)
+    setter _ _                     = erCompat "nick"
+
+statusMessage :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
+statusMessage = lens getter setter
+  where
+    getter (UpToN STATUSMESSAGE bstr) = T.unpack $ T.decodeUtf8 bstr
+    getter _                          = erCompat "statusMessage"
+    setter (UpToN STATUSMESSAGE _) nick = UpToN STATUSMESSAGE (T.encodeUtf8 . T.pack $ nick)
+    setter _ _                          = erCompat "statusMessage"
+
+action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
+action = lens getter setter
+  where
+    getter (UpToN ACTION bstr) = T.unpack $ T.decodeUtf8 bstr
+    getter _                     = erCompat "action"
+    setter (UpToN ACTION _) action = UpToN ACTION (T.encodeUtf8 . T.pack $ action)
+    setter _ _                     = erCompat "action"
+
+newtype GroupChatId = GrpId ByteString -- 33 bytes
+    deriving (Show,Eq)
+
+class HasGroupChatID x where
+    getGroupChatID :: x -> GroupChatId
+    setGroupChatID :: x -> GroupChatId -> x
+
+sizedN :: Int -> ByteString -> ByteString
+sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
+                                 else B.take n bs
+
+sizedAtLeastN :: Int -> ByteString -> ByteString
+sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
+                                        else bs
+
+instance HasGroupChatID CryptoMessage where
+    -- Get
+    getGroupChatID (UpToN INVITE_GROUPCHAT payload)
+        = let (xs,ys) = B.splitAt 1 payload'
+              payload' = sizedN 38 payload
+              in case B.unpack xs of
+                    [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number
+                    [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers
+                    _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message"
+
+    getGroupChatID (UpToN ONLINE_PACKET payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
+    getGroupChatID _ = error "getGroupChatID on non-groupchat message."
+
+    -- Set
+    setGroupChatID msg@(UpToN INVITE_GROUPCHAT  payload) (GrpId newid)
+        = let (xs,ys) = B.splitAt 1 payload'
+              payload' = sizedN 38 payload
+              in case B.unpack xs of
+                    [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number
+                    [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers
+                    _ -> msg -- unexpected condition, leave unchanged
+
+    setGroupChatID (UpToN ONLINE_PACKET payload) (GrpId newid) = UpToN ONLINE_PACKET (B.concat [B.take 2 payload, sizedN 33 newid])
+    setGroupChatID _ _= error "setGroupChatID on non-groupchat message."
+
+groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
+groupChatID = lens getGroupChatID setGroupChatID
+
+type GroupNumber = Word16
+type PeerNumber = Word16
+type MessageNumber = Word32
+
+class HasGroupNumber x where
+    getGroupNumber :: x -> GroupNumber
+    setGroupNumber :: x -> GroupNumber -> x
+
+instance HasGroupNumber CryptoMessage where
+    getGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1
+        = let twobytes = B.take 2 xs
+              Right n = S.decode twobytes
+              in n
+    getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63
+        = let Right n = S.decode twobytes in n
+    getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes))
+        = let Right n = S.decode twobytes in n
+
+    getGroupNumber _   = error "getGroupNumber on CryptoMessage without group number field."
+
+    setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum
+        = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs)))
+    setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum
+        | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs)
+        | x == 0xC7              = UpToN xE (B.append (S.encode groupnum) xs)
+    setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field."
+
+groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
+groupNumber = lens getGroupNumber setGroupNumber
+
+class HasGroupNumberToJoin x where
+    getGroupNumberToJoin :: x -> GroupNumber
+    setGroupNumberToJoin :: x -> GroupNumber -> x
+
+instance HasGroupNumberToJoin CryptoMessage where
+    getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join
+        = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local)
+              Right n = S.decode twobytes
+              in n
+    getGroupNumberToJoin _   = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field."
+    setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum 
+        = let (a,b)        = B.splitAt 2 xs
+              (twoBytes,c) = B.splitAt 2 b
+              twoBytes' = S.encode groupnum
+            in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c]))
+    setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field."
+
+groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
+groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin
+
+class HasPeerNumber x where
+    getPeerNumber :: x -> PeerNumber
+    setPeerNumber :: x -> PeerNumber -> x
+
+instance HasPeerNumber CryptoMessage where
+    getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
+        = let Right n = S.decode twobytes in n
+    getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
+        = let Right n = S.decode twobytes in n
+    getPeerNumber _   = error "getPeerNumber on CryptoMessage without peer number field."
+
+    setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
+        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
+    setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum 
+        = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
+    setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field."
+
+peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
+peerNumber = lens getPeerNumber setPeerNumber
+
+class HasMessageNumber x where
+    getMessageNumber :: x -> MessageNumber
+    setMessageNumber :: x -> MessageNumber -> x
+
+instance HasMessageNumber CryptoMessage where
+    getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
+        = let Right n = S.decode fourbytes in n
+    getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
+        = let Right n = S.decode fourbytes in n
+    getMessageNumber _   = error "getMessageNumber on CryptoMessage without message number field."
+
+    setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
+        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
+    setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum 
+        = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
+    setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field."
+
+messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
+messageNumber = lens getMessageNumber setMessageNumber
+
+
+class HasMessageName x where
+    getMessageName :: x -> MessageName
+    setMessageName :: x -> MessageName -> x
+
+instance HasMessageName CryptoMessage where
+    getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
+        = let [n] = B.unpack onebyte
+              in toEnum . fromIntegral $ n
+    getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
+        = let [n] = B.unpack onebyte
+              in toEnum . fromIntegral $ n
+    getMessageName _   = error "getMessageName on CryptoMessage without message name field."
+
+    setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
+        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
+    setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
+        = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
+    setMessageName _ _ = error "setMessageName on CryptoMessage without message name field."
+
+messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
+messageName = lens getMessageName setMessageName
+
+data MessageType = Msg MessageID
+                 | GrpMsg MessageName
+    deriving (Eq,Show)
+
+instance Ord MessageType where
+    compare (Msg x) (Msg y) = compare x y
+    compare (GrpMsg x) (GrpMsg y) = compare x y
+    compare (Msg _) (GrpMsg _) = LT
+    compare (GrpMsg _) (Msg _) = GT
+
+class HasMessageType x where
+    getMessageType :: x -> MessageType
+    setMessageType :: x -> MessageType -> x
+
+instance HasMessageType CryptoMessage where
+    getMessageType (OneByte mid) = Msg mid
+    getMessageType (TwoByte mid _) = Msg mid
+    getMessageType m@(UpToN mid _) | isIndirectGrpChat mid = GrpMsg (getMessageName m)
+    getMessageType (UpToN mid _) = Msg mid
+
+    setMessageType m@(UpToN mid _) (GrpMsg mname) | isIndirectGrpChat mid = setMessageName m mname
+    setMessageType (OneByte _   ) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty        ) mname
+    setMessageType (TwoByte  _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
+    setMessageType (UpToN _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
+    setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
+    setMessageType (OneByte mid0  ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 
+    setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x 
+    setMessageType (UpToN mid0 x)   (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
+    setMessageType (OneByte mid0)   (Msg mid) = UpToN mid B.empty
+    setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
+    setMessageType (UpToN mid0 x)   (Msg mid) = UpToN mid x
+
+instance HasMessageType CryptoData where
+    getMessageType (CryptoData { bufferData })     = getMessageType bufferData
+    setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ }
+
+-- | This lens should always succeed on CryptoMessage
+messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
+messageType = lens getMessageType setMessageType
+
+type MessageData = B.ByteString
+
+class HasMessageData x where
+    getMessageData :: x -> MessageData
+    setMessageData :: x -> MessageData -> x
+
+instance HasMessageData CryptoMessage where
+    getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
+    getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
+    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos
+    -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8
+    getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title
+    getMessageData _   = error "getMessageData on CryptoMessage without message data field."
+
+    setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT
+        = UpToN xE (B.concat [bs,messagedata])
+    setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT
+        = UpToN xE (B.concat [bs,messagedata])
+    setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets
+        = UpToN xE (B.concat [bs,peerinfosOrTitle])
+    setMessageData _ _ = error "setMessageData on CryptoMessage without message data field."
+
+messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
+messageData = lens getMessageData setMessageData
+
+class HasTitle x where
+    getTitle :: x -> Text
+    setTitle :: x -> Text -> x
+
+instance HasTitle CryptoMessage where
+    getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-}    (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata
+    getTitle (UpToN xE                           (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata))))
+        | isIndirectGrpChat xE = decodeUtf8 mdata
+    getTitle _   = error "getTitle on CryptoMessage without title field."
+
+    setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (bs,B.uncons -> Just (_,xs)))) messagedata
+        = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)])
+    setTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (_,xs)))) title
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum GroupchatTitleChange) (encodeUtf8 title)])
+    setTitle _ _ = error "setTitle on CryptoMessage without title field."
+
+title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
+title = lens getTitle setTitle
+
+class HasMessage x where
+    getMessage :: x -> Text
+    setMessage :: x -> Text -> x
+
+instance HasMessage CryptoMessage where
+    getMessage (UpToN MESSAGE bstr) = T.decodeUtf8 bstr
+    getMessage (UpToN xE                           (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (mnameByte,mdata))))
+        | isIndirectGrpChat xE = decodeUtf8 mdata
+    getMessage _   = error "getMessage on CryptoMessage without message field."
+
+    setMessage (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 $ message)
+    setMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (mnameByte,xs)))) message
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (if mnameByte == 0 then 0x40 else mnameByte) (encodeUtf8 message)])
+    setMessage _ _ = error "setMessage on CryptoMessage without message field."
+
+message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
+message = lens getMessage setMessage
+
+class HasName x where
+    getName :: x -> Text
+    setName :: x -> Text -> x
+
+
+instance HasName CryptoMessage where
+    -- Only MESSAGE_GROUPCHAT:NameChange has Name field
+    getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
+    getName _   = error "getName on CryptoMessage without name field."
+
+    -- If its not NameChange, this setter will set it to NameChange
+    setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
+    setName _ _ = error "setName on CryptoMessage without name field."
+
+name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
+name = lens getTitle setTitle
+
+data PeerInfo
+      = PeerInfo
+         { piPeerNum :: PeerNumber
+         , piUserKey :: PublicKey
+         , piDHTKey  :: PublicKey
+         , piName  :: ByteString -- byte-prefix for length
+         } deriving (Eq,Show)
+
+instance HasPeerNumber PeerInfo where
+    getPeerNumber = piPeerNum
+    setPeerNumber x n = x { piPeerNum = n }
+
+instance Serialize PeerInfo where
+    get = do
+        w16 <- get
+        ukey <- id2key <$> get
+        dkey <- id2key <$> get
+        w8 <- get :: Get Word8
+        PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)
+
+    put (PeerInfo w16 ukey dkey bs) = do
+        put w16
+        put $ key2id ukey
+        put $ key2id dkey
+        let sz :: Word8
+            sz = case B.length bs of
+                    n | n <= 255  -> fromIntegral n
+                      | otherwise -> 255
+        put sz
+        putByteString $ B.take (fromIntegral sz) bs
+
+
+-- |
+-- default constructor, handy for formations such as:
+--
+-- > userStatus .~ Busy $ msg USERSTATUS
+--
+msg :: MessageID -> CryptoMessage
+msg mid | Just (True,0) <- msgSizeParam mid  = OneByte mid
+msg mid | Just (True,1) <- msgSizeParam mid  = TwoByte mid 0
+msg mid | Just (False,_) <- msgSizeParam mid = UpToN   mid B.empty
+msg mid = UpToN   mid B.empty
+
+leaveMsg :: Serialize a => a -> CryptoMessage
+leaveMsg     groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
+
+peerQueryMsg :: Serialize a => a -> CryptoMessage
+peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
+
+
+-- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as
+-- the maximum allowed size for the message Payload (message minus id)
+-- Or Nothing if unknown/unimplemented.
+msgSizeParam :: MessageID -> Maybe (Bool,Int)
+msgSizeParam ONLINE  = Just (True,0)
+msgSizeParam OFFLINE = Just (True,0)
+msgSizeParam USERSTATUS = Just (True,1)
+msgSizeParam TYPING     = Just (True,1)
+msgSizeParam NICKNAME         = Just (False,128)
+msgSizeParam STATUSMESSAGE    = Just (False,1007)
+msgSizeParam MESSAGE          = Just (False,1372)
+msgSizeParam ACTION           = Just (False,1372)
+msgSizeParam FILE_DATA        = Just (False,1372)-- up to 1373
+msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
+msgSizeParam FILE_CONTROL     = Just (False,7)   -- 8 bytes if seek, otherwise 4
+msgSizeParam INVITE_GROUPCHAT = Just (False,38)
+msgSizeParam ONLINE_PACKET    = Just (True,35)
+msgSizeParam DIRECT_GROUPCHAT  {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
+msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
+msgSizeParam LOSSY_GROUPCHAT   {-0xC7-} = Nothing -- variable
+msgSizeParam _ = Nothing
+
+isIndirectGrpChat :: MessageID -> Bool
+isIndirectGrpChat MESSAGE_GROUPCHAT = True
+isIndirectGrpChat LOSSY_GROUPCHAT = True
+isIndirectGrpChat _ = False
+
+data LossyOrLossless = UnknownLossyness | Lossless | Lossy 
+    deriving (Eq,Ord,Enum,Show,Bounded)
+
+lossyness :: MessageID -> LossyOrLossless
+lossyness (fromEnum -> x) | x < 3             = Lossy
+lossyness (fromEnum -> x) | x >= 16, x < 192  = Lossless
+lossyness (fromEnum -> x) | x >= 192, x < 255 = Lossy
+lossyness (fromEnum -> 255)                   = Lossless
+lossyness _ = UnknownLossyness
+
+-- TODO: Flesh this out.
+data MessageID              -- First byte indicates data
+    = Padding               -- ^ 0 padding (skipped until we hit a non zero (data id) byte)
+    | PacketRequest         -- ^ 1 packet request packet (lossy packet)
+    | KillPacket            -- ^ 2 connection kill packet (lossy packet)
+    | UnspecifiedPacket003  -- ^ 3+ unspecified
+    | UnspecifiedPacket004
+    | UnspecifiedPacket005
+    | UnspecifiedPacket006
+    | UnspecifiedPacket007
+    | UnspecifiedPacket008
+    | UnspecifiedPacket009
+    | UnspecifiedPacket010
+    | UnspecifiedPacket011
+    | UnspecifiedPacket012
+    | UnspecifiedPacket013
+    | UnspecifiedPacket014
+    | UnspecifiedPacket015
+    | MessengerLossless016  -- ^ 16+  reserved for Messenger usage (lossless packets)
+    | MessengerLossless017
+    | MessengerLossless018
+    | MessengerLossless019
+    | MessengerLossless020
+    | MessengerLossless021
+    | MessengerLossless022
+    | MessengerLossless023
+    | ONLINE                -- 1 byte
+    | OFFLINE               -- 1 byte
+    | MessengerLossless026
+    | MessengerLossless027
+    | MessengerLossless028
+    | MessengerLossless029
+    | MessengerLossless030
+    | MessengerLossless031
+    | MessengerLossless032
+    | MessengerLossless033
+    | MessengerLossless034
+    | MessengerLossless035
+    | MessengerLossless036
+    | MessengerLossless037
+    | MessengerLossless038
+    | MessengerLossless039
+    | MessengerLossless040
+    | MessengerLossless041
+    | MessengerLossless042
+    | MessengerLossless043
+    | MessengerLossless044
+    | MessengerLossless045
+    | MessengerLossless046
+    | MessengerLossless047
+    | NICKNAME              -- up to 129 bytes
+    | STATUSMESSAGE         -- up to 1008 bytes
+    | USERSTATUS            -- 2 bytes
+    | TYPING                -- 2 bytes
+    | MessengerLossless052
+    | MessengerLossless053
+    | MessengerLossless054
+    | MessengerLossless055
+    | MessengerLossless056
+    | MessengerLossless057
+    | MessengerLossless058
+    | MessengerLossless059
+    | MessengerLossless060
+    | MessengerLossless061
+    | MessengerLossless062
+    | MessengerLossless063
+    | MESSAGE               -- up to 1373 bytes
+    | ACTION                -- up to 1373 bytes
+    | MessengerLossless066
+    | MessengerLossless067
+    | MessengerLossless068
+    | MSI
+    | MessengerLossless070
+    | MessengerLossless071
+    | MessengerLossless072
+    | MessengerLossless073
+    | MessengerLossless074
+    | MessengerLossless075
+    | MessengerLossless076
+    | MessengerLossless077
+    | MessengerLossless078
+    | MessengerLossless079
+    | FILE_SENDREQUEST      -- 1+1+4+8+32+max255 = up to 301
+    | FILE_CONTROL          -- 8 bytes if seek, otherwise 4
+    | FILE_DATA             -- up to 1373
+    | MessengerLossless083
+    | MessengerLossless084
+    | MessengerLossless085
+    | MessengerLossless086
+    | MessengerLossless087
+    | MessengerLossless088
+    | MessengerLossless089
+    | MessengerLossless090
+    | MessengerLossless091
+    | MessengerLossless092
+    | MessengerLossless093
+    | MessengerLossless094
+    | MessengerLossless095
+    | INVITE_GROUPCHAT  -- 0x60
+    | ONLINE_PACKET     -- 0x61
+    | DIRECT_GROUPCHAT  -- 0x62
+    | MESSAGE_GROUPCHAT -- 0x63
+    | MessengerLossless100
+    | MessengerLossless101
+    | MessengerLossless102
+    | MessengerLossless103
+    | MessengerLossless104
+    | MessengerLossless105
+    | MessengerLossless106
+    | MessengerLossless107
+    | MessengerLossless108
+    | MessengerLossless109
+    | MessengerLossless110
+    | MessengerLossless111
+    | MessengerLossless112
+    | MessengerLossless113
+    | MessengerLossless114
+    | MessengerLossless115
+    | MessengerLossless116
+    | MessengerLossless117
+    | MessengerLossless118
+    | MessengerLossless119
+    | MessengerLossless120
+    | MessengerLossless121
+    | MessengerLossless122
+    | MessengerLossless123
+    | MessengerLossless124
+    | MessengerLossless125
+    | MessengerLossless126
+    | MessengerLossless127
+    | MessengerLossless128
+    | MessengerLossless129
+    | MessengerLossless130
+    | MessengerLossless131
+    | MessengerLossless132
+    | MessengerLossless133
+    | MessengerLossless134
+    | MessengerLossless135
+    | MessengerLossless136
+    | MessengerLossless137
+    | MessengerLossless138
+    | MessengerLossless139
+    | MessengerLossless140
+    | MessengerLossless141
+    | MessengerLossless142
+    | MessengerLossless143
+    | MessengerLossless144
+    | MessengerLossless145
+    | MessengerLossless146
+    | MessengerLossless147
+    | MessengerLossless148
+    | MessengerLossless149
+    | MessengerLossless150
+    | MessengerLossless151
+    | MessengerLossless152
+    | MessengerLossless153
+    | MessengerLossless154
+    | MessengerLossless155
+    | MessengerLossless156
+    | MessengerLossless157
+    | MessengerLossless158
+    | MessengerLossless159
+    | MessengerLossless160
+    | MessengerLossless161
+    | MessengerLossless162
+    | MessengerLossless163
+    | MessengerLossless164
+    | MessengerLossless165
+    | MessengerLossless166
+    | MessengerLossless167
+    | MessengerLossless168
+    | MessengerLossless169
+    | MessengerLossless170
+    | MessengerLossless171
+    | MessengerLossless172
+    | MessengerLossless173
+    | MessengerLossless174
+    | MessengerLossless175
+    | MessengerLossless176
+    | MessengerLossless177
+    | MessengerLossless178
+    | MessengerLossless179
+    | MessengerLossless180
+    | MessengerLossless181
+    | MessengerLossless182
+    | MessengerLossless183
+    | MessengerLossless184
+    | MessengerLossless185
+    | MessengerLossless186
+    | MessengerLossless187
+    | MessengerLossless188
+    | MessengerLossless189
+    | MessengerLossless190
+    | MessengerLossless191
+    | MessengerLossy192     -- ^ 192+ reserved for Messenger usage (lossy packets)
+    | MessengerLossy193
+    | MessengerLossy194
+    | MessengerLossy195
+    | MessengerLossy196
+    | MessengerLossy197
+    | MessengerLossy198
+    | LOSSY_GROUPCHAT -- 0xC7
+    | MessengerLossy200
+    | MessengerLossy201
+    | MessengerLossy202
+    | MessengerLossy203
+    | MessengerLossy204
+    | MessengerLossy205
+    | MessengerLossy206
+    | MessengerLossy207
+    | MessengerLossy208
+    | MessengerLossy209
+    | MessengerLossy210
+    | MessengerLossy211
+    | MessengerLossy212
+    | MessengerLossy213
+    | MessengerLossy214
+    | MessengerLossy215
+    | MessengerLossy216
+    | MessengerLossy217
+    | MessengerLossy218
+    | MessengerLossy219
+    | MessengerLossy220
+    | MessengerLossy221
+    | MessengerLossy222
+    | MessengerLossy223
+    | MessengerLossy224
+    | MessengerLossy225
+    | MessengerLossy226
+    | MessengerLossy227
+    | MessengerLossy228
+    | MessengerLossy229
+    | MessengerLossy230
+    | MessengerLossy231
+    | MessengerLossy232
+    | MessengerLossy233
+    | MessengerLossy234
+    | MessengerLossy235
+    | MessengerLossy236
+    | MessengerLossy237
+    | MessengerLossy238
+    | MessengerLossy239
+    | MessengerLossy240
+    | MessengerLossy241
+    | MessengerLossy242
+    | MessengerLossy243
+    | MessengerLossy244
+    | MessengerLossy245
+    | MessengerLossy246
+    | MessengerLossy247
+    | MessengerLossy248
+    | MessengerLossy249
+    | MessengerLossy250
+    | MessengerLossy251
+    | MessengerLossy252
+    | MessengerLossy253
+    | MessengerLossy254
+    | Messenger255          -- ^ 255 reserved for Messenger usage (lossless packet)
+    deriving (Show,Eq,Enum,Ord,Bounded)
+
+
+
+data MessageName = Ping -- 0x00
+                 | MessageName0x01
+                 | MessageName0x02
+                 | MessageName0x03
+                 | MessageName0x04
+                 | MessageName0x05
+                 | MessageName0x06
+                 | MessageName0x07
+                 | MessageName0x08
+                 | MessageName0x09
+                 | MessageName0x0a
+                 | MessageName0x0b
+                 | MessageName0x0c
+                 | MessageName0x0d
+                 | MessageName0x0e
+                 | MessageName0x0f
+                 | NewPeer  -- 0x10
+                 | KillPeer -- 0x11
+                 | MessageName0x12
+                 | MessageName0x13
+                 | MessageName0x14
+                 | MessageName0x15
+                 | MessageName0x16
+                 | MessageName0x17
+                 | MessageName0x18
+                 | MessageName0x19
+                 | MessageName0x1a
+                 | MessageName0x1b
+                 | MessageName0x1c
+                 | MessageName0x1d
+                 | MessageName0x1e
+                 | MessageName0x1f
+                 | MessageName0x20
+                 | MessageName0x21
+                 | MessageName0x22
+                 | MessageName0x23
+                 | MessageName0x24
+                 | MessageName0x25
+                 | MessageName0x26
+                 | MessageName0x27
+                 | MessageName0x28
+                 | MessageName0x29
+                 | MessageName0x2a
+                 | MessageName0x2b
+                 | MessageName0x2c
+                 | MessageName0x2d
+                 | MessageName0x2e
+                 | MessageName0x2f
+                 | NameChange -- 0x30
+                 | GroupchatTitleChange -- 0x31
+                 | MessageName0x32
+                 | MessageName0x33
+                 | MessageName0x34
+                 | MessageName0x35
+                 | MessageName0x36
+                 | MessageName0x37
+                 | MessageName0x38
+                 | MessageName0x39
+                 | MessageName0x3a
+                 | MessageName0x3b
+                 | MessageName0x3c
+                 | MessageName0x3d
+                 | MessageName0x3e
+                 | MessageName0x3f
+                 | ChatMessage -- 0x40
+                 | Action -- 0x41
+                 | MessageName0x42
+                 | MessageName0x43
+                 | MessageName0x44
+                 | MessageName0x45
+                 | MessageName0x46
+                 | MessageName0x47
+                 | MessageName0x48
+                 | MessageName0x49
+                 | MessageName0x4a
+                 | MessageName0x4b
+                 | MessageName0x4c
+                 | MessageName0x4d
+                 | MessageName0x4e
+                 | MessageName0x4f
+                 | MessageName0x50
+                 | MessageName0x51
+                 | MessageName0x52
+                 | MessageName0x53
+                 | MessageName0x54
+                 | MessageName0x55
+                 | MessageName0x56
+                 | MessageName0x57
+                 | MessageName0x58
+                 | MessageName0x59
+                 | MessageName0x5a
+                 | MessageName0x5b
+                 | MessageName0x5c
+                 | MessageName0x5d
+                 | MessageName0x5e
+                 | MessageName0x5f
+                 | MessageName0x60
+                 | MessageName0x61
+                 | MessageName0x62
+                 | MessageName0x63
+                 | MessageName0x64
+                 | MessageName0x65
+                 | MessageName0x66
+                 | MessageName0x67
+                 | MessageName0x68
+                 | MessageName0x69
+                 | MessageName0x6a
+                 | MessageName0x6b
+                 | MessageName0x6c
+                 | MessageName0x6d
+                 | MessageName0x6e
+                 | MessageName0x6f
+                 | MessageName0x70
+                 | MessageName0x71
+                 | MessageName0x72
+                 | MessageName0x73
+                 | MessageName0x74
+                 | MessageName0x75
+                 | MessageName0x76
+                 | MessageName0x77
+                 | MessageName0x78
+                 | MessageName0x79
+                 | MessageName0x7a
+                 | MessageName0x7b
+                 | MessageName0x7c
+                 | MessageName0x7d
+                 | MessageName0x7e
+                 | MessageName0x7f
+                 | MessageName0x80
+                 | MessageName0x81
+                 | MessageName0x82
+                 | MessageName0x83
+                 | MessageName0x84
+                 | MessageName0x85
+                 | MessageName0x86
+                 | MessageName0x87
+                 | MessageName0x88
+                 | MessageName0x89
+                 | MessageName0x8a
+                 | MessageName0x8b
+                 | MessageName0x8c
+                 | MessageName0x8d
+                 | MessageName0x8e
+                 | MessageName0x8f
+                 | MessageName0x90
+                 | MessageName0x91
+                 | MessageName0x92
+                 | MessageName0x93
+                 | MessageName0x94
+                 | MessageName0x95
+                 | MessageName0x96
+                 | MessageName0x97
+                 | MessageName0x98
+                 | MessageName0x99
+                 | MessageName0x9a
+                 | MessageName0x9b
+                 | MessageName0x9c
+                 | MessageName0x9d
+                 | MessageName0x9e
+                 | MessageName0x9f
+                 | MessageName0xa0
+                 | MessageName0xa1
+                 | MessageName0xa2
+                 | MessageName0xa3
+                 | MessageName0xa4
+                 | MessageName0xa5
+                 | MessageName0xa6
+                 | MessageName0xa7
+                 | MessageName0xa8
+                 | MessageName0xa9
+                 | MessageName0xaa
+                 | MessageName0xab
+                 | MessageName0xac
+                 | MessageName0xad
+                 | MessageName0xae
+                 | MessageName0xaf
+                 | MessageName0xb0
+                 | MessageName0xb1
+                 | MessageName0xb2
+                 | MessageName0xb3
+                 | MessageName0xb4
+                 | MessageName0xb5
+                 | MessageName0xb6
+                 | MessageName0xb7
+                 | MessageName0xb8
+                 | MessageName0xb9
+                 | MessageName0xba
+                 | MessageName0xbb
+                 | MessageName0xbc
+                 | MessageName0xbd
+                 | MessageName0xbe
+                 | MessageName0xbf
+                 | MessageName0xc0
+                 | MessageName0xc1
+                 | MessageName0xc2
+                 | MessageName0xc3
+                 | MessageName0xc4
+                 | MessageName0xc5
+                 | MessageName0xc6
+                 | MessageName0xc7
+                 | MessageName0xc8
+                 | MessageName0xc9
+                 | MessageName0xca
+                 | MessageName0xcb
+                 | MessageName0xcc
+                 | MessageName0xcd
+                 | MessageName0xce
+                 | MessageName0xcf
+                 | MessageName0xd0
+                 | MessageName0xd1
+                 | MessageName0xd2
+                 | MessageName0xd3
+                 | MessageName0xd4
+                 | MessageName0xd5
+                 | MessageName0xd6
+                 | MessageName0xd7
+                 | MessageName0xd8
+                 | MessageName0xd9
+                 | MessageName0xda
+                 | MessageName0xdb
+                 | MessageName0xdc
+                 | MessageName0xdd
+                 | MessageName0xde
+                 | MessageName0xdf
+                 | MessageName0xe0
+                 | MessageName0xe1
+                 | MessageName0xe2
+                 | MessageName0xe3
+                 | MessageName0xe4
+                 | MessageName0xe5
+                 | MessageName0xe6
+                 | MessageName0xe7
+                 | MessageName0xe8
+                 | MessageName0xe9
+                 | MessageName0xea
+                 | MessageName0xeb
+                 | MessageName0xec
+                 | MessageName0xed
+                 | MessageName0xee
+                 | MessageName0xef
+                 | MessageName0xf0
+                 | MessageName0xf1
+                 | MessageName0xf2
+                 | MessageName0xf3
+                 | MessageName0xf4
+                 | MessageName0xf5
+                 | MessageName0xf6
+                 | MessageName0xf7
+                 | MessageName0xf8
+                 | MessageName0xf9
+                 | MessageName0xfa
+                 | MessageName0xfb
+                 | MessageName0xfc
+                 | MessageName0xfd
+                 | MessageName0xfe
+                 | MessageName0xff
+                deriving (Show,Eq,Ord,Enum,Bounded)
+
+-- --> CookieRequest WithoutCookie
+-- <-- CookieResponse CookieAddress
+-- --> Handshake CookieAddress
+-- <-- Handshake CookieAddress
+
+-- cookie request packet (145 bytes)
+--
+-- [uint8_t 24]
+-- [Sender's DHT Public key (32 bytes)]
+-- [Random nonce (24 bytes)]
+-- [Encrypted message containing:
+--     [Sender's real public key (32 bytes)]
+--     [padding (32 bytes)]
+--     [uint64_t echo id (must be sent back untouched in cookie response)]
+-- ]
+
+
+-- cookie response packet (161 bytes):
+--
+--     [uint8_t 25]
+--     [Random nonce (24 bytes)]
+--     [Encrypted message containing:
+--         [Cookie]
+--         [uint64_t echo id (that was sent in the request)]
+--     ]
+--
+--     Encrypted message is encrypted with the exact same symmetric key as the
+--     cookie request packet it responds to but with a different nonce.
+--     (Encrypted message is encrypted with reqesters's DHT private key,
+--     responders's DHT public key and the nonce.)
+--
+--     Since we don't receive the public key, we will need to lookup the key by
+--     the SockAddr... I don't understand why the CookieResponse message is
+--     special this way.  TODO: implement a multimap (SockAddr -> SharedSecret)
+--     and wrap cookie queries with store/delete.  TODO: Should the entire
+--     SharedScret cache be keyed on only SockAddr ?  Perhaps the secret cache
+--     should be (NodeId -> Secret) and the cookie-request map should be
+--     (SockAddr -> NodeId)
+
+
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
new file mode 100644
index 00000000..500785cc
--- /dev/null
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -0,0 +1,432 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE TupleSections              #-}
+module Network.Tox.DHT.Handlers where
+
+import Network.Tox.DHT.Transport as DHTTransport
+import Network.QueryResponse as QR hiding (Client)
+import qualified Network.QueryResponse as QR (Client)
+import Crypto.Tox
+import Network.Kademlia.Search
+import qualified Data.Wrapper.PSQInt as Int
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Address               (WantIP (..), ipFamily, testIdBit,fromSockAddr, sockAddrPort)
+import qualified Network.Kademlia.Routing as R
+import Control.TriadCommittee
+import System.Global6
+import OnionRouter
+
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Base16 as Base16
+import Control.Arrow
+import Control.Monad
+import Control.Concurrent.Lifted.Instrument
+import Control.Concurrent.STM
+import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+import Network.Socket
+import Data.Hashable
+import Data.IP
+import Data.Ord
+import Data.Maybe
+import Data.Bits
+import Data.Serialize (Serialize)
+import Data.Word
+import Data.List
+import System.IO
+
+data TransactionId = TransactionId
+ { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
+ , cryptoNonce    :: Nonce24 -- ^ Used during the encryption layer.
+ }
+ deriving (Eq,Ord,Show)
+
+newtype PacketKind = PacketKind Word8
+ deriving (Eq, Ord, Serialize)
+
+pattern OnionRequest0Type = PacketKind 128 -- 0x80     Onion Request 0
+pattern OnionRequest1Type = PacketKind 129 -- 0x81     Onion Request 1
+pattern OnionRequest2Type = PacketKind 130 -- 0x82     Onion Request 2
+pattern AnnounceType  = PacketKind 131 -- 0x83     Announce Request
+pattern AnnounceResponseType = PacketKind 132 -- 0x84     Announce Response
+
+pattern DataRequestType = PacketKind 133 -- 0x85     Onion Data Request (data to route request packet)
+pattern DataResponseType = PacketKind 134 -- 0x86     Onion Data Response (data to route response packet)
+-- 0x8c     Onion Response 3
+-- 0x8d     Onion Response 2
+pattern OnionResponse3Type = PacketKind 140 -- 0x8c     Onion Response 3
+pattern OnionResponse2Type = PacketKind 141 -- 0x8d     Onion Response 2
+pattern OnionResponse1Type = PacketKind 142 -- 0x8e     Onion Response 1
+-- 0xf0     Bootstrap Info
+
+pattern DHTRequestType = PacketKind 32 -- 0x20     DHT Request
+
+pattern CookieRequestType = PacketKind 0x18
+pattern CookieResponseType = PacketKind 0x19
+
+pattern PingType      = PacketKind 0 -- 0x00     Ping Request
+pattern PongType      = PacketKind 1 -- 0x01     Ping Response
+pattern GetNodesType  = PacketKind 2 -- 0x02     Nodes Request
+pattern SendNodesType = PacketKind 4 -- 0x04     Nodes Response
+
+
+instance Show PacketKind where
+    showsPrec d PingType = mappend "PingType"
+    showsPrec d PongType = mappend "PongType"
+    showsPrec d GetNodesType = mappend "GetNodesType"
+    showsPrec d SendNodesType = mappend "SendNodesType"
+    showsPrec d DHTRequestType = mappend "DHTRequestType"
+    showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
+    showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
+    showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
+    showsPrec d AnnounceType = mappend "AnnounceType"
+    showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
+    showsPrec d DataRequestType = mappend "DataRequestType"
+    showsPrec d DataResponseType = mappend "DataResponseType"
+    showsPrec d CookieRequestType = mappend "CookieRequestType"
+    showsPrec d CookieResponseType = mappend "CookieResponseType"
+    showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
+
+msgType :: ( Serialize (f DHTRequest)
+           , Serialize (f Cookie), Serialize (f CookieRequest)
+           , Serialize (f SendNodes), Serialize (f GetNodes)
+           , Serialize (f Pong), Serialize (f Ping)
+           ) => DHTMessage f -> PacketKind
+msgType msg = PacketKind $ fst $ dhtMessageType msg
+
+classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message
+classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
+classify client msg = fromMaybe (IsUnknown "unknown")
+                      $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
+ where
+    go (DHTPing          {}) = IsQuery PingType
+    go (DHTGetNodes      {}) = IsQuery GetNodesType
+    go (DHTPong          {}) = IsResponse
+    go (DHTSendNodes     {}) = IsResponse
+    go (DHTCookieRequest {}) = IsQuery CookieRequestType
+    go (DHTCookie        {}) = IsResponse
+    go (DHTDHTRequest    {}) = IsQuery DHTRequestType
+
+data Routing = Routing
+    { tentativeId :: NodeInfo
+    , committee4  :: TriadCommittee NodeId SockAddr
+    , committee6  :: TriadCommittee NodeId SockAddr
+    , refresher4  :: BucketRefresher NodeId NodeInfo
+    , refresher6  :: BucketRefresher NodeId NodeInfo
+    }
+
+sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
+
+sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
+
+routing4 :: Routing -> TVar (R.BucketList NodeInfo)
+routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+routing6 :: Routing -> TVar (R.BucketList NodeInfo)
+routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+newRouting :: SockAddr -> TransportCrypto
+                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change
+                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change
+                       -> IO (Client -> Routing)
+newRouting addr crypto update4 update6 = do
+    let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
+        tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
+        tentative_info = NodeInfo
+                { nodeId   = key2id $ transportPublic crypto
+                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
+                , nodePort = fromMaybe 0 $ sockAddrPort addr
+                }
+        tentative_info4 = tentative_info { nodeIP = tentative_ip4 }
+    tentative_info6 <-
+        maybe (tentative_info { nodeIP = tentative_ip6 })
+              (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
+            <$> case addr of
+                    SockAddrInet {} -> return Nothing
+                    _               -> global6
+    atomically $ do
+        -- We defer initializing the refreshSearch and refreshPing until we
+        -- have a client to send queries with.
+        let nullPing = const $ return False
+            nullSearch = Search
+                { searchSpace       = toxSpace
+                , searchNodeAddress = nodeIP &&& nodePort
+                , searchQuery       = \_ _ -> return Nothing
+                }
+        refresher4 <- newBucketRefresher tentative_info nullSearch nullPing
+        refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing
+        let tbl4 = refreshBuckets refresher4
+            tbl6 = refreshBuckets refresher6
+        committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4
+        committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
+        return $ \client ->
+            -- Now we have a client, so tell the BucketRefresher how to search and ping.
+            let updIO r = updateRefresherIO (nodeSearch client) (ping client) r
+            in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6)
+
+
+-- TODO: This should cover more cases
+isLocal :: IP -> Bool
+isLocal (IPv6 ip6) = (ip6 == toEnum 0)
+isLocal (IPv4 ip4) = (ip4 == toEnum 0)
+
+isGlobal :: IP -> Bool
+isGlobal = not . isLocal
+
+prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
+prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
+
+toxSpace :: R.KademliaSpace NodeId NodeInfo
+toxSpace = R.KademliaSpace
+    { R.kademliaLocation = nodeId
+    , R.kademliaTestBit  = testNodeIdBit
+    , R.kademliaXor      = xorNodeId
+    , R.kademliaSample   = sampleNodeId
+    }
+
+
+pingH :: NodeInfo -> Ping -> IO Pong
+pingH _ Ping = return Pong
+
+getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
+getNodesH routing addr (GetNodes nid) = do
+    let preferred = prefer4or6 addr Nothing
+
+    (append4,append6) <- atomically $ do
+        ni4 <- R.thisNode <$> readTVar (routing4 routing)
+        ni6 <- R.thisNode <$> readTVar (routing6 routing)
+        return $ case ipFamily (nodeIP addr) of
+            Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
+            Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
+            _                                -> (id, id)
+    ks  <- go append4 $ routing4 routing
+    ks6 <- go append6 $ routing6 routing
+    let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
+                                      Want_IP4 -> (ks,ks6)
+                                      Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+    return $ SendNodes
+           $ if null ns2 then ns1
+                         else take 4 (take 3 ns1 ++ ns2)
+ where
+    go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)
+
+    k = 4
+
+cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO Cookie
+cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
+    hPutStrLn stderr $ "CookieRequest! remoteUserKey=" ++ show (key2id remoteUserKey)
+    (n24,sym,us) <- atomically $ do
+        n24 <- transportNewNonce crypto
+        sym <- transportSymmetric crypto
+        us <- readTVar $ userKeys crypto
+        return (n24,sym,us)
+    timestamp <- round . (* 1000000) <$> getPOSIXTime
+    let dta = encodePlain $ CookieData
+            { cookieTime  = timestamp
+            , longTermKey = remoteUserKey
+            , dhtKey      = transportPublic crypto
+            }
+        edta = encryptSymmetric sym n24 dta
+    hPutStrLn stderr $ "CookieRequest! responding to " ++ show (key2id remoteUserKey)
+    return $ Cookie n24 edta
+
+lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message))
+lanDiscoveryH client _ ni = do
+    forkIO $ do
+        myThreadId >>= flip labelThread "lan-discover-ping"
+        ping client ni
+        return ()
+    return Nothing
+
+type Message = DHTMessage ((,) Nonce8)
+
+type Client = QR.Client String PacketKind TransactionId NodeInfo Message
+
+
+wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta
+wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
+    { senderKey = id2key $ nodeId src
+    , asymmNonce = n24
+    , asymmData = dta n8
+    }
+
+serializer :: PacketKind
+                -> (Asymm (Nonce8,ping) -> Message)
+                -> (Message -> Maybe (Asymm (Nonce8,pong)))
+                -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
+serializer pktkind mkping mkpong = MethodSerializer
+        { methodTimeout  = \tid addr -> return (addr, 5000000)
+        , method         = pktkind
+        -- wrapQuery :: tid -> addr -> addr -> qry -> x
+        , wrapQuery      = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
+        -- unwrapResponse :: x -> b
+        , unwrapResponse = fmap (snd . asymmData) . mkpong
+        }
+
+
+unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
+unpong (DHTPong asymm) = Just asymm
+unpong _               = Nothing
+
+showHex :: BA.ByteArrayAccess ba => ba -> String
+showHex bs = C8.unpack $ Base16.encode $ BA.convert bs
+
+ping :: Client -> NodeInfo -> IO Bool
+ping client addr = do
+    hPutStrLn stderr $ show addr ++ " <-- ping"
+    reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
+    hPutStrLn stderr $ show addr ++ " -pong-> " ++ show reply
+    maybe (return False) (\Pong -> return True) $ join reply
+
+
+saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
+saveCookieKey var saddr pk = do
+    cookiekeys <- readTVar var
+    case break (\(stored,_) -> stored == saddr) cookiekeys of
+        (xs,[])                               -> writeTVar var $ (saddr, (1  ,pk)) : xs
+        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys
+        _                                     -> retry -- Wait for requests to this address
+                                                       -- under a different key to time out
+                                                       -- before we try this key.
+
+loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
+loseCookieKey var saddr pk = do
+    cookiekeys <- readTVar var
+    case break (\(stored,_) -> stored == saddr) cookiekeys of
+        (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $                     xs ++ ys
+        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys
+        _                                     -> return () -- unreachable?
+
+
+cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe Cookie)
+cookieRequest crypto client localUserKey addr = do
+    let sockAddr = nodeAddr addr
+        nid = id2key $ nodeId addr
+        cookieSerializer
+            = MethodSerializer
+                   { methodTimeout  = \tid addr -> return (addr, 5000000)
+                   , method    = CookieRequestType
+                   , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
+                   , unwrapResponse = fmap snd . unCookie
+                   }
+        cookieRequest = CookieRequest localUserKey
+    atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
+    hPutStrLn stderr $ show addr ++ " <-- cookieRequest"
+    reply <- QR.sendQuery client cookieSerializer cookieRequest addr
+    atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid
+    hPutStrLn stderr $ show addr ++ " -cookieResponse-> " ++ show reply
+    return $ join reply
+
+unCookie :: DHTMessage t -> Maybe (t Cookie)
+unCookie (DHTCookie n24 fcookie) = Just fcookie
+unCookie _ = Nothing
+
+unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
+unsendNodes (DHTSendNodes asymm) = Just asymm
+unsendNodes _                    = Nothing
+
+unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
+unwrapNodes (SendNodes ns) = (ns,ns,Just ())
+
+getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getNodes client nid addr = do
+    -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
+    reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
+    -- hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
+    return $ fmap unwrapNodes $ join reply
+
+updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO ()
+updateRouting client routing orouter naddr msg
+    | PacketKind 0x21 <- msgType msg = return () -- ignore lan discovery
+    | otherwise                      = do
+    case prefer4or6 naddr Nothing of
+        Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
+        Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher4 routing)
+        Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+
+updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
+updateTable client naddr orouter committee refresher = do
+        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
+        when (nodeIP self /= nodeIP naddr) $ do
+            -- TODO: IP address vote?
+            insertNode (toxKademlia client committee orouter refresher) naddr
+
+toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter
+                -> BucketRefresher NodeId NodeInfo
+                -> Kademlia NodeId NodeInfo
+toxKademlia client committee orouter refresher
+    = Kademlia quietInsertions
+               toxSpace
+               (vanillaIO (refreshBuckets refresher) $ ping client)
+                   { tblTransition = \tr -> do
+                        io1 <- transitionCommittee committee tr
+                        io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
+                        hookBucketList toxSpace (refreshBuckets refresher) orouter tr
+                        return $ do
+                            io1 >> io2
+                            {-
+                            hPutStrLn stderr $ unwords
+                                [ show (transitionedTo tr)
+                                , show (transitioningNode tr)
+                                ]
+                            -}
+                            return ()
+                   }
+
+transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
+transitionCommittee committee (RoutingTransition ni Stranger) = do
+    delVote committee (nodeId ni)
+    return $ do
+        -- hPutStrLn stderr $ "delVote "++show (nodeId ni)
+        return ()
+transitionCommittee committee _ = return $ return ()
+
+type Handler = MethodHandler String TransactionId NodeInfo Message
+
+isPing :: (f Ping -> Ping) ->  DHTMessage f -> Either String Ping
+isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
+isPing _      _           = Left "Bad ping"
+
+mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
+mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)
+
+isGetNodes :: (f GetNodes -> GetNodes) ->  DHTMessage f -> Either String GetNodes
+isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
+isGetNodes _      _               = Left "Bad GetNodes"
+
+mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
+mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)
+
+isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
+isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
+isCookieRequest _      _                    = Left "Bad cookie request"
+
+mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie -> DHTMessage ((,) Nonce8)
+mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
+
+isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
+isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
+isDHTRequest _      _                        = Left "Bad dht relay request"
+
+dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
+dhtRequestH ni req = do
+    hPutStrLn stderr $ "Unhandled DHT Request: " ++ show req
+
+handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
+handlers _      routing PingType          = Just $ MethodHandler (isPing snd) mkPong            $ pingH
+handlers _      routing GetNodesType      = Just $ MethodHandler (isGetNodes snd) mkSendNodes   $ getNodesH routing
+handlers crypto _       CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
+handlers _      _       DHTRequestType    = Just $ NoReply (isDHTRequest snd) $ dhtRequestH
+handlers _      _       typ               = error $ "TODO DHT handlers " ++ show typ
+
+nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
+nodeSearch client  = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = getNodes client
+    }
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
new file mode 100644
index 00000000..2e5649d3
--- /dev/null
+++ b/src/Network/Tox/DHT/Transport.hs
@@ -0,0 +1,478 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Network.Tox.DHT.Transport
+    ( parseDHTAddr
+    , encodeDHTAddr
+    , forwardDHTRequests
+    , module Network.Tox.NodeId
+    , DHTMessage(..)
+    , Ping(..)
+    , Pong(..)
+    , GetNodes(..)
+    , SendNodes(..)
+    , DHTPublicKey(..)
+    , FriendRequest(..)
+    , NoSpam(..)
+    , verifyChecksum
+    , CookieRequest(..)
+    , CookieResponse(..)
+    , Cookie(..)
+    , CookieData(..)
+    , DHTRequest
+    , mapMessage
+    , encrypt
+    , decrypt
+    , dhtMessageType
+    , asymNodeInfo
+    ) where
+
+import Network.Tox.NodeId
+import Crypto.Tox hiding (encrypt,decrypt)
+import qualified Crypto.Tox as ToxCrypto
+import Network.QueryResponse
+
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Bool
+import qualified Data.ByteString.Char8  as B8
+import qualified Data.ByteString  as B
+         ;import Data.ByteString  (ByteString)
+import Data.Functor.Contravariant
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize             as S
+import Data.Tuple
+import Data.Word
+import Foreign.C (CTime(..))
+import Network.Socket
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Base16 as Base16
+import Data.Char (isSpace)
+
+type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
+type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
+
+
+data DHTMessage (f :: * -> *)
+    = DHTPing (Asymm (f Ping))
+    | DHTPong (Asymm (f Pong))
+    | DHTGetNodes (Asymm (f GetNodes))
+    | DHTSendNodes (Asymm (f SendNodes))
+    | DHTCookieRequest (Asymm (f CookieRequest))
+    | DHTCookie Nonce24 (f Cookie)
+    | DHTDHTRequest PublicKey (Asymm (f DHTRequest))
+    | DHTLanDiscovery NodeId
+
+deriving instance ( Show (f Cookie)
+                  , Show (Asymm (f Ping))
+                  , Show (Asymm (f Pong))
+                  , Show (Asymm (f GetNodes))
+                  , Show (Asymm (f SendNodes))
+                  , Show (Asymm (f CookieRequest))
+                  , Show (Asymm (f DHTRequest))
+                  ) => Show (DHTMessage f)
+
+mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b
+mapMessage f (DHTPing          a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTPong          a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTGetNodes      a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTSendNodes     a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTCookieRequest a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTDHTRequest  _ a)      = Just $ f (asymmNonce a) (asymmData a)
+mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie
+mapMessage f (DHTLanDiscovery nid)     = Nothing
+
+
+instance Sized Ping where size = ConstSize 1
+instance Sized Pong where size = ConstSize 1
+
+parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr))
+parseDHTAddr crypto (msg,saddr)
+    | Just (typ,bs) <- B.uncons msg
+    , let right = return $ Right (msg,saddr)
+          left  = either (const right) (return . Left)
+    = case typ of
+    0x00 -> left $ direct bs saddr DHTPing
+    0x01 -> left $ direct bs saddr DHTPong
+    0x02 -> left $ direct bs saddr DHTGetNodes
+    0x04 -> left $ direct bs saddr DHTSendNodes
+    0x18 -> left $ direct bs saddr DHTCookieRequest
+    0x19 -> do
+        cs <- atomically $ readTVar (pendingCookies crypto)
+        let ni = fromMaybe (noReplyAddr saddr) $ do
+                    (cnt,key) <- lookup saddr cs
+                    either (const Nothing) Just $ nodeInfo (key2id key) saddr
+        left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni)
+    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
+    0x21 -> left $ do
+               nid <- runGet get bs
+               ni <- nodeInfo nid saddr
+               return (DHTLanDiscovery nid, ni)
+    _ -> right
+
+encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr)
+encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni)
+
+dhtMessageType :: ( Serialize (f DHTRequest)
+                  , Serialize (f Cookie), Serialize (f CookieRequest)
+                  , Serialize (f SendNodes), Serialize (f GetNodes)
+                  , Serialize (f Pong), Serialize (f Ping)
+                  ) => DHTMessage f -> (Word8, Put)
+dhtMessageType (DHTPing           a) = (0x00, putAsymm a)
+dhtMessageType (DHTPong           a) = (0x01, putAsymm a)
+dhtMessageType (DHTGetNodes       a) = (0x02, putAsymm a)
+dhtMessageType (DHTSendNodes      a) = (0x04, putAsymm a)
+dhtMessageType (DHTCookieRequest  a) = (0x18, putAsymm a)
+dhtMessageType (DHTCookie       n x) = (0x19, put n >> put x)
+dhtMessageType (DHTDHTRequest   k a) = (0x20, putPublicKey k >> putAsymm a)
+dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid)
+
+putMessage :: DHTMessage Encrypted8 -> Put
+putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
+
+getCookie :: Get (Nonce24, Encrypted8 Cookie)
+getCookie = get
+
+getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest))
+getDHTReqest = (,) <$> getPublicKey <*> getAsymm
+
+-- ## DHT Request packets
+--
+-- | Length | Contents                  |
+-- |:-------|:--------------------------|
+-- | `1`    | `uint8_t` (0x20)          |
+-- | `32`   | receiver's DHT public key |
+--   ...      ...
+
+
+getDHT :: Sized a => Get (Asymm (Encrypted8 a))
+getDHT = getAsymm
+
+
+-- Throws an error if called with a non-internet socket.
+direct :: Sized a => ByteString
+                  -> SockAddr
+                  -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8)
+                  -> Either String (DHTMessage Encrypted8, NodeInfo)
+direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
+
+-- Throws an error if called with a non-internet socket.
+asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo
+asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr
+
+
+fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
+fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
+
+-- Throws an error if called with a non-internet socket.
+noReplyAddr :: SockAddr -> NodeInfo
+noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
+
+
+data DHTRequest
+    -- #### NAT ping request
+    --
+    --   Length   Contents
+    --  :------- :-------------------------
+    --   `1`      `uint8_t` (0xfe)
+    --   `1`      `uint8_t` (0x00)
+    --   `8`      `uint64_t` random number
+    = NATPing Nonce8
+    -- #### NAT ping response
+    --
+    --   Length   Contents
+    --  :------- :-----------------------------------------------------------------
+    --   `1`      `uint8_t` (0xfe)
+    --   `1`      `uint8_t` (0x01)
+    --   `8`      `uint64_t` random number (the same that was received in request)
+    | NATPong Nonce8
+    | DHTPK LongTermKeyWrap
+    -- From docs/Hardening_docs.txt
+    --
+    -- All hardening requests must contain exactly 384 bytes of data. (The data sent
+    -- must be padded with zeros if it is smaller than that.)
+    --
+    -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to
+    -- test.)][client_id(32 bytes) the id to query the node with.][padding]
+    --
+    -- packet id: CRYPTO_PACKET_HARDENING (48)
+    | Hardening -- TODO
+ deriving Show
+
+instance Sized DHTRequest where
+    size = VarSize $ \case
+        NATPing   _ -> 10
+        NATPong   _ -> 10
+        DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-}
+                        + case size of
+                            ConstSize n -> n
+                            VarSize f -> f (wrapData wrap)
+        Hardening -> 1{-typ-} + 384
+
+instance Serialize DHTRequest where
+    get = do
+        tag <- get
+        case tag :: Word8 of
+            0xfe -> do
+                direction <- get
+                bool NATPong NATPing (direction==(0::Word8)) <$> get
+            0x9c -> DHTPK <$> get
+            0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING
+            _ -> fail ("unrecognized DHT request: "++show tag)
+    put (NATPing n) = put (0xfe00 :: Word16) >> put n
+    put (NATPong n) = put (0xfe01 :: Word16) >> put n
+    put (DHTPK pk)  = put (0x9c :: Word8) >> put pk
+    put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO
+
+-- DHT public key packet:
+-- (As Onion data packet?)
+--
+-- | Length      | Contents                            |
+-- |:------------|:------------------------------------|
+-- | `1`         | `uint8_t` (0x9c)                    |
+-- | `8`         | `uint64_t` `no_replay`              |
+-- | `32`        | Our DHT public key                  |
+-- | `[39, 204]` | Maximum of 4 nodes in packed format |
+data DHTPublicKey = DHTPublicKey
+    { dhtpkNonce :: Word64    -- ^ The `no_replay` number is protection if
+                              -- someone tries to replay an older packet and
+                              -- should be set to an always increasing number.
+                              -- It is 8 bytes so you should set a high
+                              -- resolution monotonic time as the value.
+    , dhtpk      :: PublicKey -- dht public key
+    , dhtpkNodes :: SendNodes -- other reachable nodes
+    }
+ deriving (Eq, Show)
+
+
+-- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto)
+-- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes]
+data FriendRequest = FriendRequest
+    { friendNoSpam      :: Word32
+    , friendRequestText :: ByteString -- UTF8
+    }
+ deriving (Eq, Show)
+
+data NoSpam = NoSpam !Word32 !(Maybe Word16)
+
+instance Read NoSpam where
+    readsPrec d s = case break isSpace s of
+        (ws,rs) | (length ws == 8)  -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        (ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
+        _                           -> []
+
+base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base64decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+           =<< Base64.decode (B8.pack s)
+
+base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
+base16decode rs getter s =
+    either fail (\a -> return (a,rs))
+        $ runGet getter
+        $ fst
+        $ Base16.decode (B8.pack s)
+
+verifyChecksum :: PublicKey -> Word16 -> Either String ()
+verifyChecksum _ _ = return () -- TODO
+
+
+-- When sent as a DHT request packet (this is the data sent in the DHT request
+-- packet):
+--
+--   Length     Contents
+--  :--------- :-------------------------------
+--   `1`        `uint8_t` (0x9c)
+--   `32`       Long term public key of sender
+--   `24`       Nonce
+--   variable   Encrypted payload
+data LongTermKeyWrap = LongTermKeyWrap
+    { wrapLongTermKey :: PublicKey
+    , wrapNonce       :: Nonce24
+    , wrapData        :: Encrypted DHTPublicKey
+    }
+ deriving Show
+
+instance Serialize LongTermKeyWrap where
+    get = LongTermKeyWrap <$> getPublicKey <*> get <*> get
+    put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta
+
+
+instance Sized DHTPublicKey where
+    -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size.
+    -- WARNING: Serialize instance does not include this byte FIXME
+    size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of
+                                                    ConstSize nodes -> nodes
+                                                    VarSize sznodes -> sznodes nodes
+
+instance Sized Word32 where size = ConstSize 4
+
+-- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte
+-- where the DHTPublicKey type does include its tag.
+instance Sized FriendRequest where
+    size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length)
+
+instance Serialize DHTPublicKey where
+    -- TODO: This should agree with Sized instance.
+    get = DHTPublicKey <$> get <*> getPublicKey <*> get
+    put (DHTPublicKey nonce key nodes) = do
+        put nonce
+        putPublicKey key
+        put nodes
+
+instance Serialize FriendRequest where
+    get = FriendRequest <$> get <*> (remaining >>= getBytes)
+    put (FriendRequest nospam txt) = put nospam >> putByteString txt
+
+newtype GetNodes = GetNodes NodeId
+    deriving (Eq,Ord,Show,Read,S.Serialize)
+
+instance Sized GetNodes where
+    size = ConstSize 32 -- TODO This right?
+
+newtype SendNodes = SendNodes [NodeInfo]
+    deriving (Eq,Ord,Show,Read)
+
+instance Sized SendNodes where
+    size = VarSize $ \(SendNodes ns) -> case size of
+            ConstSize nodeFormatSize -> nodeFormatSize * length ns
+            VarSize   nsize          -> sum $ map nsize ns
+
+instance S.Serialize SendNodes where
+    get = do
+        cnt <- S.get :: S.Get Word8
+        ns <- sequence $ replicate (fromIntegral cnt) S.get
+        return $ SendNodes ns
+
+    put (SendNodes ns) = do
+        let ns' = take 4 ns
+        S.put (fromIntegral (length ns') :: Word8)
+        mapM_ S.put ns'
+
+data Ping = Ping deriving Show
+data Pong = Pong deriving Show
+
+instance S.Serialize Ping where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 0
+                then fail "Malformed ping."
+                else return Ping
+    put Ping = S.put (0 :: Word8)
+
+instance S.Serialize Pong where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 1
+                then fail "Malformed pong."
+                else return Pong
+    put Pong = S.put (1 :: Word8)
+
+newtype CookieRequest = CookieRequest PublicKey
+ deriving (Eq, Show)
+newtype CookieResponse = CookieResponse Cookie
+ deriving (Eq, Show)
+
+data Cookie = Cookie Nonce24 (Encrypted CookieData)
+ deriving (Eq, Ord, Show)
+
+instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
+
+instance Serialize Cookie where
+    get = Cookie <$> get <*> get
+    put (Cookie nonce dta) = put nonce >> put dta
+
+data CookieData = CookieData   --   16 (mac)
+    { cookieTime  :: Word64    --    8
+    , longTermKey :: PublicKey --   32
+    , dhtKey      :: PublicKey -- + 32
+    }                          -- = 88 bytes when encrypted.
+
+instance Sized CookieData where
+    size = ConstSize 72
+
+instance Serialize CookieData where
+    get = CookieData <$> get
+                     <*> (id2key <$> get)
+                     <*> (id2key <$> get)
+    put (CookieData tm userkey dhtkey) = do
+        put tm
+        put (key2id userkey)
+        put (key2id dhtkey)
+
+instance Sized CookieRequest where
+    size = ConstSize 64 -- 32 byte key + 32 byte padding
+
+instance Serialize CookieRequest where
+    get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
+    put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
+
+forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
+forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
+ where
+    await' :: HandleHi a -> IO a
+    await' pass = awaitMessage dht $ \case
+        Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
+            -> do mni <- closeLookup target
+                  -- Forward the message if the target is in our close list.
+                  forM_ mni $ \ni -> sendMessage dht ni m
+                  await' pass
+        m -> pass m
+
+encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo)
+encrypt crypto msg ni = do
+    let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain
+    m <- sequenceMessage $ transcode cipher msg
+    return (m, ni)
+
+encryptMessage :: Serialize a =>
+                  TransportCrypto ->
+                  PublicKey ->
+                  Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a)
+encryptMessage crypto destKey n arg = do
+    let plain  = encodePlain $ swap $ either id asymmData arg
+    secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n
+    return $ E8 $ ToxCrypto.encrypt secret plain
+
+decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo))
+decrypt crypto msg ni = do
+    let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c
+    msg' <- sequenceMessage $ transcode decipher msg
+    return $ fmap (, ni) $ sequenceMessage msg'
+
+decryptMessage :: Serialize x =>
+                  TransportCrypto
+                  -> Nonce24
+                  -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x))
+                  -> IO ((Either String ∘ ((,) Nonce8)) x)
+decryptMessage crypto n arg = do
+    let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg
+        plain8           = Composed . fmap swap . (>>= decodePlain)
+    secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n
+    return $ plain8 $ ToxCrypto.decrypt secret e
+
+sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
+sequenceMessage (DHTPing asym)              = fmap DHTPing          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTPong asym)              = fmap DHTPong          $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTGetNodes asym)          = fmap DHTGetNodes      $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTSendNodes asym)         = fmap DHTSendNodes     $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookieRequest asym)     = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTCookie n dta)           = fmap (DHTCookie n)    $ uncomposed dta
+sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
+sequenceMessage (DHTLanDiscovery nid)       = pure $ DHTLanDiscovery nid
+
+transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g
+transcode f (DHTPing asym)              = DHTPing              $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTPong asym)              = DHTPong              $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTGetNodes asym)          = DHTGetNodes          $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTSendNodes asym)         = DHTSendNodes         $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTCookieRequest asym)     = DHTCookieRequest     $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTCookie n dta)           = DHTCookie n          $ f n  $ Left dta
+transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) }
+transcode f (DHTLanDiscovery nid)       = DHTLanDiscovery nid
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
new file mode 100644
index 00000000..95604108
--- /dev/null
+++ b/src/Network/Tox/NodeId.hs
@@ -0,0 +1,470 @@
+{- LANGUAGE ApplicativeDo              -}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+{- LANGUAGE TypeApplications           -}
+module Network.Tox.NodeId
+    ( NodeInfo(..)
+    , NodeId
+    , nodeInfo
+    , nodeAddr
+    , zeroID
+    , key2id
+    , id2key
+    , getIP
+    , xorNodeId
+    , testNodeIdBit
+    , sampleNodeId) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Crypto.Error.Types                     (CryptoFailable (..),
+                                               throwCryptoError)
+import Crypto.PubKey.Curve25519
+import qualified Data.Aeson                   as JSON
+         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
+import Data.Bits.ByteString                   ()
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               as BA (ByteArrayAccess)
+import qualified Data.ByteString              as B
+         ;import Data.ByteString              (ByteString)
+import qualified Data.ByteString.Base16       as Base16
+import qualified Data.ByteString.Base64       as Base64
+import qualified Data.ByteString.Char8        as C8
+import Data.Char
+import Data.Data
+import Data.Hashable
+import Data.IP
+import Data.Serialize                         as S
+import Data.Word
+import Foreign.Storable
+import GHC.TypeLits
+import Network.Address                        hiding (nodePort)
+import System.IO.Unsafe                       (unsafeDupablePerformIO)
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.Read
+import Data.Bits
+import Crypto.Tox
+import Foreign.Ptr
+import Data.Function
+import System.Endian
+
+-- | perform io for hashes that do allocation and ffi.
+-- unsafeDupablePerformIO is used when possible as the
+-- computation is pure and the output is directly linked
+-- to the input. we also do not modify anything after it has
+-- been returned to the user.
+unsafeDoIO :: IO a -> a
+#if __GLASGOW_HASKELL__ > 704
+unsafeDoIO = unsafeDupablePerformIO
+#else
+unsafeDoIO = unsafePerformIO
+#endif
+
+unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64]
+unpackPublicKey bs = loop 0
+  where loop i
+            | i == (BA.length bs `div` 8) = []
+            | otherwise =
+                let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i)
+                 in v : loop (i+1)
+
+packPublicKey :: BA.ByteArray bs => [Word64] -> bs
+packPublicKey ws = BA.allocAndFreeze (8 * length ws) $
+    flip fix ws $ \loop ys ptr -> case ys of
+        [] -> return ()
+        x:xs -> do poke ptr (toBE64 x)
+                   loop xs (plusPtr ptr 8)
+
+-- We represent the node id redundantly in two formats.  The [Word64] format is
+-- convenient for short-circuiting xor/distance comparisons.  The PublicKey
+-- format is convenient for encryption.
+data NodeId = NodeId [Word64] !(Maybe PublicKey)
+
+instance Eq NodeId where
+ (NodeId ws _) == (NodeId xs _)
+  =         ws == xs
+
+instance Ord NodeId where
+    compare (NodeId ws _) (NodeId xs _) = compare ws xs
+
+instance Sized NodeId where size = ConstSize 32
+
+key2id :: PublicKey -> NodeId
+key2id k = NodeId (unpackPublicKey k) (Just k)
+
+bs2id :: ByteString -> NodeId
+bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs
+
+id2key :: NodeId -> PublicKey
+id2key (NodeId ws (Just key)) = key
+id2key (NodeId key Nothing)   = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes)
+
+zeroKey :: PublicKey
+zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0
+
+zeroID :: NodeId
+zeroID = NodeId (replicate 4 0) (Just zeroKey)
+
+-- | Convert to and from a Base64 variant that uses .- instead of +/.
+nmtoken64 :: Bool -> Char -> Char
+nmtoken64 False '.' = '+'
+nmtoken64 False '-' = '/'
+nmtoken64 True  '+' = '.'
+nmtoken64 True  '/' = '-'
+nmtoken64 _     c   = c
+
+instance Read NodeId where
+    readsPrec _ str
+        | Right bs <- fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str)
+        , CryptoPassed pub <- publicKey bs -- B.length bs == 32
+                    = [ (key2id pub, drop 43 str) ]
+        | otherwise = []
+
+instance Show NodeId where
+    show nid = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert $ id2key nid
+
+instance S.Serialize NodeId where
+    get = key2id <$> getPublicKey
+    put nid = putPublicKey $ id2key nid
+
+instance Hashable NodeId where
+    hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws)
+
+testNodeIdBit :: NodeId -> Word -> Bool
+testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available.
+  | fromIntegral i < 256 -- 256 bits
+  , (q, r) <- quotRem (fromIntegral i) 64
+  = testBit (ws !! q) (63 - r)
+  |     otherwise      = False
+
+xorNodeId :: NodeId -> NodeId -> NodeId
+xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing
+
+sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
+sampleNodeId gen (NodeId self k) (q,m,b)
+    | q <= 0    = bs2id <$> gen 32
+    | q >= 32   = pure (NodeId self k)
+    | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend?
+          bw = shiftL (fromIntegral b) (8*(7-r))
+          mw = bw - 1 :: Word64
+          (hd, t0 : _) = splitAt (qw-1) self
+          h = xor bw (complement mw .&. t0)
+    = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs ->
+        let (w:ws) = unpackPublicKey bs
+        in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP   :: IP
+  , nodePort :: PortNumber
+  }
+ deriving (Eq,Ord)
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo nid (IPv4 ip) port)
+        = JSON.object [ "public_key" .= show nid
+                      , "ipv4" .= show ip
+                      , "port" .= (fromIntegral port :: Int)
+                      ]
+    toJSON (NodeInfo nid (IPv6 ip6) port)
+        | Just ip <- un4map ip6
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv4" .= show ip
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+        | otherwise
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv6" .= show ip6
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+instance FromJSON NodeInfo where
+    parseJSON (JSON.Object v) = do
+        nidstr <- v JSON..: "public_key"
+        ip6str <- v JSON..:? "ipv6"
+        ip4str <- v JSON..:? "ipv4"
+        portnum <- v JSON..: "port"
+        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
+              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        let (bs,_) = Base16.decode (C8.pack nidstr)
+            enid   = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
+        idbs <- (guard (B.length bs == 32) >> return bs)
+                <|> either fail (return . B.drop 1) enid
+        return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16))
+
+getIP :: Word8 -> S.Get IP
+getIP 0x02 = IPv4 <$> S.get
+getIP 0x0a = IPv6 <$> S.get
+getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
+getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
+getIP x    = fail ("unsupported address family ("++show x++")")
+
+instance Sized NodeInfo where
+    size = VarSize $ \(NodeInfo nid ip port) ->
+            case ip of
+                IPv4 _ -> 39 -- 35 +  4 = 1 + 4 + 2 + 32
+                IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32
+
+instance S.Serialize NodeInfo where
+    get = do
+        addrfam <- S.get :: S.Get Word8
+        let fallback = do -- FIXME: Handle unrecognized address families.
+                IPv6 <$> S.get
+                return $ IPv6 (read "::" :: IPv6)
+        ip <- getIP addrfam <|> fallback
+        port <- S.get :: S.Get PortNumber
+        nid <- S.get
+        return $ NodeInfo nid ip port
+
+    put (NodeInfo nid ip port) = do
+        case ip of
+            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+        S.put port
+        S.put nid
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+b64digit :: Char -> Bool
+b64digit '.' = True
+b64digit '+' = True
+b64digit '-' = True
+b64digit '/' = True
+b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 43 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (not . isSpace)
+        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy b64digit)
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
+                              Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs)
+                              _                              -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    let raddr = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+    (ip,port) <- case RP.readP_to_S raddr addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+-- The Hashable instance depends only on the IP address and port number.
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
+
+
+
+
+{-
+type NodeId = PubKey
+
+pattern NodeId bs = PubKey bs
+
+-- TODO: This should probably be represented by Curve25519.PublicKey, but
+-- ByteString has more instances...
+newtype PubKey = PubKey ByteString
+ deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)
+
+instance Serialize PubKey where
+    get = PubKey <$> getBytes 32
+    put (PubKey bs) = putByteString bs
+
+instance Show PubKey where
+    show (PubKey bs) = C8.unpack $ Base16.encode bs
+
+instance FiniteBits PubKey where
+    finiteBitSize _ = 256
+
+instance Read PubKey where
+    readsPrec _ str
+        | (bs, xs) <- Base16.decode $ C8.pack str
+        , B.length bs == 32
+                    = [ (PubKey bs, drop 64 str) ]
+        | otherwise = []
+
+
+
+
+data NodeInfo = NodeInfo
+  { nodeId   :: NodeId
+  , nodeIP   :: IP
+  , nodePort :: PortNumber
+  }
+ deriving (Eq,Ord,Data)
+
+instance Data PortNumber where
+    dataTypeOf _ = mkNoRepType "PortNumber"
+    toConstr _     = error "PortNumber.toConstr"
+    gunfold _ _    = error "PortNumber.gunfold"
+
+instance ToJSON NodeInfo where
+    toJSON (NodeInfo nid (IPv4 ip) port)
+        = JSON.object [ "public_key" .= show nid
+                      , "ipv4" .= show ip
+                      , "port" .= (fromIntegral port :: Int)
+                      ]
+    toJSON (NodeInfo nid (IPv6 ip6) port)
+        | Just ip <- un4map ip6
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv4" .= show ip
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+        | otherwise
+          = JSON.object [ "public_key" .= show nid
+                        , "ipv6" .= show ip6
+                        , "port" .= (fromIntegral port :: Int)
+                        ]
+instance FromJSON NodeInfo where
+    parseJSON (JSON.Object v) = do
+        nidstr <- v JSON..: "public_key"
+        ip6str <- v JSON..:? "ipv6"
+        ip4str <- v JSON..:? "ipv4"
+        portnum <- v JSON..: "port"
+        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
+              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        let (bs,_) = Base16.decode (C8.pack nidstr)
+        guard (B.length bs == 32)
+        return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
+
+getIP :: Word8 -> S.Get IP
+getIP 0x02 = IPv4 <$> S.get
+getIP 0x0a = IPv6 <$> S.get
+getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
+getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
+getIP x    = fail ("unsupported address family ("++show x++")")
+
+instance S.Serialize NodeInfo where
+    get = do
+        addrfam <- S.get :: S.Get Word8
+        ip <- getIP addrfam
+        port <- S.get :: S.Get PortNumber
+        nid <- S.get
+        return $ NodeInfo nid ip port
+
+    put (NodeInfo nid ip port) = do
+        case ip of
+            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
+            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
+        S.put port
+        S.put nid
+
+-- node format:
+-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
+-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
+-- [port (in network byte order), length=2 bytes]
+-- [char array (node_id), length=32 bytes]
+--
+
+
+hexdigit :: Char -> Bool
+hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
+
+instance Read NodeInfo where
+  readsPrec i = RP.readP_to_S $ do
+    RP.skipSpaces
+    let n = 64 -- characters in node id.
+        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
+                      RP.+++ RP.munch (not . isSpace)
+        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
+                      RP.char '@' RP.+++ RP.satisfy isSpace
+                      addrstr <- parseAddr
+                      nid <- case Base16.decode $ C8.pack hexhash of
+                              (bs,_) | B.length bs==32 -> return (PubKey bs)
+                              _                        -> fail "Bad node id."
+                      return (nid,addrstr)
+    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
+    let raddr = do
+            ip <- RP.between (RP.char '[') (RP.char ']')
+                         (IPv6 <$> RP.readS_to_P (readsPrec i))
+                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
+            _    <- RP.char ':'
+            port <- toEnum <$> RP.readS_to_P (readsPrec i)
+            return (ip, port)
+
+    (ip,port) <- case RP.readP_to_S raddr addrstr of
+                    [] -> fail "Bad address."
+                    ((ip,port),_):_ -> return (ip,port)
+    return $ NodeInfo nid ip port
+
+
+-- The Hashable instance depends only on the IP address and port number.
+instance Hashable NodeInfo where
+  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
+  {-# INLINE hashWithSalt #-}
+
+
+instance Show NodeInfo where
+    showsPrec _ (NodeInfo nid ip port) =
+        shows nid . ('@' :) . showsip . (':' :) . shows port
+     where
+        showsip
+            | IPv4 ip4 <- ip                          = shows ip4
+            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
+            | otherwise                               = ('[' :) . shows ip . (']' :)
+
+nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
+nodeInfo nid saddr
+    | Just ip <- fromSockAddr saddr
+    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
+    | otherwise                       = Left "Address family not supported."
+
+zeroID :: NodeId
+zeroID = PubKey $ B.replicate 32 0
+
+-}
+
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
+
+
+newtype ForwardPath (n::Nat) = ForwardPath ByteString
+ deriving (Eq, Ord,Data)
+
+{-
+class KnownNat n => OnionPacket n where
+    mkOnion :: ReturnPath n -> Packet -> Packet
+instance OnionPacket 0 where mkOnion _ = id
+instance OnionPacket 3 where mkOnion = OnionResponse3
+-}
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
new file mode 100644
index 00000000..e792aa50
--- /dev/null
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Network.Tox.Onion.Handlers where
+
+import Network.Kademlia.Search
+import Network.Tox.DHT.Transport
+import Network.Tox.DHT.Handlers hiding (Message,Client)
+import Network.Tox.Onion.Transport
+import Network.QueryResponse as QR hiding (Client)
+import qualified Network.QueryResponse as QR (Client)
+import Crypto.Tox
+import qualified Data.Wrapper.PSQ             as PSQ
+         ;import Data.Wrapper.PSQ             (PSQ)
+import Crypto.Error.Types                     (CryptoFailable (..),
+                                               throwCryptoError)
+import Control.Arrow
+
+import System.IO
+import qualified Data.ByteArray               as BA
+import Data.Function
+import Data.Serialize as S
+import qualified Data.Wrapper.PSQInt as Int
+import Network.Kademlia
+import Network.Address               (WantIP (..), ipFamily, testIdBit)
+import qualified Network.Kademlia.Routing as R
+import Control.TriadCommittee
+import qualified Data.MinMaxPSQ               as MinMaxPSQ
+         ;import Data.MinMaxPSQ               (MinMaxPSQ')
+import Network.BitTorrent.DHT.Token           as Token
+
+import Control.Exception hiding (Handler)
+import Control.Monad
+import Control.Concurrent.STM
+import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+import Network.Socket
+import Data.IP
+import Data.Maybe
+import Data.Bits
+import Data.Ord
+import Data.Functor.Identity
+
+type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
+type Message = OnionMessage Identity
+
+classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
+classify msg = go msg
+ where
+    go (OnionAnnounce         announce)    = IsQuery AnnounceType
+                                                $ TransactionId (snd $ runIdentity $ asymmData announce)
+                                                                (asymmNonce announce)
+    go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
+    go (OnionToRoute          {})          = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
+    go (OnionToRouteResponse  {})          = IsResponse              (TransactionId (Nonce8 0) (Nonce24 zeros24))
+
+-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
+-- some secret bytes generated when the instance is created, the current time
+-- divided by a 20 second timeout, the public key of the requester and the source
+-- ip/port that the packet was received from. Since the ip/port that the packet
+-- was received from is in the `ping_id`, the announce packets being sent with a
+-- ping id must be sent using the same path as the packet that we received the
+-- `ping_id` from or announcing will fail.
+--
+-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
+-- time (20 to 40 seconds) for a peer to announce himself while taking in count
+-- all the possible delays with some extra seconds.
+announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
+announceH routing toks keydb oaddr req = do
+    case () of
+        _ | announcePingId req == zeros32
+          -> go False
+
+        _ -> let Nonce32 bs = announcePingId req
+                 tok        = fromPaddedByteString 32 bs
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
+        `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
+ where
+    go withTok = do
+        let naddr = onionNodeInfo oaddr
+        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
+        tm <- getPOSIXTime
+
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
+        hPutStrLn stderr $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
+                                   , "           announceSeeking = " ++ show (announceSeeking req)
+                                   , "           withTok         = " ++ show withTok
+                                   , "           storing         = " ++ maybe "False" (const "True") storing
+                                   ]
+        record <- atomically $ do
+            forM_ storing $ \retpath -> when withTok $ do
+                let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
+                    -- Note: The following distance calculation assumes that
+                    -- our nodeid doesn't change and is the same for both
+                    -- routing4 and routing6.
+                    d = xorNodeId (nodeId (tentativeId routing))
+                                  (announceSeeking req)
+                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
+            ks <- readTVar keydb
+            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
+        let k = case record of
+                Nothing                    -> NotStored newtok
+                Just _  | isJust storing   -> Acknowledged newtok
+                Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
+        let response = AnnounceResponse k ns
+        hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
+        return response
+
+dataToRouteH ::
+          TVar AnnouncedKeys
+          -> Transport err (OnionDestination r) (OnionMessage f)
+          -> addr
+          -> OnionMessage f
+          -> IO ()
+dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
+    let k = key2id pub
+    hPutStrLn stderr $ "dataToRouteH "++ show k
+    mb <- atomically $ do
+        ks <- readTVar keydb
+        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
+            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
+            return rpath
+    hPutStrLn stderr $ "dataToRouteH "++ show (fmap (const ()) mb)
+    forM_ mb $ \rpath -> do
+        -- forward
+        hPutStrLn stderr $ "dataToRouteH sendMessage"
+        sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
+        hPutStrLn stderr $ "Forwarding data-to-route -->"++show k
+
+type NodeDistance = NodeId
+
+data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
+
+toOnionDestination :: AnnouncedRoute -> OnionDestination r
+toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
+
+data AnnouncedKeys = AnnouncedKeys
+    { keyByAge :: !(PSQ NodeId (Down POSIXTime)) -- TODO: timeout of 300 seconds
+    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int,AnnouncedRoute))
+    }
+
+
+insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
+insertKey tm pub toxpath d keydb = AnnouncedKeys
+    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
+    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
+                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
+                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
+    }
+
+areq :: Message -> Either String AnnounceRequest
+areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
+areq _                     = Left "Unexpected non-announce OnionMessage"
+
+handlers :: Transport err (OnionDestination r) Message
+            -> Routing
+            -> TVar SessionTokens
+            -> TVar AnnouncedKeys
+            -> PacketKind
+            -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
+handlers net routing toks keydb AnnounceType
+    = Just
+    $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
+    $ announceH routing toks keydb
+handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
+
+
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
+toxidSearch getTimeout crypto client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = getRendezvous getTimeout crypto client
+    }
+
+announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+                   -> MethodSerializer
+                        TransactionId
+                        (OnionDestination r)
+                        (OnionMessage Identity)
+                        PacketKind
+                        AnnounceRequest
+                        (Maybe AnnounceResponse)
+announceSerializer getTimeout = MethodSerializer
+    { methodTimeout = getTimeout
+    , method = AnnounceType
+    , wrapQuery = \(TransactionId n8 n24) src dst req ->
+        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
+        OnionAnnounce $ Asymm
+            { -- The public key is our real long term public key if we want to
+              -- announce ourselves, a temporary one if we are searching for
+              -- friends.
+              senderKey = onionKey src
+            , asymmNonce = n24
+            , asymmData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
+unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> ( ns , []                                                        , Just n32)
+        SendBackKey k    -> ( ns , [Rendezvous k ni]                                         , Nothing )
+        Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
+
+-- TODO Announce key to announce peers.
+--
+--   Announce Peers are only put in the 8 closest peers array if they respond
+--   to an announce request. If the peers fail to respond to 3 announce
+--   requests they are deemed timed out and removed.
+--
+--   ...
+--
+--   For this reason, after the peer is announced successfully for 17 seconds,
+--   announce packets are sent aggressively every 3 seconds to each known close
+--   peer (in the list of 8 peers) to search aggressively for peers that know
+--   the peer we are searching for.
+
+-- TODO
+-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
+-- aggressively reannounce itself and search for friends as if it was just
+-- started.
+
+
+sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> AnnounceRequest
+            -> OnionDestination r
+            -> (NodeInfo -> AnnounceResponse -> t)
+            -> IO (Maybe t)
+sendOnion getTimeout client req oaddr unwrap =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrap (onionNodeInfo oaddr))
+          $ join mb
+
+-- | Lookup the secret counterpart for a given alias key.
+getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> TransportCrypto
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
+getRendezvous getTimeout crypto client nid ni = do
+    asel <- atomically $ selectAlias crypto nid
+    let oaddr = OnionDestination asel ni Nothing
+        rkey  = case asel of
+                    SearchingAlias -> Nothing
+                    _              -> Just $ key2id $ rendezvousPublic crypto
+    sendOnion getTimeout client
+        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
+        oaddr
+        (unwrapAnnounceResponse rkey)
+
+putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> PublicKey
+               -> Nonce32
+               -> NodeInfo
+               -> IO (Maybe (Rendezvous, AnnounceResponse))
+putRendezvous getTimeout crypto client pubkey nonce32 ni = do
+    let longTermKey   = key2id pubkey
+        rkey          = rendezvousPublic crypto
+        rendezvousKey = key2id rkey
+    asel <- atomically $ selectAlias crypto longTermKey
+    let oaddr = OnionDestination asel ni Nothing
+    sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
+        $ \ni resp -> (Rendezvous rkey ni, resp)
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
new file mode 100644
index 00000000..5c4544ca
--- /dev/null
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -0,0 +1,927 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module Network.Tox.Onion.Transport
+    ( parseOnionAddr
+    , encodeOnionAddr
+    , parseDataToRoute
+    , encodeDataToRoute
+    , forwardOnions
+    , AliasSelector(..)
+    , OnionDestination(..)
+    , OnionMessage(..)
+    , Rendezvous(..)
+    , DataToRoute(..)
+    , OnionData(..)
+    , AnnouncedRendezvous(..)
+    , AnnounceResponse(..)
+    , AnnounceRequest(..)
+    , Forwarding(..)
+    , ReturnPath(..)
+    , OnionRequest(..)
+    , OnionResponse(..)
+    , Addressed(..)
+    , UDPTransport
+    , KeyRecord(..)
+    , encrypt
+    , decrypt
+    , peelSymmetric
+    , OnionRoute(..)
+    , N3
+    , onionKey
+    , onionAliasSelector
+    , selectAlias
+    , RouteId(..)
+    , routeId
+    ) where
+
+import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
+import Network.QueryResponse
+import Crypto.Tox hiding (encrypt,decrypt)
+import Network.Tox.NodeId
+import qualified Crypto.Tox as ToxCrypto
+import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
+
+import Control.Applicative
+import Control.Arrow
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.ByteString    as B
+         ;import Data.ByteString    (ByteString)
+import Data.Coerce
+import Data.Function
+import Data.Functor.Contravariant
+import Data.Functor.Identity
+import Data.IP
+import Data.Maybe
+import Data.Monoid
+import Data.Serialize               as S
+import Data.Type.Equality
+import Data.Typeable
+import Data.Word
+import Debug.Trace
+import GHC.Generics                 ()
+import GHC.TypeLits
+import Network.Socket
+import System.IO
+import qualified Text.ParserCombinators.ReadP as RP
+import Data.Hashable
+
+type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
+
+type UDPTransport = Transport String SockAddr ByteString
+
+
+getOnionAsymm :: Get (Asymm (Encrypted DataToRoute))
+getOnionAsymm = getAliasedAsymm
+
+putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put
+putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a
+
+data OnionMessage (f :: * -> *)
+    = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8)))
+    | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse)
+    | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm
+    | OnionToRouteResponse (Asymm (Encrypted DataToRoute))
+
+deriving instance ( Show (f (AnnounceRequest, Nonce8))
+                  , Show (f AnnounceResponse)
+                  , Show (f DataToRoute)
+                  ) => Show (OnionMessage f)
+
+msgNonce :: OnionMessage f -> Nonce24
+msgNonce (OnionAnnounce a)               = asymmNonce a
+msgNonce (OnionAnnounceResponse _ n24 _) = n24
+msgNonce (OnionToRoute _ a)              = asymmNonce a
+msgNonce (OnionToRouteResponse a)        = asymmNonce a
+
+data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey
+    deriving (Eq,Show)
+
+data OnionDestination r
+    = OnionToOwner
+        { onionNodeInfo   :: NodeInfo
+        , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
+        }
+    | OnionDestination
+        { onionAliasSelector' :: AliasSelector
+        , onionNodeInfo       :: NodeInfo
+        , onionRouteSpec      :: Maybe r    -- ^ Our own onion-path.
+        }
+    deriving Show
+
+onionAliasSelector :: OnionDestination r -> AliasSelector
+onionAliasSelector (OnionToOwner    {}                         ) = SearchingAlias
+onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel
+
+onionKey :: OnionDestination r -> PublicKey
+onionKey od = id2key . nodeId $ onionNodeInfo od
+
+instance Sized (OnionMessage Encrypted) where
+    size = VarSize $ \case
+        OnionAnnounce a -> case size of ConstSize n -> n + 1
+                                        VarSize f   -> f a + 1
+        OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33
+                                                       VarSize f   -> f x + 33
+        OnionToRoute pubkey a -> case size of ConstSize n -> n + 33
+                                              VarSize f   -> f a + 33
+        OnionToRouteResponse a -> case size of ConstSize n -> n + 1
+                                               VarSize f   -> f a + 1
+
+instance Serialize (OnionMessage Encrypted) where
+    get = do
+        typ <- get
+        case typ :: Word8 of
+            0x83 -> OnionAnnounce <$> getAliasedAsymm
+            0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm
+            t    -> fail ("Unknown onion payload: " ++ show t)
+                    `fromMaybe` getOnionReply t
+    put (OnionAnnounce a)                = putWord8 0x83 >> putAliasedAsymm a
+    put (OnionToRoute k a)               = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a
+    put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
+    put (OnionToRouteResponse a)         = putWord8 0x86 >> putAliasedAsymm a
+
+onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
+onionToOwner asymm ret3 saddr = do
+    ni <- nodeInfo (key2id $ senderKey asymm) saddr
+    return $ OnionToOwner ni ret3
+-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr
+
+
+onion :: Sized msg =>
+               ByteString
+               -> SockAddr
+               -> Get (Asymm (Encrypted msg) -> t)
+               -> Either String (t, OnionDestination r)
+onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
+                         oaddr <- onionToOwner asymm ret3 saddr
+                         return (f asymm, oaddr)
+
+parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
+                  -> (ByteString, SockAddr)
+                  -> IO (Either (OnionMessage Encrypted,OnionDestination r)
+                                (ByteString,SockAddr))
+parseOnionAddr lookupSender (msg,saddr)
+    | Just (typ,bs) <- B.uncons msg
+    , let right = Right (msg,saddr)
+          query = return . either (const right) Left
+    = case typ of
+    0x83 -> query $ onion bs saddr (pure OnionAnnounce)            -- Announce Request
+    0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
+    _ -> case flip runGet bs <$> getOnionReply typ of
+            Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
+                maddr <- lookupSender saddr n8
+                maybe (return right) -- Response unsolicited or too late.
+                      (return . Left . \od -> (msg,od))
+                      maddr
+            Just (Right msg@(OnionToRouteResponse asym)) -> do
+                let ni = asymNodeInfo saddr asym
+                return $ Left (msg, OnionDestination SearchingAlias ni Nothing)
+            _ -> return right
+
+getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
+getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
+getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm
+getOnionReply _    = Nothing
+
+putOnionMsg :: OnionMessage Encrypted -> Put
+putOnionMsg (OnionAnnounce                a) = putOnionAsymm 0x83 (return ()) a
+putOnionMsg (OnionToRoute pubkey          a) = putOnionAsymm 0x85 (putPublicKey pubkey) a
+putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
+putOnionMsg (OnionToRouteResponse         a) = putOnionAsymm 0x86 (return ()) a
+
+newtype RouteId = RouteId Int
+ deriving Show
+
+
+-- We used to derive the RouteId from the Nonce8 associated with the query.
+-- This is problematic because a nonce generated by toxcore will not validate
+-- if it is received via a different route than it was issued.  This is
+-- described by the Tox spec:
+--
+--   Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current
+--   time, some secret bytes generated when the instance is created, the
+--   current time divided by a 20 second timeout, the public key of the
+--   requester and the source ip/port that the packet was received from. Since
+--   the ip/port that the packet was received from is in the `ping_id`, the
+--   announce packets being sent with a ping id must be sent using the same
+--   path as the packet that we received the `ping_id` from or announcing will
+--   fail.
+--
+-- The original idea was:
+--
+-- > routeId :: Nonce8 -> RouteId
+-- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
+--
+-- Instead, we'll just hash the destination node id.
+routeId :: NodeId -> RouteId
+routeId nid = RouteId $ mod (hash nid) 12
+
+
+encodeOnionAddr :: TransportCrypto
+                   -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
+                   -> (OnionMessage Encrypted,OnionDestination RouteId)
+                   -> IO (Maybe (ByteString, SockAddr))
+encodeOnionAddr crypto _ (msg,OnionToOwner ni p) =
+    return $ Just ( runPut $ putResponse (OnionResponse p msg)
+                  , nodeAddr ni )
+encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do
+    encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
+    -- hPutStrLn stderr $ "ONION encode missing routeid"
+    -- return Nothing
+encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
+    let go route = do
+            req <- wrapForRoute crypto msg ni route
+            return ( runPut $ putRequest req
+                   , nodeAddr $ routeNodeA route)
+        mapM' f x = do
+            let _ = x :: Maybe OnionRoute
+            -- hPutStrLn stderr $ "ONION encode sending to  " ++ show ni
+            -- hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
+            mapM f x         -- ONION encode getRoute -> Nothing
+    getRoute ni rid >>= mapM' go
+
+
+forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
+forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp }
+
+forwardAwait :: TransportCrypto -> UDPTransport -> HandleLo a -> IO a
+forwardAwait crypto udp kont = do
+    fix $ \another -> do
+      awaitMessage udp $ \case
+        m@(Just (Right (bs,saddr))) -> case B.head bs of
+            0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto saddr udp another
+            0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto saddr udp another
+            0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto saddr udp another
+            0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp another
+            0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp another
+            0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp another
+            _    -> kont m
+        m -> kont m
+
+forward :: forall c b b1. (Serialize b, Show b) =>
+              (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
+forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs
+
+class SumToThree a b
+
+instance SumToThree N0 N3
+instance SumToThree (S a) b => SumToThree a (S b)
+
+class ( Serialize (ReturnPath n)
+      , Serialize (ReturnPath (S n))
+      , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
+      , ThreeMinus n ~ S (ThreeMinus (S n))
+      ) => LessThanThree n
+
+instance LessThanThree N0
+instance LessThanThree N1
+instance LessThanThree N2
+
+type family ThreeMinus n where
+    ThreeMinus N3 = N0
+    ThreeMinus N2 = N1
+    ThreeMinus N1 = N2
+    ThreeMinus N0 = N3
+
+-- n = 0, 1, 2
+data OnionRequest n = OnionRequest
+    { onionNonce    :: Nonce24
+    , onionForward  :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
+    , pathFromOwner :: ReturnPath n
+    }
+
+deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
+                  , KnownNat (PeanoNat n)
+                  ) => Show (OnionRequest n)
+
+instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
+         , Sized (ReturnPath n)
+         , Serialize (ReturnPath n)
+         , Typeable n
+         ) => Serialize (OnionRequest n) where
+    get = do
+        -- TODO share code with 'getOnionRequest'
+        n24 <- case eqT :: Maybe (n :~: N3) of
+                Just Refl -> return $ Nonce24 zeros24
+                Nothing   -> get
+        cnt <- remaining
+        let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
+        fwd <- isolate fwdsize get
+        rpath <- get
+        return $ OnionRequest n24 fwd rpath
+    put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
+
+-- getRequest :: _
+-- getRequest = OnionRequest <$> get <*> get <*> get
+
+-- n = 1, 2, 3
+-- Attributed (Encrypted (
+
+data OnionResponse n = OnionResponse
+    { pathToOwner :: ReturnPath n
+    , msgToOwner  :: OnionMessage Encrypted
+    }
+
+deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
+
+instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
+    get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
+                                             . getOnionReply)
+    put (OnionResponse p m) = put p >> putOnionMsg m
+
+
+data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
+ deriving (Eq,Show)
+
+instance Sized a => Sized (Addressed a) where
+    size = case size :: Size a of
+            ConstSize n -> ConstSize     $ 1{-family-} + 16{-ip-} + 2{-port-} + n
+            VarSize f   -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)
+
+getForwardAddr :: S.Get SockAddr
+getForwardAddr = do
+    addrfam <- S.get :: S.Get Word8
+    ip <- getIP addrfam
+    case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
+               IPv6 _ -> return ()
+    port <- S.get :: S.Get PortNumber
+    return $ setPort port $ toSockAddr ip
+
+
+putForwardAddr :: SockAddr -> S.Put
+putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
+    port <- sockAddrPort saddr
+    ip <- fromSockAddr $ either id id $ either4or6 saddr
+    return $ do
+        case ip of
+            IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
+            IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
+        S.put port
+
+instance Serialize a => Serialize (Addressed a) where
+    get = Addressed <$> getForwardAddr <*> get
+    put (Addressed addr x) = putForwardAddr addr >> put x
+
+data N0
+data S n
+type N1 = S N0
+type N2 = S N1
+type N3 = S N2
+
+class KnownPeanoNat n where
+    peanoVal :: p n -> Int
+
+instance KnownPeanoNat N0 where
+    peanoVal _ = 0
+instance KnownPeanoNat n => KnownPeanoNat (S n) where
+    peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)
+
+type family PeanoNat p where
+    PeanoNat N0    = 0
+    PeanoNat (S n) = 1 + PeanoNat n
+
+data ReturnPath n where
+    NoReturnPath :: ReturnPath N0
+    ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
+
+-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
+instance Sized (ReturnPath N0) where size = ConstSize 0
+instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
+    size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
+                                            in error "non-constant ReturnPath size")
+                                     (size :: Size (ReturnPath n))
+
+{-
+instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
+    size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
+-}
+
+instance Serialize (ReturnPath N0) where get              = pure NoReturnPath
+                                         put NoReturnPath = pure ()
+
+instance Serialize (ReturnPath N1) where
+    get = ReturnPath <$> get <*> get
+    put (ReturnPath n24 p) = put n24 >> put p
+
+instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
+    get = ReturnPath <$> get <*> get
+    put (ReturnPath n24 p) = put n24 >> put p
+
+
+{-
+-- This doesn't work because it tried to infer it for (0 - 1)
+instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
+    get = ReturnPath <$> get <*> get
+    put (ReturnPath n24 p) = put n24 >> put p
+-}
+
+instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
+    show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
+
+
+-- instance KnownNat n => Serialize (ReturnPath n) where
+--     -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
+--     get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
+--     put (ReturnPath bs) = putByteString bs
+
+
+data Forwarding n msg where
+    NotForwarded :: msg -> Forwarding N0 msg
+    Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg
+
+instance Show msg => Show (Forwarding N0 msg) where
+    show (NotForwarded x) = "NotForwarded "++show x
+
+instance ( KnownNat (PeanoNat (S n))
+         , Show (Encrypted (Addressed (Forwarding n msg)))
+         ) => Show (Forwarding (S n) msg) where
+    show (Forwarding k a) = unwords [ "Forwarding"
+                                    , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
+                                    , show (key2id k)
+                                    , show a
+                                    ]
+
+instance Sized msg => Sized (Forwarding N0 msg)
+   where size = case size :: Size msg of
+                 ConstSize n -> ConstSize n
+                 VarSize f -> VarSize $ \(NotForwarded x) -> f x
+
+instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
+   where size = ConstSize 32
+                <> contramap (\(Forwarding _ e) -> e)
+                             (size :: Size (Encrypted (Addressed (Forwarding n msg))))
+
+instance Serialize msg => Serialize (Forwarding N0 msg) where
+    get = NotForwarded <$> get
+    put (NotForwarded msg) = put msg
+
+instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
+    get = Forwarding <$> getPublicKey <*> get
+    put (Forwarding k x) = putPublicKey k >> put x
+
+handleOnionRequest :: forall a proxy n.
+                      ( LessThanThree n
+                      , KnownPeanoNat n
+                      , Sized (ReturnPath n)
+                      , Typeable n
+                      ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
+handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
+    let n = peanoVal rpath
+    hPutStrLn stderr $ "handleOnionRequest " ++ show n
+    (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
+                                      <*> transportNewNonce crypto )
+    peeled <- peelOnion crypto nonce msg
+    case peeled of
+        Left e -> do
+            -- todo report encryption error
+            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
+            kont
+        Right (Addressed dst msg') -> do
+            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
+            sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
+            kont
+
+wrapSymmetric :: Serialize (ReturnPath n) =>
+                 SymmetricKey -> Nonce24 -> SockAddr -> ReturnPath n -> ReturnPath (S n)
+wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ Addressed saddr rpath)
+
+peelSymmetric :: Serialize (Addressed (ReturnPath n))
+                 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
+peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
+
+
+peelOnion :: Serialize (Addressed (Forwarding n t))
+              => TransportCrypto
+              -> Nonce24
+              -> Forwarding (S n) t
+              -> IO (Either String (Addressed (Forwarding n t)))
+peelOnion crypto nonce (Forwarding k fwd) = do
+    fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
+
+handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n)) => proxy (S n) -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionResponse (S n) -> IO a
+handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do
+    sym <- atomically $ transportSymmetric crypto
+    case peelSymmetric sym path of
+        Left e -> do
+            -- todo report encryption error
+            let n = peanoVal path
+            hPutStrLn stderr $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
+            kont
+        Right (Addressed dst path') -> do
+            sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
+            kont
+
+
+data AnnounceRequest = AnnounceRequest
+    { announcePingId  :: Nonce32 -- Ping ID
+    , announceSeeking :: NodeId  -- Public key we are searching for
+    , announceKey     :: NodeId  -- Public key that we want those sending back data packets to use
+    }
+ deriving Show
+
+instance Sized AnnounceRequest where size = ConstSize (32*3)
+
+instance S.Serialize AnnounceRequest where
+    get = AnnounceRequest <$> S.get <*> S.get <*> S.get
+    put (AnnounceRequest p s k) = S.put (p,s,k)
+
+getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3)
+getOnionRequest = do
+    -- Assumes return path is constant size so that we can isolate
+    -- the variable-sized prefix.
+    cnt <- remaining
+    a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
+                 getAliasedAsymm
+    path <- get
+    return (a,path)
+
+putRequest :: ( KnownPeanoNat n
+              , Serialize (OnionRequest n)
+              , Typeable n
+              ) => OnionRequest n -> Put
+putRequest req = do
+    let tag = 0x80 + fromIntegral (peanoVal req)
+    when (tag <= 0x82) (putWord8 tag)
+    put req
+
+putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
+putResponse resp = do
+    let tag = 0x8f - fromIntegral (peanoVal resp)
+    -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag
+    -- in it's Serialize instance.
+    when (tag /= 0x8f) (putWord8 tag)
+    put resp
+
+
+data KeyRecord = NotStored    Nonce32
+               | SendBackKey  PublicKey
+               | Acknowledged Nonce32
+ deriving Show
+
+instance Sized KeyRecord where size = ConstSize 33
+
+instance S.Serialize KeyRecord where
+    get = do
+        is_stored <- S.get :: S.Get Word8
+        case is_stored of
+            1 -> SendBackKey  <$> getPublicKey
+            2 -> Acknowledged <$> S.get
+            _ -> NotStored    <$> S.get
+    put (NotStored n32)    = S.put (0 :: Word8) >> S.put n32
+    put (SendBackKey key)  = S.put (1 :: Word8) >> putPublicKey key
+    put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
+
+data AnnounceResponse = AnnounceResponse
+    { is_stored     :: KeyRecord
+    , announceNodes :: SendNodes
+    }
+ deriving Show
+
+instance Sized AnnounceResponse where
+    size = contramap is_stored size <> contramap announceNodes size
+
+getNodeList :: S.Get [NodeInfo]
+getNodeList = do
+    n <- S.get
+    (:) n <$> (getNodeList <|> pure [])
+
+instance S.Serialize AnnounceResponse where
+    get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
+    put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
+
+data DataToRoute = DataToRoute
+    { dataFromKey :: PublicKey -- Real public key of sender
+    , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c
+    }
+
+instance Sized DataToRoute where
+    size = ConstSize 32 <> contramap dataToRoute size
+
+instance Serialize DataToRoute where
+    get = DataToRoute <$> getPublicKey <*> get
+    put (DataToRoute k dta) = putPublicKey k >> put dta
+
+data OnionData
+  = -- | type 0x9c
+    --
+    -- We send this packet every 30 seconds if there is more than one peer (in
+    -- the 8) that says they our friend is announced on them. This packet can
+    -- also be sent through the DHT module as a DHT request packet (see DHT) if
+    -- we know the DHT public key of the friend and are looking for them in the
+    -- DHT but have not connected to them yet. 30 second is a reasonable
+    -- timeout to not flood the network with too many packets while making sure
+    -- the other will eventually receive the packet. Since packets are sent
+    -- through every peer that knows the friend, resending it right away
+    -- without waiting has a high likelihood of failure as the chances of
+    -- packet loss happening to all (up to to 8) packets sent is low.
+    --
+    -- If a friend is online and connected to us, the onion will stop all of
+    -- its actions for that friend. If the peer goes offline it will restart
+    -- searching for the friend as if toxcore was just started.
+    OnionDHTPublicKey DHTPublicKey
+  | -- | type 0x20
+    --
+    --
+    OnionFriendRequest FriendRequest -- 0x20
+ deriving (Eq,Show)
+
+instance Sized OnionData where
+    size = VarSize $ \case
+        OnionDHTPublicKey dhtpk -> case size of
+            ConstSize n -> n -- Override because OnionData probably
+                             -- should be treated as variable sized.
+            VarSize f   -> f dhtpk
+        -- FIXME: inconsitantly, we have to add in the tag byte for this case.
+        OnionFriendRequest req -> 1 + case size of
+            ConstSize n -> n
+            VarSize f   -> f req
+
+instance Serialize OnionData where
+    get = do
+        tag <- get
+        case tag :: Word8 of
+            0x9c -> OnionDHTPublicKey <$> get
+            0x20 -> OnionFriendRequest <$> get
+            _    -> fail $ "Unknown onion data: "++show tag
+    put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
+    put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
+
+selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
+selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
+                           = return (skey, pkey)
+selectKey crypto msg rpath = return $ aliasKey crypto rpath
+
+encrypt :: TransportCrypto
+                -> OnionMessage Identity
+                -> OnionDestination r
+                -> IO (OnionMessage Encrypted, OnionDestination r)
+encrypt crypto msg rpath = do
+    (skey,pkey) <- selectKey crypto msg rpath -- source key
+    let okey = onionKey rpath                 -- destination key
+        encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a
+        encipher1 sk pk n a = Composed $ do
+            secret <- lookupSharedSecret crypto sk pk n
+            return $ ToxCrypto.encrypt secret $ encodePlain a
+        encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a
+        encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d
+    m <- sequenceMessage $ transcode encipher msg
+    return (m, rpath)
+
+decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
+decrypt crypto msg addr = do
+    (skey,pkey) <- selectKey crypto msg addr
+    let decipher1 :: Serialize a =>
+                     TransportCrypto -> SecretKey -> Nonce24
+                     -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
+                     -> (IO ∘ Either String ∘ Identity) a
+        decipher1 crypto k n arg = Composed $ do
+            let (sender,e) = either id (senderKey &&& asymmData) arg
+            secret <- lookupSharedSecret crypto k sender n
+            return $ Composed $ do
+                plain <- ToxCrypto.decrypt secret e
+                Identity <$> decodePlain plain
+        decipher :: Serialize a
+            => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
+                       -> (IO ∘ Either String ∘ Identity) a
+        decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
+    foo <- sequenceMessage $ transcode decipher msg
+    return $ do
+        msg <- sequenceMessage foo
+        Right (msg, addr)
+
+senderkey :: OnionDestination r -> t -> (PublicKey, t)
+senderkey addr e = (onionKey addr, e)
+
+aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey)
+aliasKey crypto (OnionToOwner {})     = (transportSecret &&& transportPublic) crypto
+aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto
+
+dhtKey :: TransportCrypto -> (SecretKey,PublicKey)
+dhtKey crypto = (transportSecret &&& transportPublic) crypto
+
+decryptMessage :: Serialize x =>
+                  TransportCrypto
+                  -> (SecretKey,PublicKey)
+                  -> Nonce24
+                  -> Either (PublicKey, Encrypted x)
+                            (Asymm (Encrypted x))
+                  -> IO ((Either String ∘ Identity) x)
+decryptMessage crypto (sk,pk) n arg = do
+    let (sender,e) = either id (senderKey &&& asymmData) arg
+        plain      = Composed . fmap Identity . (>>= decodePlain)
+    secret <- lookupSharedSecret crypto sk sender n
+    return $ plain $ ToxCrypto.decrypt secret e
+
+sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
+sequenceMessage (OnionAnnounce a)        = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
+sequenceMessage (OnionToRoute pub a)     = pure $ OnionToRoute pub a
+sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
+-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
+
+transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g
+transcode f (OnionAnnounce a)        = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) }
+transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
+transcode f (OnionToRoute pub a)     = OnionToRoute pub     a
+transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
+-- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) }
+
+
+data OnionRoute = OnionRoute
+    { routeAliasA :: SecretKey
+    , routeAliasB :: SecretKey
+    , routeAliasC :: SecretKey
+    , routeNodeA  :: NodeInfo
+    , routeNodeB  :: NodeInfo
+    , routeNodeC  :: NodeInfo
+    }
+
+wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0)
+wrapForRoute crypto msg ni r = do
+    -- We needn't use the same nonce value here, but I think it is safe to do so.
+    let nonce = msgNonce msg
+    fwd <-  wrapOnion crypto (routeAliasA r)
+                             nonce
+                             (id2key . nodeId $ routeNodeA r)
+                             (nodeAddr $ routeNodeB r)
+        =<< wrapOnion crypto (routeAliasB r)
+                             nonce
+                             (id2key . nodeId $ routeNodeB r)
+                             (nodeAddr $ routeNodeC r)
+        =<< wrapOnion crypto (routeAliasC r)
+                             nonce
+                             (id2key . nodeId $ routeNodeC r)
+                             (nodeAddr ni)
+                             (NotForwarded msg)
+    return OnionRequest
+        { onionNonce    = nonce
+        , onionForward  = fwd
+        , pathFromOwner = NoReturnPath
+        }
+
+wrapOnion :: Serialize (Forwarding n msg) =>
+           TransportCrypto
+           -> SecretKey
+           -> Nonce24
+           -> PublicKey
+           -> SockAddr
+           -> Forwarding n msg
+           -> IO (Forwarding (S n) msg)
+wrapOnion crypto skey nonce destkey saddr fwd = do
+    let plain = encodePlain $ Addressed saddr fwd
+    secret <- lookupSharedSecret crypto skey destkey nonce
+    return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
+
+
+-- TODO
+-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
+--
+--  (1) DHT public key packet (0x9c)
+--
+--  (2) Friend request
+data Rendezvous = Rendezvous
+    { rendezvousKey :: PublicKey
+    , rendezvousNode :: NodeInfo
+    }
+ deriving Eq
+
+instance Show Rendezvous where
+    showsPrec d (Rendezvous k ni)
+        = showsPrec d (key2id k)
+          . (':' :)
+          . showsPrec d ni
+
+data AnnouncedRendezvous = AnnouncedRendezvous
+    { remoteUserKey :: PublicKey
+    , rendezvous :: Rendezvous
+    }
+  deriving Eq
+
+instance Show AnnouncedRendezvous where
+    showsPrec d (AnnouncedRendezvous remote rendez)
+        = showsPrec d (key2id remote)
+          . (':' :)
+          . showsPrec d rendez
+
+instance Read AnnouncedRendezvous where
+    readsPrec d = RP.readP_to_S $ do
+        ukstr <- RP.munch (/=':')
+        RP.char ':'
+        rkstr <- RP.munch (/=':')
+        RP.char ':'
+        nistr <- RP.munch (const True)
+        return AnnouncedRendezvous
+            { remoteUserKey = id2key $ read ukstr
+            , rendezvous = Rendezvous
+                { rendezvousKey = id2key $ read rkstr
+                , rendezvousNode = read nistr
+                }
+            }
+
+
+selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
+selectAlias crypto pkey = do
+        ks <- filter (\(sk,pk) -> pk == id2key pkey)
+                                <$> readTVar (userKeys crypto)
+        maybe (return SearchingAlias)
+              (return . uncurry AnnouncingAlias)
+              (listToMaybe ks)
+
+
+parseDataToRoute
+    :: TransportCrypto
+         -> (OnionMessage Encrypted,OnionDestination r)
+         -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
+parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
+  ks <- atomically $ readTVar $ userKeys crypto
+
+  omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
+                                (asymmNonce dta)
+                                (Right dta) -- using Asymm{senderKey} as remote key
+  let eOuter = fmap runIdentity $ uncomposed omsg0
+
+      anyRight [] f     = return $ Left "parseDataToRoute: no user key"
+      anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
+
+  -- TODO: We don't currently have a way to look up which user key we
+  -- announced using along this onion route.  Therefore, for now, we will
+  -- try all our user keys to see if any can decrypt the packet.
+  eInner <- case eOuter of
+    Left e    -> return $ Left e
+    Right dtr -> anyRight ks $ \(sk,pk) -> do
+        omsg0 <- decryptMessage crypto
+                                 (sk,pk)
+                                 (asymmNonce dta)
+                                 (Left (dataFromKey dtr, dataToRoute dtr))
+        return $ do
+            omsg <- fmap runIdentity . uncomposed $ omsg0
+            Right (pk,dtr,omsg)
+
+  let e = do
+        (pk,dtr,omsg) <- eInner
+        return ( (pk, omsg)
+               , AnnouncedRendezvous
+                    (dataFromKey dtr)
+                    $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
+      r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
+  -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
+  hPutStrLn stderr $ unlines
+        [ "parseDataToRoute " ++ either id (const "Right") e
+        , "       crypto inner.me =" ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
+        , "              inner.you=" ++ either id (show . key2id . dataFromKey) eOuter
+        , "              outer.me =" ++ show (key2id $ rendezvousPublic crypto)
+        , "              outer.you=" ++ show (key2id $ senderKey dta)
+        ]
+  return r
+parseDataToRoute _ msg = return $ Right msg
+
+encodeDataToRoute :: TransportCrypto
+                     -> ((PublicKey,OnionData),AnnouncedRendezvous)
+                     -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
+encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
+    nonce <- atomically $ transportNewNonce crypto
+    asel <- atomically $ selectAlias crypto (key2id me)
+    let (sk,pk) = case asel of
+            AnnouncingAlias sk pk -> (sk,pk)
+            _                     -> (onionAliasSecret crypto, onionAliasPublic crypto)
+    innerSecret <- lookupSharedSecret crypto sk toxid nonce
+    let plain = encodePlain $ DataToRoute { dataFromKey = pk
+                                          , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg
+                                          }
+    outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce
+    let dta = ToxCrypto.encrypt outerSecret plain
+    hPutStrLn stderr $ unlines
+        [ "encodeDataToRoute    me=" ++ show (key2id me)
+        , "                  dhtpk=" ++ case omsg of
+                                        OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg)
+                                        OnionFriendRequest fr  -> "friend request"
+        , "                     ns=" ++ case omsg of
+                                        OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg)
+                                        OnionFriendRequest fr  -> "friend request"
+        , "       crypto inner.me =" ++ show (key2id pk)
+        , "              inner.you=" ++ show (key2id toxid)
+        , "              outer.me =" ++ show (key2id $ onionAliasPublic crypto)
+        , "              outer.you=" ++ show (key2id pub)
+        , "                  " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni))
+        , "                  " ++ show dta
+        ]
+    return $ Just ( OnionToRoute toxid -- Public key of destination node
+                                 Asymm { senderKey  = onionAliasPublic crypto
+                                       , asymmNonce = nonce
+                                       , asymmData  = dta
+                                       }
+                  , OnionDestination SearchingAlias ni Nothing )
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
new file mode 100644
index 00000000..30df93c8
--- /dev/null
+++ b/src/Network/Tox/Transport.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeOperators              #-}
+module Network.Tox.Transport (toxTransport, RouteId) where
+
+import Network.QueryResponse
+import Crypto.Tox
+import Network.Tox.DHT.Transport
+import Network.Tox.Onion.Transport
+import Network.Tox.Crypto.Transport
+import OnionRouter
+
+import Network.Socket
+
+toxTransport ::
+      TransportCrypto
+          -> OnionRouter
+          -> (PublicKey -> IO (Maybe NodeInfo))
+          -> UDPTransport
+          -> IO ( Transport String NodeInfo (DHTMessage Encrypted8)
+                , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
+                , Transport String AnnouncedRendezvous (PublicKey,OnionData)
+                , Transport String SockAddr NetCrypto )
+toxTransport crypto orouter closeLookup udp = do
+    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp
+    (onion1,udp2) <- partitionTransportM (parseOnionAddr $ lookupSender orouter)
+                                        (encodeOnionAddr crypto $ lookupRoute orouter)
+                                        udp1
+    (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
+    let netcrypto = layerTransport parseNetCrypto encodeNetCrypto udp2
+    return ( forwardDHTRequests crypto closeLookup dht
+           , onion
+           , dta
+           , netcrypto
+           )
+
+
+-- instance (Sized a, Sized b) => Sized (a,b) where size = _todo
+
+
+--   Byte value   Packet Kind           Return address
+-- :----------- :--------------------
+--   `0x00`       Ping Request          DHTNode
+--   `0x01`       Ping Response         -
+--   `0x02`       Nodes Request         DHTNode
+--   `0x04`       Nodes Response        -
+--   `0x18`       Cookie Request        DHTNode, but without sending pubkey in response
+--   `0x19`       Cookie Response       - (no pubkey)
+--
+--   `0x21`       LAN Discovery         DHTNode (No reply, port 33445, trigger Nodes Request/Response)
+--
+--   `0x20`       DHT Request           DHTNode/-forward
+--
+--   `0x1a`       Crypto Handshake      CookieAddress
+--
+--   `0x1b`       Crypto Data           SessionAddress
+--
+--   `0x83`       Announce Request      OnionToOwner
+--   `0x84`       Announce Response     -
+--   `0x85`       Onion Data Request    OnionToOwner
+--   `0x86`       Onion Data Response   -
+--
+--   `0xf0`       Bootstrap Info        SockAddr?
+--
+--   `0x80`       Onion Request 0       -forward
+--   `0x81`       Onion Request 1       -forward
+--   `0x82`       Onion Request 2       -forward
+--   `0x8c`       Onion Response 3      -return
+--   `0x8d`       Onion Response 2      -return
+--   `0x8e`       Onion Response 1      -return
+
+
+
diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs
new file mode 100644
index 00000000..ed6b4777
--- /dev/null
+++ b/src/Network/UPNP.hs
@@ -0,0 +1,39 @@
+module Network.UPNP where
+
+import Data.Maybe
+import Network.Address (sockAddrPort)
+import Network.Socket
+import System.Directory
+import System.IO
+import System.Process  as Process
+
+protocols :: SocketType -> [String]
+protocols Stream   = ["tcp"]
+protocols Datagram = ["udp"]
+protocols _        = ["udp","tcp"]
+
+upnpc :: FilePath
+upnpc = "/usr/bin/upnpc"
+
+-- | Invokes the miniupnpc command line program to request ports from a UPNP
+-- wifi router.  Returns the process handle on success.
+requestPorts :: String -- ^ Description stored on router.
+                -> [(SocketType, SockAddr)] -- ^ Protocol-port pairs to request.
+                -> IO (Maybe ProcessHandle)
+requestPorts description binds = do
+    let requests = do
+            (stype,saddr) <- binds
+            proto <- protocols stype
+            port <- maybeToList (sockAddrPort saddr)
+            [ show port, proto ]
+        bail = return Nothing
+    case requests of
+        [] -> bail
+        _  -> do
+            gotMiniUPNPC <- doesFileExist upnpc
+            if gotMiniUPNPC then do
+                phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests
+                return $ Just phandle
+            else do
+                hPutStrLn stderr $ "Warning: unable to find miniupnpc client at "++upnpc++"."
+                bail
diff --git a/src/StaticAssert.hs b/src/StaticAssert.hs
new file mode 100644
index 00000000..d0784c97
--- /dev/null
+++ b/src/StaticAssert.hs
@@ -0,0 +1,13 @@
+module StaticAssert where
+
+import Network.Socket (htonl)
+import Language.Haskell.TH
+
+staticAssert :: Bool -> Q [Dec]
+staticAssert cond = case cond of
+    True  -> return []
+    False -> fail "staticAssert failed"
+
+isLittleEndian :: Bool
+isLittleEndian = htonl 0x01000000 == 1
+
diff --git a/src/System/Global6.hs b/src/System/Global6.hs
new file mode 100644
index 00000000..f70a8547
--- /dev/null
+++ b/src/System/Global6.hs
@@ -0,0 +1,28 @@
+module System.Global6 where
+
+import Control.Monad
+import Data.IP
+import Data.List
+import Data.Maybe
+import Network.Socket
+import System.Process
+import Text.Read
+
+parseIpAddr :: String -> Maybe IPv6
+parseIpAddr s = do
+    let ws        = words s
+        (addr,bs) = splitAt 1 $ drop 1 $ dropWhile (/= "inet6") ws
+    guard ("global" `elem` bs)
+    addr <- listToMaybe addr
+    guard (not $ isPrefixOf "fd" addr)
+    guard (not $ isPrefixOf "fc" addr)
+    let (addr',slash) = break (=='/') addr
+    ip6 <- readMaybe addr'
+    return $ (ip6 :: IPv6)
+
+
+global6 :: IO (Maybe IPv6)
+global6 = do
+    addrs <- lines <$> readProcess "ip" ["-o","-6","addr"] ""
+    return $ foldr1 mplus $ map parseIpAddr addrs
+
diff --git a/src/Text/XXD.hs b/src/Text/XXD.hs
new file mode 100644
index 00000000..d835b238
--- /dev/null
+++ b/src/Text/XXD.hs
@@ -0,0 +1,26 @@
+module Text.XXD where
+
+import qualified Data.ByteString.Base16 as Base16
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Word
+import Data.Bits
+import Data.Char
+import Text.Printf
+
+nibble :: Word8 -> Char
+nibble b = intToDigit (fromIntegral (b .&. 0x0F))
+
+xxd :: Int -> ByteString -> [String]
+xxd offset bs | B.null bs = []
+xxd offset bs             = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs'
+ where
+    ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
+                 $ B.unpack xs
+    (xs,bs') = B.splitAt 16 bs
+
+{-
+main = do
+    bs <- B.getContents
+    mapM_ putStrLn $ xxd 0 bs
+    -}
diff --git a/todo.txt b/todo.txt
new file mode 100644
index 00000000..75c046e0
--- /dev/null
+++ b/todo.txt
@@ -0,0 +1,54 @@
+tox: Add fallback trials to cookie response in case response is from another address than request.
+
+ui: Online help.
+
+ui: Explicit routing table node deletion. "forget" command.
+
+ui: a -  with no arguments would list the currently active recuring publications.
+
+kademlia: Change refresh algorithm to refresh farther away buckets before closer ones.
+
+kademlia: Remove (without replacement) stale routing nodes at some point.
+
+bug: Why does running without -4 (ipv4-only) on an ipv6-disabled computer prevent
+     storage of bt peers and tox keys in the local store?
+
+kademlia: Give different networks a different minimum count to terminate
+          bootstrap.  Imperically, tox4: 6 buckets, tox6: 3 buckets
+
+tox: Don't store ourself in the kademlia buckets.
+
+tox: fallback to https://nodes.tox.chat/json
+
+tox: bootstrap motd query
+
+tox: hardening get-nodes test request.
+
+tox: nat ping
+
+tox: cache diffie-helman secrets
+
+tox: Expire ofline Tox announces.
+
+tox: Chat support.
+
+bt: Collect PeerStore garbage: "Note that you should call .put() every hour for
+    content that you want to keep alive, since nodes may discard data nodes
+    older than 2 hours." (source: https://www.npmjs.com/package/bittorrent-dht)
+
+bt: Limit peers in get_peers response for UDP packet size limiting (around 1k).
+
+bt: Use LMDB backend for peer store (and nodes too?).
+
+maint: Rename files.
+
+       OnionRouter                  -> Network.Tox.Onion.Routes
+       Announcer                    -> Network.Kademlia.Announce
+       InterruptibleDelay           -> Control.Concurrent.Delay
+       Roster                       -> Network.Tox.ContactInfo
+       Crypto.Tox                   -> Network.Tox.Crypto
+       Network.Tox.Crypto.Handlers  -> Network.Tox.Friend.Handlers
+       Network.Tox.Crypto.Transport -> Network.Tox.Friend.Transport
+
+maint: Probably, Network.* should be reserved for very general tools and the Tox and
+       BitTorrent paths should be moved to the top level.
diff --git a/vnet/build.sh b/vnet/build.sh
new file mode 100755
index 00000000..36818611
--- /dev/null
+++ b/vnet/build.sh
@@ -0,0 +1,89 @@
+#!/bin/sh
+
+wire() {
+    ip link add $1   \
+           type veth \
+      peer name $2
+}
+
+set -x
+
+# Not using this...
+buildhub() {
+        wire hub0 ep0
+        wire hub1 ep1
+        wire hub2 ep2
+        wire hub3 ep3
+        wire hub4 ep4
+        wire hub5 ep5
+        wire hub6 ep6
+        wire hub7 ep7
+
+        wire hub8 ep8
+        wire hub9 ep9
+        wire hubA epA
+        wire hubB epB
+        wire hubC epC
+        wire hubD epD
+        wire hubE epE
+        wire hubF epF
+
+        brctl addbr hub
+        brctl addif hub hub0
+        brctl addif hub hub1
+        brctl addif hub hub2
+        brctl addif hub hub3
+        brctl addif hub hub4
+        brctl addif hub hub5
+        brctl addif hub hub6
+        brctl addif hub hub7
+        brctl addif hub hub8
+        brctl addif hub hub9
+        brctl addif hub hubA
+        brctl addif hub hubB
+        brctl addif hub hubC
+        brctl addif hub hubD
+        brctl addif hub hubE
+        brctl addif hub hubF
+
+        ip addr add 222.0.0.1 dev hub
+}
+
+# This is simpler...
+buildtaps() {
+    ip tuntap add ep0 mode tap
+    ip tuntap add ep1 mode tap
+    ip tuntap add ep2 mode tap
+    ip tuntap add ep3 mode tap
+    ip tuntap add ep4 mode tap
+    ip tuntap add ep5 mode tap
+    ip tuntap add ep6 mode tap
+    ip tuntap add ep7 mode tap
+    ip tuntap add ep8 mode tap
+    ip tuntap add ep9 mode tap
+    ip tuntap add epA mode tap
+    ip tuntap add epB mode tap
+    ip tuntap add epC mode tap
+    ip tuntap add epD mode tap
+    ip tuntap add epE mode tap
+    ip tuntap add epF mode tap
+}
+
+buildtaps
+
+ip addr add 80.99.99.99 dev ep0
+ip addr add 81.99.99.99 dev ep1
+ip addr add 82.99.99.99 dev ep2
+ip addr add 83.99.99.99 dev ep3
+ip addr add 84.99.99.99 dev ep4
+ip addr add 85.99.99.99 dev ep5
+ip addr add 86.99.99.99 dev ep6
+ip addr add 87.99.99.99 dev ep7
+ip addr add 88.99.99.99 dev ep8
+ip addr add 89.99.99.99 dev ep9
+ip addr add 90.99.99.99 dev epA
+ip addr add 91.99.99.99 dev epB
+ip addr add 92.99.99.99 dev epC
+ip addr add 93.99.99.99 dev epD
+ip addr add 94.99.99.99 dev epE
+ip addr add 95.99.99.99 dev epF
diff --git a/vnet/clean.sh b/vnet/clean.sh
new file mode 100755
index 00000000..3e0af1bd
--- /dev/null
+++ b/vnet/clean.sh
@@ -0,0 +1,49 @@
+#!/bin/sh
+
+cleanhub() {
+        brctl delbr hub
+
+        ip link del hub0
+        ip link del hub1
+        ip link del hub2
+        ip link del hub3
+        ip link del hub4
+        ip link del hub5
+        ip link del hub6
+        ip link del hub7
+
+        ip link del hub8
+        ip link del hub9
+        ip link del hubA
+        ip link del hubB
+        ip link del hubC
+        ip link del hubD
+        ip link del hubE
+        ip link del hubF
+}
+
+cleantaps()
+{
+        ip link del ep0
+        ip link del ep1
+        ip link del ep2
+        ip link del ep3
+        ip link del ep4
+        ip link del ep5
+        ip link del ep6
+        ip link del ep7
+
+        ip link del ep8
+        ip link del ep9
+        ip link del epA
+        ip link del epB
+        ip link del epC
+        ip link del epD
+        ip link del epE
+        ip link del epF
+}
+
+cleantaps
+
+rm -rf ep0 ep1 ep2 ep3 ep4 ep5 ep6 ep7 \
+       ep8 ep9 epA epB epC epD epE epF
diff --git a/vnet/everywhere.sh b/vnet/everywhere.sh
new file mode 100755
index 00000000..ebd4ca38
--- /dev/null
+++ b/vnet/everywhere.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+cmd="$@"
+for ep in ep?
+do
+    ( cd $ep
+      $cmd
+      )
+done
diff --git a/vnet/mkroutes.sh b/vnet/mkroutes.sh
new file mode 100755
index 00000000..4058bb40
--- /dev/null
+++ b/vnet/mkroutes.sh
@@ -0,0 +1,19 @@
+#!/bin/sh
+ip=$1
+ip route add 80.99.99.99/32 via $host
+ip route add 80.99.99.99/32 via $host
+ip route add 81.99.99.99/32 via $host
+ip route add 82.99.99.99/32 via $host
+ip route add 83.99.99.99/32 via $host
+ip route add 84.99.99.99/32 via $host
+ip route add 85.99.99.99/32 via $host
+ip route add 86.99.99.99/32 via $host
+ip route add 87.99.99.99/32 via $host
+ip route add 88.99.99.99/32 via $host
+ip route add 89.99.99.99/32 via $host
+ip route add 90.99.99.99/32 via $host
+ip route add 91.99.99.99/32 via $host
+ip route add 92.99.99.99/32 via $host
+ip route add 93.99.99.99/32 via $host
+ip route add 94.99.99.99/32 via $host
+ip route add 95.99.99.99/32 via $host
diff --git a/vnet/run.sh b/vnet/run.sh
new file mode 100755
index 00000000..0189b6b7
--- /dev/null
+++ b/vnet/run.sh
@@ -0,0 +1,45 @@
+#!/bin/sh
+
+[ -L ./dhtd ] || ( echo "Missing symbolic link to your build: ./dhtd" ; exit 1 )
+
+mkdir -p ep0 ep1 ep2 ep3 ep4 ep5 ep6 ep7 \
+         ep8 ep9 epA epB epC epD epE epF
+
+rm -f window-count
+echo detach > detached
+
+screen -S test -s ./screen-shell.sh -c detached
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
+screen -S test -X screen
+sleep 0.5
diff --git a/vnet/screen-everywhere.sh b/vnet/screen-everywhere.sh
new file mode 100755
index 00000000..e4f75374
--- /dev/null
+++ b/vnet/screen-everywhere.sh
@@ -0,0 +1,21 @@
+#!/bin/sh
+cmd="$@"
+echo "$cmd" > /tmp/screen-exchange
+screen -S test -X eval readbuf \
+    "select 15" "paste ." \
+    "select 14" "paste ." \
+    "select 13" "paste ." \
+    "select 12" "paste ." \
+    "select 11" "paste ." \
+    "select 10" "paste ." \
+    "select 9" "paste ." \
+    "select 8" "paste ." \
+    "select 7" "paste ." \
+    "select 6" "paste ." \
+    "select 5" "paste ." \
+    "select 5" "paste ." \
+    "select 4" "paste ." \
+    "select 3" "paste ." \
+    "select 2" "paste ." \
+    "select 1" "paste ." \
+    "select 0" "paste ."
diff --git a/vnet/screen-shell.sh b/vnet/screen-shell.sh
new file mode 100755
index 00000000..6143c81d
--- /dev/null
+++ b/vnet/screen-shell.sh
@@ -0,0 +1,14 @@
+#!/bin/sh
+ifaddr() {
+    ip -o address show dev $1 | sed -n 's#.* inet \([^ /]*\).*#\1#p'
+}
+touch window-count
+count=$(cat window-count)
+count=${count:-(-1)}
+count=$(( $count + 1 ))
+echo $count > window-count
+digit=$(printf '%X' $count)
+cd ep$digit
+port=$(( 33400 + $count ))
+pwd
+../dhtd tox=$(ifaddr ep$digit):$port,bt=
diff --git a/vnet/show-links.sh b/vnet/show-links.sh
new file mode 100755
index 00000000..d7115a0b
--- /dev/null
+++ b/vnet/show-links.sh
@@ -0,0 +1,2 @@
+#!/bin/sh
+ip -o link | sed 's/\([^:]*:[^:]*:*\).*/\1/'