~ Starting separating protocol and high level api.

It will be more convenient to provide high level api and raw protocol
separated. In many use cases we don't worry about protocol but need some
simple things like track swarm/peer state.

So I think it will be better to refactor library in the following way:

1. Network.BitTorrent.Tracker.Protocol,
   Network.BitTorrent.PeerWire.Protocol
   For raw protocol definitions, documentation and serialization.

2. Network.BitTorrent.Tracker
   Network.BitTorrent.PeerWire
   For convenient API.

Though we should not restrict user to in some particular way, so high level
api should be flexible enough. In other words: mechanism, not
policy/framework.

2 files changed, 288 insertions, 187 deletions

diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index 99ffc280..6ecf4fc2 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -1,4 +1,3 @@
--- TODO: add "compact" field to TRequest
 -- |
 --   Copyright   :  (c) Sam T. 2013
 --   License     :  MIT
@@ -6,195 +5,57 @@
 --   Stability   :  experimental
 --   Portability :  non-portable
 --
-{-# OPTIONS -fno-warn-orphans #-}
-{-# LANGUAGE OverloadedStrings #-}
--- make higher level api
+--   This module provides high level API for peer->tracker
+--   communication.
+--
 module Network.BitTorrent.Tracker
        ( module Network.BitTorrent.Tracker.Scrape
-       , Progress(..), TSession(..)
-       , tsession, startProgress
 
-         -- * Requests
-       , Event(..), TRequest(..)
-       , startedReq, regularReq, stoppedReq, completedReq
+       , withTracker, completedReq
+
+         -- * Progress
+       , Progress(..), startProgress
 
-         -- * Responses
-       , TResponse(..)
-       , sendRequest
+         -- * Connection
+       , TConnection(..), tconnection
 
-         -- * Defaults
-       , defaultPorts, defaultNumWant
-       )
-       where
+         -- * Session
+       , TSession, getPeerList, getProgress, waitInterval
+
+         -- * Re-export
+       , defaultPorts
+       ) where
 
 import Control.Applicative
-import Data.Char as Char
-import Data.Word (Word32)
-import Data.List as L
-import Data.Map  as M
-import Data.Monoid
-import Data.BEncode
-import Data.ByteString as B
-import           Data.ByteString.Char8 as BC
-import           Data.Text as T
-import Data.Serialize.Get hiding (Result)
-import Data.URLEncoded as URL
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import Data.IORef
 import Data.Torrent
-
 import Network
-import Network.Socket
-import Network.HTTP
 import Network.URI
 
 import Network.BitTorrent.Peer
 import Network.BitTorrent.PeerID
+import Network.BitTorrent.Tracker.Protocol
 import Network.BitTorrent.Tracker.Scrape
 
 
-data Event = Started   -- ^ For first request.
-           | Stopped   -- ^ Sent when the peer is shutting down.
-           | Completed -- ^ To be sent when the peer completes a download.
-             deriving (Show, Read, Eq, Ord, Enum, Bounded)
-
-data TRequest = TRequest { -- TODO peer here -- TODO detach announce
-     reqAnnounce   :: URI         -- ^ Announce url of the torrent.
-   , reqInfoHash   :: InfoHash    -- ^ Hash of info part of the torrent.
-   , reqPeerID     :: PeerID      -- ^ Id of the peer doing request. ()
-   , reqPort       :: PortNumber  -- ^ Port to listen to for connection from other peers.
-   , reqUploaded   :: Integer     -- ^ # of bytes that the peer has uploaded in the swarm.
-   , reqDownloaded :: Integer     -- ^ # of bytes downloaded in the swarm by the peer.
-   , reqLeft       :: Integer     -- ^ # of bytes needed in order to complete download.
-   , reqIP         :: Maybe HostAddress    -- ^ The peer IP.
-   , reqNumWant    :: Maybe Int   -- ^ Number of peers that the peers wants to receive from.
-   , reqEvent      :: Maybe Event -- ^ If not specified,
-                                  --   the request is regular periodic request.
-   } deriving Show
-
-data TResponse =
-     Failure Text           -- ^ Failure reason in human readable form.
-   | OK {
-       respWarning     :: Maybe Text
-     , respInterval    :: Int       -- ^ Recommended interval to wait between requests.
-     , respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests.
-     , respComplete    :: Maybe Int -- ^ Number of peers completed the torrent. (seeders)
-     , respIncomplete  :: Maybe Int -- ^ Number of peers downloading the torrent.
-     , respPeers       :: [Peer]    -- ^ Peers that must be contacted.
-     } deriving Show
-
-instance BEncodable PortNumber where
-  toBEncode = toBEncode . fromEnum
-  fromBEncode b = toEnum <$> fromBEncode b
-
-instance BEncodable Peer where
-  toBEncode (Peer pid pip pport) = fromAssocs
-    [ "peer id" -->? pid
-    , "ip"      -->  pip
-    , "port"    -->  pport
-    ]
-
-  fromBEncode (BDict d) =
-    Peer <$> d >--? "peer id"
-         <*> d >--  "ip"
-         <*> d >--  "port"
-
-  fromBEncode _ = decodingError "Peer"
-
-instance BEncodable TResponse where
-  toBEncode (Failure t)  = fromAssocs ["failure reason" --> t]
-  toBEncode resp@(OK {}) = fromAssocs
-    [ "interval"     -->  respInterval resp
-    , "min interval" -->? respMinInterval resp
-    , "complete"     -->? respComplete resp
-    , "incomplete"   -->? respIncomplete resp
-    , "peers"        -->  respPeers resp
-    ]
-
-  fromBEncode (BDict d)
-    | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t
-    | otherwise = OK <$> d >--? "warning message"
-                     <*> d >--  "interval"
-                     <*> d >--? "min interval"
-                     <*> d >--? "complete"
-                     <*> d >--? "incomplete"
-                     <*> getPeers (M.lookup "peers" d)
-
-      where
-        getPeers :: Maybe BEncode -> Result [Peer]
-        getPeers (Just (BList l))     = fromBEncode (BList l)
-        getPeers (Just (BString s))
-            | B.length s `mod` 6 == 0 =
-              let cnt = B.length s `div` 6 in
-              runGet (sequence (L.replicate cnt peerG)) s
-            | otherwise = decodingError "peers length not a multiple of 6"
-          where
-            peerG = do
-              pip   <- getWord32be
-              pport <- getWord16be
-              return (Peer Nothing (fromIntegral pip) (fromIntegral pport))
-
-        getPeers _ = decodingError "Peers"
-
-  fromBEncode _ = decodingError "TResponse"
-
-
-instance URLShow PortNumber where
-  urlShow = urlShow . fromEnum
-
-instance URLShow Word32 where
-  urlShow = show
-
-instance URLShow Event where
-  urlShow e = urlShow (Char.toLower x : xs)
-    where
-      -- this is always nonempty list
-      (x : xs) = show e
-
-instance URLEncode TRequest where
-  urlEncode req = mconcat
-      [ s "peer_id"    %=  reqPeerID req
-      , s "port"       %=  reqPort req
-      , s "uploaded"   %=  reqUploaded req
-      , s "downloaded" %=  reqDownloaded req
-      , s "left"       %=  reqLeft req
-      , s "ip"         %=? reqIP req
-      , s "numwant"    %=? reqNumWant req
-      , s "event"      %=? reqEvent req
-      ]
-    where s :: String -> String;  s = id; {-# INLINE s #-}
-
-encodeRequest :: TRequest -> URI
-encodeRequest req = URL.urlEncode req
-                    `addToURI`      reqAnnounce req
-                    `addHashToURI`  reqInfoHash req
-
-
--- | Ports typically reserved for bittorrent.
-defaultPorts :: [PortNumber]
-defaultPorts = [6881..6889]
-
--- | 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. So default value is set to 25.
---
-defaultNumWant :: Int
-defaultNumWant = 25
-
-
--- | 'TSession' (shorthand for Tracker session) combines tracker request
+-- | 'TConnection' (shorthand for Tracker session) combines tracker request
 --   fields neccessary for tracker, torrent and client identification.
 --
 --   This data is considered as static within one session.
 --
-data TSession = TSession {
-    tsesAnnounce :: URI        -- ^ Announce URL.
-  , tsesInfoHash :: InfoHash   -- ^ Hash of info part of current .torrent file.
-  , tsesPeerID   :: PeerID     -- ^ Client peer ID.
-  , tsesPort     :: PortNumber -- ^ The port number the client is listenning on.
+data TConnection = TConnection {
+    tconnAnnounce :: URI        -- ^ Announce URL.
+  , tconnInfoHash :: InfoHash   -- ^ Hash of info part of current .torrent file.
+  , tconnPeerID   :: PeerID     -- ^ Client peer ID.
+  , tconnPort     :: PortNumber -- ^ The port number the client is listenning on.
   } deriving Show
 
-tsession :: Torrent -> PeerID -> PortNumber -> TSession
-tsession t = TSession (tAnnounce t) (tInfoHash t)
+tconnection :: Torrent -> PeerID -> PortNumber -> TConnection
+tconnection t = TConnection (tAnnounce t) (tInfoHash t)
 
 
 -- | 'Progress' contains upload/download/left stats about
@@ -213,12 +74,12 @@ startProgress = Progress 0 0
 
 
 -- | used to avoid boilerplate; do NOT export me
-genericReq :: TSession -> Progress -> TRequest
+genericReq :: TConnection -> Progress -> TRequest
 genericReq ses pr =   TRequest {
-    reqAnnounce   = tsesAnnounce ses
-  , reqInfoHash   = tsesInfoHash ses
-  , reqPeerID     = tsesPeerID   ses
-  , reqPort       = tsesPort     ses
+    reqAnnounce   = tconnAnnounce ses
+  , reqInfoHash   = tconnInfoHash ses
+  , reqPeerID     = tconnPeerID   ses
+  , reqPort       = tconnPort     ses
 
   , reqUploaded   = prUploaded   pr
   , reqDownloaded = prDownloaded pr
@@ -233,7 +94,7 @@ genericReq ses pr =   TRequest {
 -- | The first request to the tracker that should be created is 'startedReq'.
 --   It includes necessary 'Started' event field.
 --
-startedReq :: TSession -> Progress -> TRequest
+startedReq :: TConnection -> Progress -> TRequest
 startedReq ses pr = (genericReq ses pr) {
     reqIP         = Nothing
   , reqNumWant    = Just defaultNumWant
@@ -244,7 +105,7 @@ startedReq ses pr = (genericReq ses pr) {
 --   notify tracker about current state of the client
 --   so new peers could connect to the client.
 --
-regularReq :: Int -> TSession -> Progress -> TRequest
+regularReq :: Int -> TConnection -> Progress -> TRequest
 regularReq numWant ses pr = (genericReq ses pr) {
     reqIP         = Nothing
   , reqNumWant    = Just numWant
@@ -253,7 +114,7 @@ regularReq numWant ses pr = (genericReq ses pr) {
 
 -- | Must be sent to the tracker if the client is shutting down gracefully.
 --
-stoppedReq :: TSession -> Progress -> TRequest
+stoppedReq :: TConnection -> Progress -> TRequest
 stoppedReq ses pr = (genericReq ses pr) {
     reqIP         = Nothing
   , reqNumWant    = Nothing
@@ -263,7 +124,7 @@ stoppedReq ses pr = (genericReq ses pr) {
 -- | Must be sent to the tracker when the download completes.
 --   However, must not be sent if the download was already 100% complete.
 --
-completedReq :: TSession -> Progress -> TRequest
+completedReq :: TConnection -> Progress -> TRequest
 completedReq ses pr = (genericReq ses pr) {
     reqIP         = Nothing
   , reqNumWant    = Nothing
@@ -271,16 +132,52 @@ completedReq ses pr = (genericReq ses pr) {
   }
 
 
--- | TODO rename to ask for peers
---
-sendRequest :: TRequest -> IO (Result TResponse)
-sendRequest req = do
-  let r = mkHTTPRequest (encodeRequest req)
 
-  rawResp  <- simpleHTTP r
-  respBody <- getResponseBody rawResp
-  return (decoded (BC.pack respBody))
 
+data TSession = TSession {
+    seProgress   :: TVar Progress
+  , seInterval   :: IORef Int
+  , sePeers      :: TVar [Peer]
+  }
+
+newSession :: Progress -> Int -> [Peer] -> IO TSession
+newSession pr i ps = TSession <$> newTVarIO pr <*> newIORef i <*> newTVarIO ps
+
+getPeerList :: TSession -> IO [Peer]
+getPeerList = readTVarIO . sePeers
+
+getProgress :: TSession -> IO Progress
+getProgress = readTVarIO . seProgress
+
+waitInterval :: TSession -> IO ()
+waitInterval = readIORef . seInterval >=> threadDelay
+
+withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a
+withTracker initProgress conn action = bracket start end (action . fst)
   where
-    mkHTTPRequest :: URI -> Request String
-    mkHTTPRequest uri = Request uri GET [] ""
+    start = do
+      res <- sendRequest (startedReq conn initProgress)
+      case res of
+        Left err -> ioError (userError err)
+        Right (Failure err) -> ioError (userError (show err))
+        Right resp -> do
+          se  <- newSession initProgress (respInterval resp) (respPeers resp)
+          tid <- forkIO (syncSession se)
+          return (se, tid)
+
+
+    syncSession se = do
+      waitInterval se
+      pr    <- getProgress se
+      eresp <- sendRequest (regularReq defaultNumWant conn pr)
+      case eresp of
+        Right (OK { respInterval = i, respPeers = ps }) -> do
+          writeIORef (seInterval se) i
+          atomically $ writeTVar (sePeers se) ps
+        _             -> return ()
+      syncSession se
+
+
+    end (se, tid) = do
+      killThread tid
+      getProgress se >>= sendRequest . stoppedReq conn
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs
new file mode 100644
index 00000000..000b38c1
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Protocol.hs
@@ -0,0 +1,204 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--
+--   This module provides straigthforward Tracker protocol
+--   implementation. The tracker is an HTTP/HTTPS service:
+--
+--     * A tracker request is HTTP GET request; used to include
+--   metrics from clients that help the tracker keep overall
+--   statistics about the torrent.
+--
+--     * The tracker response includes a peer list that helps the
+--   client participate in the torrent.
+--
+--   For more convenient high level API see Network.BitTorrent.Tracker
+--   module.
+--
+{-# OPTIONS -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- TODO: add "compact" field to TRequest
+module Network.BitTorrent.Tracker.Protocol
+       ( module Network.BitTorrent.Tracker.Scrape
+
+       , Event(..), TRequest(..), TResponse(..)
+       , sendRequest
+
+         -- * Defaults
+       , defaultPorts, defaultNumWant
+       )
+       where
+
+import Control.Applicative
+import Data.Char as Char
+import Data.Word (Word32)
+import Data.List as L
+import Data.Map  as M
+import Data.Monoid
+import Data.BEncode
+import Data.ByteString as B
+import           Data.ByteString.Char8 as BC
+import           Data.Text as T
+import Data.Serialize.Get hiding (Result)
+import Data.URLEncoded as URL
+import Data.Torrent
+
+import Network
+import Network.Socket
+import Network.HTTP
+import Network.URI
+
+import Network.BitTorrent.Peer
+import Network.BitTorrent.PeerID
+import Network.BitTorrent.Tracker.Scrape
+
+
+data Event = Started   -- ^ For first request.
+           | Stopped   -- ^ Sent when the peer is shutting down.
+           | Completed -- ^ To be sent when the peer completes a download.
+             deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+data TRequest = TRequest { -- TODO peer here -- TODO detach announce
+     reqAnnounce   :: URI         -- ^ Announce url of the torrent.
+   , reqInfoHash   :: InfoHash    -- ^ Hash of info part of the torrent.
+   , reqPeerID     :: PeerID      -- ^ Id of the peer doing request. ()
+   , reqPort       :: PortNumber  -- ^ Port to listen to for connection from other peers.
+   , reqUploaded   :: Integer     -- ^ # of bytes that the peer has uploaded in the swarm.
+   , reqDownloaded :: Integer     -- ^ # of bytes downloaded in the swarm by the peer.
+   , reqLeft       :: Integer     -- ^ # of bytes needed in order to complete download.
+   , reqIP         :: Maybe HostAddress    -- ^ The peer IP.
+   , reqNumWant    :: Maybe Int   -- ^ Number of peers that the peers wants to receive from.
+   , reqEvent      :: Maybe Event -- ^ If not specified,
+                                  --   the request is regular periodic request.
+   } deriving Show
+
+data TResponse =
+     Failure Text           -- ^ Failure reason in human readable form.
+   | OK {
+       respWarning     :: Maybe Text
+     , respInterval    :: Int       -- ^ Recommended interval to wait between requests.
+     , respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests.
+     , respComplete    :: Maybe Int -- ^ Number of peers completed the torrent. (seeders)
+     , respIncomplete  :: Maybe Int -- ^ Number of peers downloading the torrent.
+     , respPeers       :: [Peer]    -- ^ Peers that must be contacted.
+     } deriving Show
+
+instance BEncodable PortNumber where
+  toBEncode = toBEncode . fromEnum
+  fromBEncode b = toEnum <$> fromBEncode b
+
+instance BEncodable Peer where
+  toBEncode (Peer pid pip pport) = fromAssocs
+    [ "peer id" -->? pid
+    , "ip"      -->  pip
+    , "port"    -->  pport
+    ]
+
+  fromBEncode (BDict d) =
+    Peer <$> d >--? "peer id"
+         <*> d >--  "ip"
+         <*> d >--  "port"
+
+  fromBEncode _ = decodingError "Peer"
+
+instance BEncodable TResponse where
+  toBEncode (Failure t)  = fromAssocs ["failure reason" --> t]
+  toBEncode resp@(OK {}) = fromAssocs
+    [ "interval"     -->  respInterval resp
+    , "min interval" -->? respMinInterval resp
+    , "complete"     -->? respComplete resp
+    , "incomplete"   -->? respIncomplete resp
+    , "peers"        -->  respPeers resp
+    ]
+
+  fromBEncode (BDict d)
+    | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t
+    | otherwise = OK <$> d >--? "warning message"
+                     <*> d >--  "interval"
+                     <*> d >--? "min interval"
+                     <*> d >--? "complete"
+                     <*> d >--? "incomplete"
+                     <*> getPeers (M.lookup "peers" d)
+
+      where
+        getPeers :: Maybe BEncode -> Result [Peer]
+        getPeers (Just (BList l))     = fromBEncode (BList l)
+        getPeers (Just (BString s))
+            | B.length s `mod` 6 == 0 =
+              let cnt = B.length s `div` 6 in
+              runGet (sequence (L.replicate cnt peerG)) s
+            | otherwise = decodingError "peers length not a multiple of 6"
+          where
+            peerG = do
+              pip   <- getWord32be
+              pport <- getWord16be
+              return (Peer Nothing (fromIntegral pip) (fromIntegral pport))
+
+        getPeers _ = decodingError "Peers"
+
+  fromBEncode _ = decodingError "TResponse"
+
+
+instance URLShow PortNumber where
+  urlShow = urlShow . fromEnum
+
+instance URLShow Word32 where
+  urlShow = show
+
+instance URLShow Event where
+  urlShow e = urlShow (Char.toLower x : xs)
+    where
+      -- this is always nonempty list
+      (x : xs) = show e
+
+instance URLEncode TRequest where
+  urlEncode req = mconcat
+      [ s "peer_id"    %=  reqPeerID req
+      , s "port"       %=  reqPort req
+      , s "uploaded"   %=  reqUploaded req
+      , s "downloaded" %=  reqDownloaded req
+      , s "left"       %=  reqLeft req
+      , s "ip"         %=? reqIP req
+      , s "numwant"    %=? reqNumWant req
+      , s "event"      %=? reqEvent req
+      ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
+encodeRequest :: TRequest -> URI
+encodeRequest req = URL.urlEncode req
+                    `addToURI`      reqAnnounce req
+                    `addHashToURI`  reqInfoHash req
+
+
+-- | Ports typically reserved for bittorrent.
+defaultPorts :: [PortNumber]
+defaultPorts = [6881..6889]
+
+-- | 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. So default value is set to 25.
+--
+defaultNumWant :: Int
+defaultNumWant = 25
+
+
+
+
+-- | TODO rename to ask for peers
+--
+sendRequest :: TRequest -> IO (Result TResponse)
+sendRequest req = do
+  let r = mkHTTPRequest (encodeRequest req)
+
+  rawResp  <- simpleHTTP r
+  respBody <- getResponseBody rawResp
+  return (decoded (BC.pack respBody))
+
+  where
+    mkHTTPRequest :: URI -> Request String
+    mkHTTPRequest uri = Request uri GET [] ""