6 files changed, 64 insertions, 83 deletions

diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs
index c166b1b1..26824724 100644
--- a/src/Network/BitTorrent.hs
+++ b/src/Network/BitTorrent.hs
@@ -28,25 +28,19 @@ module Network.BitTorrent
        , ppExtension
        ) where
 
-import Control.Concurrent
-import Control.Monad
-import Control.Monad.Trans
 import Network
 import Data.Torrent
 import Network.BitTorrent.Sessions.Types
 import Network.BitTorrent.Sessions
 import Network.BitTorrent.Extension
-import Network.BitTorrent.Exchange
-
-import System.Torrent.Storage
 
 -- TODO remove fork from Network.BitTorrent.Exchange
 -- TODO make all forks in Internal.
 
 -- | Client session with default parameters. Use it for testing only.
 withDefaultClient :: PortNumber -> PortNumber -> (ClientSession -> IO ()) -> IO ()
-withDefaultClient dhtPort listPort action = do
-  withClientSession defaultThreadCount defaultExtensions listPort dhtPort action
+withDefaultClient listPort dhtPort action = do
+  withClientSession defaultThreadCount [] listPort dhtPort action
 
 {-----------------------------------------------------------------------
     Torrent management
@@ -68,14 +62,6 @@ addTorrent clientSession loc @ TorrentLoc {..} = do
   torrent <- validateLocation loc
 --  registerTorrent loc tInfoHash
 --  when (bf is not full)
-
-  swarm   <- newLeecher  clientSession torrent
-  storage <- openStorage (torrentMeta swarm) dataDirPath
-  forkIO $ discover swarm $ do
-    liftIO $ putStrLn "connected to peer"
-    forever $ do
-      liftIO $ putStrLn "from mesage loop"
-      exchange storage
   return ()
 
 -- | Unregister torrent and stop all running sessions.
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 32ab493d..52b5f690 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -71,7 +71,6 @@ module Network.BitTorrent.Exchange
 
 import Control.Applicative
 import Control.Exception
-import Control.Concurrent
 import Control.Lens
 import Control.Monad.Reader
 import Control.Monad.State
@@ -89,7 +88,6 @@ import Network
 
 import Data.Bitfield as BF
 import Network.BitTorrent.Extension
-import Network.BitTorrent.Peer
 import Network.BitTorrent.Exchange.Protocol
 import Network.BitTorrent.Sessions.Types
 import System.Torrent.Storage
@@ -117,7 +115,8 @@ awaitMessage = P2P $ ReaderT $ const $ {-# SCC awaitMessage #-} go
 {-# INLINE awaitMessage #-}
 
 yieldMessage :: Message -> P2P ()
-yieldMessage msg =  P2P $ ReaderT $ const $ {-# SCC yieldMessage #-} C.yield msg
+yieldMessage msg = P2P $ ReaderT $ const $ {-# SCC yieldMessage #-} do
+  C.yield msg
 {-# INLINE yieldMessage #-}
 
 -- TODO send vectored
@@ -209,7 +208,6 @@ singletonBF i = liftM (BF.singleton i) getPieceCount
 adjustBF :: Bitfield -> P2P Bitfield
 adjustBF bf = (`adjustSize` bf) `liftM` getPieceCount
 
-
 peerWant   :: P2P Bitfield
 peerWant   = BF.difference <$> getClientBF  <*> use bitfield
 
@@ -306,7 +304,8 @@ data Event
 awaitEvent :: P2P Event
 awaitEvent = {-# SCC awaitEvent #-} do
     flushPending
-    awaitMessage >>= go
+    msg <- awaitMessage
+    go msg
   where
     go KeepAlive = awaitEvent
     go Choke     = do
@@ -464,7 +463,7 @@ exchange :: Storage -> P2P ()
 exchange storage = {-# SCC exchange #-} awaitEvent >>= handler
   where
     handler (Available bf) = do
-      liftIO (print (completeness bf))
+      liftIO $ print (completeness bf)
       ixs <- selBlk (findMin bf) storage
       mapM_ (yieldEvent . Want) ixs -- TODO yield vectored
 
diff --git a/src/Network/BitTorrent/Peer.hs b/src/Network/BitTorrent/Peer.hs
index cdcd65ea..7bac336b 100644
--- a/src/Network/BitTorrent/Peer.hs
+++ b/src/Network/BitTorrent/Peer.hs
@@ -196,6 +196,8 @@ timestamp = (BC.pack . format) <$> getCurrentTime
 entropy :: IO ByteString
 entropy = getEntropy 15
 
+-- NOTE: entropy generates incorrrect peer id
+
 -- |  Here we use Azureus-style encoding with the following args:
 --
 --      * 'HS' for the client id.
@@ -205,7 +207,7 @@ entropy = getEntropy 15
 --      * UTC time day ++ day time for the random number.
 --
 genPeerId :: IO PeerId
-genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> entropy
+genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
 
 -- | Pad bytestring so it's becomes exactly request length. Conversion
 -- is done like so:
diff --git a/src/Network/BitTorrent/Sessions.hs b/src/Network/BitTorrent/Sessions.hs
index 1f34bd4c..4d4cf629 100644
--- a/src/Network/BitTorrent/Sessions.hs
+++ b/src/Network/BitTorrent/Sessions.hs
@@ -30,15 +30,14 @@ module Network.BitTorrent.Sessions
        , getCurrentProgress
        , getSwarmCount
        , getPeerCount
+       , getSwarm
+       , openSwarmSession
 
          -- * Swarm
        , SwarmSession( SwarmSession, torrentMeta, clientSession )
 
        , SessionCount
        , getSessionCount
-
-       , newLeecher
-       , newSeeder
        , getClientBitfield
 
        , discover
@@ -63,6 +62,7 @@ import Data.Set as S
 import Data.Serialize hiding (get)
 
 import Network hiding (accept)
+import Network.BSD
 import Network.Socket
 import Network.Socket.ByteString
 
@@ -177,14 +177,14 @@ getListenerPort ClientSession {..} = servPort <$> readMVar peerListener
 defSeederConns :: SessionCount
 defSeederConns = defaultUnchokeSlots
 
-defLeacherConns :: SessionCount
-defLeacherConns = defaultNumWant
+defLeecherConns :: SessionCount
+defLeecherConns = defaultNumWant
 
 -- discovery should hide tracker and DHT communication under the hood
 -- thus we can obtain an unified interface
 
-discover :: SwarmSession -> P2P () -> IO ()
-discover swarm @ SwarmSession {..} action = {-# SCC discover #-} do
+discover :: SwarmSession -> IO ()
+discover swarm @ SwarmSession {..} = {-# SCC discover #-} do
   port <- getListenerPort clientSession
 
   let conn = TConnection {
@@ -199,37 +199,46 @@ discover swarm @ SwarmSession {..} action = {-# SCC discover #-} do
   withTracker progress conn $ \tses -> do
     forever $ do
       addr <- getPeerAddr tses
+      print addr
       forkThrottle swarm $ do
-        initiatePeerSession swarm addr $ \conn ->
-          runP2P conn action
+        print addr
+        initiatePeerSession swarm addr $ \conn -> do
+          print addr
+          runP2P conn (exchange storage)
 
-registerSwarmSession :: SwarmSession -> IO ()
-registerSwarmSession = undefined
+registerSwarmSession :: SwarmSession -> STM ()
+registerSwarmSession ss @ SwarmSession {..} =
+  modifyTVar' (swarmSessions clientSession) $
+    M.insert (tInfoHash torrentMeta) ss
 
-unregisterSwarmSession :: SwarmSession -> IO ()
+unregisterSwarmSession :: SwarmSession -> STM ()
 unregisterSwarmSession SwarmSession {..} =
-  atomically $ modifyTVar (swarmSessions clientSession) $
+  modifyTVar' (swarmSessions clientSession) $
     M.delete $ tInfoHash torrentMeta
 
-newSwarmSession :: Int -> Bitfield -> ClientSession -> Torrent
-                -> IO SwarmSession
-newSwarmSession n bf cs @ ClientSession {..} t @ Torrent {..}
-  = SwarmSession t cs
-    <$> MSem.new n
+openSwarmSession :: ClientSession -> TorrentLoc -> IO SwarmSession
+openSwarmSession cs @ ClientSession {..} loc @ TorrentLoc {..} = do
+  t <- validateLocation loc
+  let bf = haveNone $ pieceCount $ tInfo t
+
+  ss <- SwarmSession t cs
+    <$> MSem.new defLeecherConns
     <*> newTVarIO bf
-    <*> undefined
+    <*> openStorage t dataDirPath
     <*> newTVarIO S.empty
     <*> newBroadcastTChanIO
 
--- > openSwarmSession :: ClientSession -> InfoHash -> IO SwarmSession
--- > openSwarmSession ClientSession {..} ih = do
--- >   loc <- HM.lookup <$> readTVarIO torrentMap
--- >   torrent <- validateLocation loc
--- >   return undefined
+  atomically $ do
+    modifyTVar' currentProgress $ enqueuedProgress $ contentLength $ tInfo t
+    registerSwarmSession ss
+
+  forkIO $ discover ss
+
+  return ss
 
 closeSwarmSession :: SwarmSession -> IO ()
 closeSwarmSession se @ SwarmSession {..} = do
-  unregisterSwarmSession se
+  atomically $ unregisterSwarmSession se
   -- TODO stop discovery
   -- TODO killall peer sessions
   -- TODO the order is important!
@@ -237,21 +246,11 @@ closeSwarmSession se @ SwarmSession {..} = do
 
 getSwarm :: ClientSession -> InfoHash -> IO SwarmSession
 getSwarm cs @ ClientSession {..} ih = do
-  ss <- readTVarIO swarmSessions
-  case M.lookup ih ss of
-    Just sw -> return sw
-    Nothing -> undefined -- openSwarmSession cs
-
-newSeeder :: ClientSession -> Torrent -> IO SwarmSession
-newSeeder cs t @ Torrent {..}
-  = newSwarmSession defSeederConns (haveAll (pieceCount tInfo)) cs t
-
--- | New swarm in which the client allowed both download and upload.
-newLeecher :: ClientSession -> Torrent -> IO SwarmSession
-newLeecher cs t @ Torrent {..} = do
-  se <- newSwarmSession defLeacherConns (haveNone (pieceCount tInfo)) cs t
-  atomically $ modifyTVar' (currentProgress cs) (enqueuedProgress (contentLength tInfo))
-  return se
+  status <- torrentPresence cs ih
+  case status of
+    Unknown        -> throw $ UnknownTorrent ih
+    Active sw      -> return sw
+    Registered loc -> openSwarmSession cs loc
 
 -- | Get the number of connected peers in the given swarm.
 getSessionCount :: SwarmSession -> IO SessionCount
@@ -284,9 +283,6 @@ leaveSwarm SwarmSession {..} = do
   MSem.signal vacantPeers
   MSem.signal (activeThreads clientSession)
 
-waitVacancy :: SwarmSession -> IO () -> IO ()
-waitVacancy se = bracket (enterSwarm se) (const (leaveSwarm se)) . const
-
 forkThrottle :: SwarmSession -> IO () -> IO ThreadId
 forkThrottle se action = do
    enterSwarm se
@@ -304,14 +300,6 @@ registerTorrent = error "registerTorrent"
 unregisterTorrent :: TVar TorrentMap -> InfoHash -> IO ()
 unregisterTorrent = error "unregisterTorrent"
 
-torrentSwarm :: ClientSession -> InfoHash -> TorrentPresence -> IO SwarmSession
-torrentSwarm _  _  (Active     sws) = return sws
-torrentSwarm cs _  (Registered loc) = newSeeder cs =<< validateLocation loc
-torrentSwarm _  ih  Unknown         = throw $ UnknownTorrent ih
-
-lookupSwarm :: ClientSession -> InfoHash -> IO SwarmSession
-lookupSwarm cs ih = torrentSwarm cs ih =<< torrentPresence cs ih
-
 {-----------------------------------------------------------------------
   Peer session creation
 ------------------------------------------------------------------------
@@ -353,6 +341,7 @@ openSession ss @ SwarmSession {..} addr Handshake {..} = do
   registerPeerSession ps
   return ps
 
+-- TODO kill thread
 closeSession :: PeerSession -> IO ()
 closeSession = unregisterPeerSession
 
@@ -384,10 +373,11 @@ runSession connector opener action =
 -- | Used then the client want to connect to a peer.
 initiatePeerSession :: SwarmSession -> PeerAddr -> Exchange -> IO ()
 initiatePeerSession ss @ SwarmSession {..} addr
-    = runSession (connectToPeer addr) initiated
+    = runSession (putStrLn ("trying to connect" ++ show addr) *> connectToPeer addr <* putStrLn "connected") initiated
   where
     initiated sock = do
       phs  <- handshake sock (swarmHandshake ss)
+      putStrLn "handshaked"
       ps   <- openSession ss addr phs
       sendClientStatus (sock, ps)
       return ps
@@ -398,7 +388,7 @@ acceptPeerSession cs@ClientSession {..} addr s = runSession (pure s) accepted
   where
     accepted sock = do
       phs   <- recvHandshake sock
-      swarm <- lookupSwarm cs $ hsInfoHash phs
+      swarm <- getSwarm cs $ hsInfoHash phs
       ps    <- openSession swarm addr phs
       sendHandshake sock $ Handshake {
           hsProtocol = defaultBTProtocol
@@ -413,17 +403,22 @@ listener :: ClientSession -> Exchange -> PortNumber -> IO ()
 listener cs action serverPort = bracket openListener close loop
   where
     loop sock = forever $ handle isIOError $ do
+      putStrLn "listen"
+      print =<< getSocketName sock
       (conn, addr) <- accept sock
+      putStrLn "accepted"
       case addr of
         SockAddrInet port host -> do
-          acceptPeerSession cs (PeerAddr Nothing host port) conn action
+          forkIO $ do
+            acceptPeerSession cs (PeerAddr Nothing host port) conn action
+          return ()
         _                      -> return ()
 
     isIOError :: IOError -> IO ()
     isIOError _ = return ()
 
     openListener  = do
-      sock <- socket AF_INET Stream defaultProtocol
-      bindSocket sock (SockAddrInet serverPort 0)
+      sock <- socket AF_INET Stream =<< getProtocolNumber "tcp"
+      bindSocket sock (SockAddrInet serverPort iNADDR_ANY)
       listen sock 1
       return sock
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index b320f0f9..b737a3df 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -241,9 +241,7 @@ withTracker initProgress conn action = bracket start end (action . fst)
             -- commutative: this implements the heuristic "old peers
             -- in head"
             old <- BC.getChanContents sePeers
-            let new = respPeers
-            let combined = L.union old new
-
+            let combined = L.union old respPeers
             BC.writeList2Chan sePeers combined
 
           _ -> return ()
diff --git a/src/System/Torrent/Storage.hs b/src/System/Torrent/Storage.hs
index 6a748fe3..cd1a8364 100644
--- a/src/System/Torrent/Storage.hs
+++ b/src/System/Torrent/Storage.hs
@@ -92,8 +92,9 @@ openStorage t @ Torrent {..} contentPath = do
       unless exist $ do
         createDirectoryIfMissing True dirPath
 
+-- TODO
 closeStorage :: Storage -> IO ()
-closeStorage st = error "closeStorage"
+closeStorage st = return ()
 
 
 withStorage :: Torrent -> FilePath -> (Storage -> IO a) -> IO a