Factor out some new libraries

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

78 files changed, 11878 insertions, 0 deletions

diff --git a/dht/bittorrent/README.md b/dht/bittorrent/README.md
new file mode 100644
index 00000000..32948896
--- /dev/null
+++ b/dht/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/dht/bittorrent/Readme.md b/dht/bittorrent/Readme.md
new file mode 100644
index 00000000..e092c3ad
--- /dev/null
+++ b/dht/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/dht/bittorrent/bench/Main.hs b/dht/bittorrent/bench/Main.hs
new file mode 100644
index 00000000..f04485ab
--- /dev/null
+++ b/dht/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/dht/bittorrent/bench/Throughtput.hs b/dht/bittorrent/bench/Throughtput.hs
new file mode 100644
index 00000000..d0404405
--- /dev/null
+++ b/dht/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/dht/bittorrent/bench/TorrentFile.hs b/dht/bittorrent/bench/TorrentFile.hs
new file mode 100644
index 00000000..e91a9c10
--- /dev/null
+++ b/dht/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/dht/bittorrent/bittorrent.cabal b/dht/bittorrent/bittorrent.cabal
new file mode 100644
index 00000000..8ec314e7
--- /dev/null
+++ b/dht/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/dht/bittorrent/dev/README.md b/dht/bittorrent/dev/README.md
new file mode 100644
index 00000000..e2cc51a6
--- /dev/null
+++ b/dht/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/dht/bittorrent/dev/add-sources.sh b/dht/bittorrent/dev/add-sources.sh
new file mode 100755
index 00000000..e125cade
--- /dev/null
+++ b/dht/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/dht/bittorrent/dev/bench b/dht/bittorrent/dev/bench
new file mode 100755
index 00000000..5d03db3f
--- /dev/null
+++ b/dht/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/dht/bittorrent/dev/test b/dht/bittorrent/dev/test
new file mode 100755
index 00000000..2eb85df2
--- /dev/null
+++ b/dht/bittorrent/dev/test
@@ -0,0 +1,2 @@
+#!/bin/sh
+cabal-dev build && cabal-dev test || echo "ERROR: Some tests failed."
diff --git a/dht/bittorrent/dev/update-dependencies.sh b/dht/bittorrent/dev/update-dependencies.sh
new file mode 100755
index 00000000..c83694c3
--- /dev/null
+++ b/dht/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/dht/bittorrent/examples/Client.hs b/dht/bittorrent/examples/Client.hs
new file mode 100644
index 00000000..26711676
--- /dev/null
+++ b/dht/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/dht/bittorrent/examples/FS.hs b/dht/bittorrent/examples/FS.hs
new file mode 100644
index 00000000..550d85a7
--- /dev/null
+++ b/dht/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/dht/bittorrent/examples/MkTorrent.hs b/dht/bittorrent/examples/MkTorrent.hs
new file mode 100644
index 00000000..88a84893
--- /dev/null
+++ b/dht/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/dht/bittorrent/res/dapper-dvd-amd64.iso.torrent b/dht/bittorrent/res/dapper-dvd-amd64.iso.torrent
new file mode 100644
index 00000000..5713344b
--- /dev/null
+++ b/dht/bittorrent/res/dapper-dvd-amd64.iso.torrent
diff --git a/dht/bittorrent/res/pkg.torrent b/dht/bittorrent/res/pkg.torrent
new file mode 100644
index 00000000..be89e9e0
--- /dev/null
+++ b/dht/bittorrent/res/pkg.torrent
diff --git a/dht/bittorrent/res/testfile b/dht/bittorrent/res/testfile
new file mode 100644
index 00000000..8e984818
--- /dev/null
+++ b/dht/bittorrent/res/testfile
diff --git a/dht/bittorrent/res/testfile.torrent b/dht/bittorrent/res/testfile.torrent
new file mode 100644
index 00000000..297f56a2
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent.hs b/dht/bittorrent/src/Network/BitTorrent.hs
new file mode 100644
index 00000000..91a58887
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Client.hs b/dht/bittorrent/src/Network/BitTorrent/Client.hs
new file mode 100644
index 00000000..c84290dd
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Client/Handle.hs b/dht/bittorrent/src/Network/BitTorrent/Client/Handle.hs
new file mode 100644
index 00000000..66baac48
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Client/Types.hs b/dht/bittorrent/src/Network/BitTorrent/Client/Types.hs
new file mode 100644
index 00000000..e2ad858f
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange.hs
new file mode 100644
index 00000000..143bf090
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs
new file mode 100644
index 00000000..1be9f970
--- /dev/null
+++ b/dht/bittorrent/src/Network/BitTorrent/Exchange/Bitfield.hs
@@ -0,0 +1,405 @@
+-- |
+--   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 selection 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 a restriction:
+-- each integer in the set should be within the given interval.  The greatest
+-- lower bound of the interval must be zero, so intervals may be specified by
+-- providing a maximum set size.  For example, a bitfield of size 10 might
+-- contain only indices in interval [0..9].
+--
+-- By convention, we use the following aliases for Int:
+--
+--   [ PieceIx ] an Int member of the Bitfield.
+--
+--   [ PieceCount ] maximum set size for a Bitfield.
+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
+    {-# NOINLINE freqMap #-}
+
+    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 "TODO: randomFirst"
+
+endGame :: Selector
+endGame = strictLast
diff --git a/dht/bittorrent/src/Network/BitTorrent/Exchange/Block.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Block.hs
new file mode 100644
index 00000000..bc9a3d24
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Connection.hs
new file mode 100644
index 00000000..6804d0a2
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange/Download.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Download.hs
new file mode 100644
index 00000000..981db2fb
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Manager.hs
new file mode 100644
index 00000000..30a6a607
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Exchange/Message.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Message.hs
new file mode 100644
index 00000000..5c096523
--- /dev/null
+++ b/dht/bittorrent/src/Network/BitTorrent/Exchange/Message.hs
@@ -0,0 +1,1237 @@
+-- |
+--   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            #-}
+{-# LANGUAGE CPP                        #-}
+{-# 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
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+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/dht/bittorrent/src/Network/BitTorrent/Exchange/Session.hs b/dht/bittorrent/src/Network/BitTorrent/Exchange/Session.hs
new file mode 100644
index 00000000..38a3c3a6
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Internal/Cache.hs b/dht/bittorrent/src/Network/BitTorrent/Internal/Cache.hs
new file mode 100644
index 00000000..8c74467a
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Internal/Progress.hs b/dht/bittorrent/src/Network/BitTorrent/Internal/Progress.hs
new file mode 100644
index 00000000..6ac889e2
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Internal/Types.hs b/dht/bittorrent/src/Network/BitTorrent/Internal/Types.hs
new file mode 100644
index 00000000..d157db3e
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Readme.md b/dht/bittorrent/src/Network/BitTorrent/Readme.md
new file mode 100644
index 00000000..ebf9545e
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Tracker.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker.hs
new file mode 100644
index 00000000..1191f921
--- /dev/null
+++ b/dht/bittorrent/src/Network/BitTorrent/Tracker.hs
@@ -0,0 +1,51 @@
+-- |
+--   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 (..)
+       , trackers
+       , 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/dht/bittorrent/src/Network/BitTorrent/Tracker/List.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/List.hs
new file mode 100644
index 00000000..1507b4be
--- /dev/null
+++ b/dht/bittorrent/src/Network/BitTorrent/Tracker/List.hs
@@ -0,0 +1,197 @@
+-- |
+--   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
+       , trackers
+       , 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
+
+trackers :: [URI] -> TrackerList ()
+trackers uris = TierList $ map (\uri -> [(uri,())]) uris
+
+-- | 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/dht/bittorrent/src/Network/BitTorrent/Tracker/Message.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/Message.hs
new file mode 100644
index 00000000..ab492275
--- /dev/null
+++ b/dht/bittorrent/src/Network/BitTorrent/Tracker/Message.hs
@@ -0,0 +1,925 @@
+-- |
+--   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               #-}
+{-# LANGUAGE CPP                        #-}
+{-# 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
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+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]
+  | CompactPeerList [PeerAddr]
+    deriving (Show, Eq, Typeable, Functor)
+
+-- | The empty non-compact peer list.
+instance Default (PeerList IP) where
+  def = PeerList []
+  {-# INLINE def #-}
+
+getPeerList :: PeerList IP -> [PeerAddr]
+getPeerList (PeerList        xs) = xs
+getPeerList (CompactPeerList xs) = xs
+
+instance 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 -> Either PeerAddr PeerAddr
+          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 ipv4s
+
+      merge (CompactPeerList _    ) (Just (PeerList _))
+        = fail "PeerList: the `peers6' field value \
+                         \should contain *compact* peer list"
+
+      merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s))
+        = pure $ CompactPeerList $
+                 ipv4s <> 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_ (getPeerList respPeers) put
+
+  get = do
+    interval <- getWord32be
+    leechers <- getWord32be
+    seeders  <- getWord32be
+    peers    <- many $ isolate 6 get -- isolated to specify IPv4.
+
+    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/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC.hs
new file mode 100644
index 00000000..45fef05e
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
new file mode 100644
index 00000000..6f7a53bf
--- /dev/null
+++ b/dht/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 defaultRequest 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/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/RPC/UDP.hs
new file mode 100644
index 00000000..31b6b870
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/dht/bittorrent/src/Network/BitTorrent/Tracker/Session.hs
new file mode 100644
index 00000000..db6ebaff
--- /dev/null
+++ b/dht/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]
+
+    -- | 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])
+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]
+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/dht/bittorrent/src/System/Torrent/FileMap.hs b/dht/bittorrent/src/System/Torrent/FileMap.hs
new file mode 100644
index 00000000..38c475e8
--- /dev/null
+++ b/dht/bittorrent/src/System/Torrent/FileMap.hs
@@ -0,0 +1,163 @@
+{-# 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 -- XXX: mutable buffer (see 'writeBytes').
+  } 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
+
+-- Unsafe: FileMap 'writeBytes' will modify supplied bytestrings in place.
+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)/.
+--
+-- Unsafe: mutable buffers are returned without copy.
+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)
+
+-- | Find the file number for a particular byte offset within a torrent.
+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'.
+--
+-- The returned bytestring points directly into an area memory mapped from a
+-- file.
+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''
+
+-- The returned bytestring is copied and safe to use after the file is
+-- unmapped.
+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
+
+-- UNSAFE: Uses the first byte string as a pointer to mutable data and writes
+-- the contents of the second bytestring there.
+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 ()
+
+-- UNSAFE: Mutates bytestring contents within the provided FileMap.
+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
diff --git a/dht/bittorrent/src/System/Torrent/Storage.hs b/dht/bittorrent/src/System/Torrent/Storage.hs
new file mode 100644
index 00000000..1d77e55d
--- /dev/null
+++ b/dht/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/dht/bittorrent/src/System/Torrent/Tree.hs b/dht/bittorrent/src/System/Torrent/Tree.hs
new file mode 100644
index 00000000..41cfb360
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Config.hs b/dht/bittorrent/tests/Config.hs
new file mode 100644
index 00000000..55e30867
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Data/TorrentSpec.hs b/dht/bittorrent/tests/Data/TorrentSpec.hs
new file mode 100644
index 00000000..b4a280e4
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Main.hs b/dht/bittorrent/tests/Main.hs
new file mode 100644
index 00000000..5ed953da
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
new file mode 100644
index 00000000..d51bab02
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/CoreSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
new file mode 100644
index 00000000..e9b17a42
--- /dev/null
+++ b/dht/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
@@ -0,0 +1,309 @@
+{-# 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
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+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
diff --git a/dht/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
new file mode 100644
index 00000000..6f3c7489
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
new file mode 100644
index 00000000..93f78263
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
new file mode 100644
index 00000000..07a906ba
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
new file mode 100644
index 00000000..32e4c158
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
new file mode 100644
index 00000000..e9473cbb
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
new file mode 100644
index 00000000..a45d2212
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/DHTSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
new file mode 100644
index 00000000..77160eb5
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
new file mode 100644
index 00000000..1ba772f6
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
new file mode 100644
index 00000000..2dc8e0b8
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
new file mode 100644
index 00000000..d654cda1
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
new file mode 100644
index 00000000..d46f2034
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
new file mode 100644
index 00000000..d615b1ff
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
new file mode 100644
index 00000000..bf5b95a1
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
new file mode 100644
index 00000000..337e7add
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
new file mode 100644
index 00000000..acbfd84c
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
new file mode 100644
index 00000000..bba9d0e2
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
new file mode 100644
index 00000000..29854d58
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
new file mode 100644
index 00000000..e928f917
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
new file mode 100644
index 00000000..73acb3fa
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
new file mode 100644
index 00000000..dfc13a1e
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
new file mode 100644
index 00000000..72936ee7
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs b/dht/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
new file mode 100644
index 00000000..b95e2df4
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/KRPC/MessageSpec.hs b/dht/bittorrent/tests/Network/KRPC/MessageSpec.hs
new file mode 100644
index 00000000..498ef679
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/KRPC/MethodSpec.hs b/dht/bittorrent/tests/Network/KRPC/MethodSpec.hs
new file mode 100644
index 00000000..c1c58282
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Network/KRPCSpec.hs b/dht/bittorrent/tests/Network/KRPCSpec.hs
new file mode 100644
index 00000000..eabcc817
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/Readme.md b/dht/bittorrent/tests/Readme.md
new file mode 100644
index 00000000..7a9d8914
--- /dev/null
+++ b/dht/bittorrent/tests/Readme.md
@@ -0,0 +1,4 @@
+Prerequisites
+=============
+
+To run test suite you need rtorrent and screen installed.
diff --git a/dht/bittorrent/tests/Spec.hs b/dht/bittorrent/tests/Spec.hs
new file mode 100644
index 00000000..b4e92e75
--- /dev/null
+++ b/dht/bittorrent/tests/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
diff --git a/dht/bittorrent/tests/System/Torrent/FileMapSpec.hs b/dht/bittorrent/tests/System/Torrent/FileMapSpec.hs
new file mode 100644
index 00000000..29252925
--- /dev/null
+++ b/dht/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/dht/bittorrent/tests/System/Torrent/StorageSpec.hs b/dht/bittorrent/tests/System/Torrent/StorageSpec.hs
new file mode 100644
index 00000000..b5e49078
--- /dev/null
+++ b/dht/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