+ Default P2P.

4 files changed, 43 insertions, 1 deletions

diff --git a/bittorrent.cabal b/bittorrent.cabal
index fbd045f4..7f1a9be5 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -101,7 +101,8 @@ library
 
                        -- System
                      , filepath    >= 1
-                     , mmap         >= 0.5.2
+                     , directory   >= 1
+                     , mmap        >= 0.5.2
 
                        -- Misc
                      , data-default
diff --git a/examples/Main.hs b/examples/Main.hs
index d0404405..fdf982d8 100644
--- a/examples/Main.hs
+++ b/examples/Main.hs
@@ -20,6 +20,9 @@ main = do
   client  <- newClient 100 []
   swarm   <- newLeecher  client torrent
 
+--  storage <- bindStorage swarm "/tmp/"
+--  discover swarm $ exchange storage
+
   ref <- liftIO $ newIORef 0
   discover swarm $ do
     forever $ do
diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs
index ec0adb51..b97db4b0 100644
--- a/src/Network/BitTorrent.hs
+++ b/src/Network/BitTorrent.hs
@@ -73,6 +73,7 @@ import Control.Monad.Reader
 
 import Network
 
+import Data.Bitfield
 import Data.Torrent
 import Network.BitTorrent.Internal
 import Network.BitTorrent.Exchange
@@ -81,6 +82,8 @@ import Network.BitTorrent.Tracker
 import Network.BitTorrent.Extension
 import Network.BitTorrent.Peer
 
+import System.Torrent.Storage
+
 
 -- | Client session with default parameters. Use it for testing only.
 defaultClient :: IO ClientSession
@@ -105,3 +108,33 @@ discover swarm action = do
       addr <- getPeerAddr tses
       spawnP2P swarm addr $ do
         action
+
+-- Event translation table looks like:
+--
+--   Available -> Want
+--   Want      -> Fragment
+--   Fragment  -> Available
+--
+-- If we join the chain we get the event loop:
+--
+--   Available -> Want -> Fragment --\
+--      /|\                           |
+--       \---------------------------/
+--
+
+-- | Default P2P action.
+exchange :: Storage -> P2P ()
+exchange storage = handleEvent handler
+  where
+    handler (Available bf)
+      | Just m <- findMin bf = return (Want (BlockIx m 0 10))
+      |     otherwise        = error "impossible"
+                               -- TODO findMin :: Bitfield -> PieceIx
+
+    handler (Want     bix) = do
+      blk <- liftIO $ getBlk bix storage
+      return (Fragment blk)
+
+    handler (Fragment blk) = do
+      liftIO $ putBlk blk storage
+      return (Available (singleton (blkPiece blk) (error "singleton") ))
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 2eedc6bd..3d05f7fc 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -58,6 +58,7 @@ module Network.BitTorrent.Exchange
        , Event(..)
        , awaitEvent
        , yieldEvent
+       , handleEvent
 
          -- * Exceptions
        , disconnect
@@ -444,6 +445,10 @@ yieldEvent (Fragment  blk) = do
     then yieldMessage (Piece blk)
     else return ()
 
+
+handleEvent :: (Event -> P2P Event) -> P2P ()
+handleEvent action = awaitEvent >>= action >>= yieldEvent
+
 --flushBroadcast :: P2P ()
 --flushBroadcast = nextBroadcast >>= maybe (return ()) go
 --  where