From 7313c139eb5a75edf4fca36e5d0f401584ab7502 Mon Sep 17 00:00:00 2001
From: Sam T <pxqr.sta@gmail.com>
Date: Mon, 10 Jun 2013 05:42:15 +0400
Subject: ~ Sketch of high level API.

---
 src/Network/BitTorrent/Exchange.hs  | 137 ++++++++++++++++++++++++++++++------
 src/Network/BitTorrent/Extension.hs |   4 +-
 2 files changed, 116 insertions(+), 25 deletions(-)

(limited to 'src/Network/BitTorrent')

diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs
index 425ed2a3..4fe90cda 100644
--- a/src/Network/BitTorrent/Exchange.hs
+++ b/src/Network/BitTorrent/Exchange.hs
@@ -6,27 +6,34 @@
 --   Portability :  portable
 --
 {-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
 module Network.BitTorrent.Exchange
-       (
-         -- * Session
-         PeerSession, newLeacher, newSeeder
+       ( P2P, withPeer
        ) where
 
 import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Reader
+import Control.Monad.State
+
 import Data.IORef
 import Data.Function
 import Data.Ord
 import Data.Set as S
 
-import Data.Conduit
+import Data.Conduit as C
 import Data.Conduit.Cereal
 import Data.Conduit.Network
-import Data.Serialize
+import Data.Serialize as S
+
+import Network
 
-import Network.BitTorrent.Exchange.Selection as PW
-import Network.BitTorrent.Exchange.Protocol as PW
+import Network.BitTorrent.Exchange.Selection
+import Network.BitTorrent.Exchange.Protocol
 
 import Network.BitTorrent.Internal
 import Network.BitTorrent.Extension
@@ -38,29 +45,113 @@ import Data.Torrent
     P2P monad
 -----------------------------------------------------------------------}
 
-{-
-type P2P = Reader PeerSession (ConduitM Message Message IO)
+type PeerWire = ConduitM Message Message IO
+
+waitMessage :: PeerWire Message
+waitMessage = await >>= maybe waitMessage return
+
+signalMessage :: Message -> PeerWire ()
+signalMessage = C.yield
 
-conduit :: Socket -> P2P a -> IO a
-conduit sock p2p =
+newtype P2P a = P2P {
+    runP2P :: ReaderT PeerSession PeerWire a
+  } deriving (Monad, MonadReader PeerSession, MonadIO)
+
+instance MonadState Bitfield P2P where
+
+runConduit :: Socket -> Conduit Message IO Message -> IO ()
+runConduit sock p2p =
   sourceSocket sock   $=
-    conduitGet get    $=
-      messageLoop p2p $=
-    conduitPut put    $$
+    conduitGet S.get  $=
+      forever p2p     $=
+    conduitPut S.put  $$
   sinkSocket sock
 
-messageLoop :: P2P () -> P2P ()
-messageLoop = undefined
-
-runP2P :: SSession -> PeerAddr -> P2P a -> IO a
-runP2P se addr p2p = withPeer se addr $ conduit messageLoop
+withPeer :: SwarmSession -> PeerAddr -> P2P () -> IO ()
+withPeer se addr p2p =
+  withPeerSession se addr $ \(sock, pses) -> do
+    runConduit sock (runReaderT (runP2P p2p) pses)
 
-data Event = Available
+data Event = Available Bitfield
            | Want
            | Block
 
-{-
+
+
 waitForEvent :: P2P Event
+waitForEvent = P2P (ReaderT nextEvent)
+  where
+    nextEvent se @ PeerSession {..} = waitMessage >>= diff
+      where
+        -- diff finds difference between
+        diff KeepAlive = do
+          signalMessage KeepAlive
+          nextEvent se
+
+        handleMessage Choke     = do
+          SessionStatus {..} <- liftIO $ readIORef peerSessionStatus
+          if psChoking  sePeerStatus
+            then nextEvent se
+            else undefined
+
+        handleMessage Unchoke   = return $ Available BF.difference
+
+        handleMessage Interested = return undefined
+        handleMessage NotInterested = return undefined
+
+        handleMessage (Have ix) = do
+          pc <- liftIO $ getPieceCount se
+          haveMessage $ have ix (haveNone pc) -- TODO singleton
+
+        handleMessage (Bitfield bf) = undefined
+        handleMessage (Request  bix) = do
+          undefined
+
+        handleMessage (Piece    blk) = undefined
+        handleMessage (Port     _)
+          = checkExtension msg ExtDHT $ do
+              undefined
+
+        handleMessage msg @ HaveAll
+          = checkExtension msg ExtFast $ do
+              pc <- liftIO $ getPieceCount se
+              haveMessage (haveAll pc)
+
+        handleMessage msg @ HaveNone
+          = checkExtension msg ExtFast $ do
+              pc <- liftIO $ getPieceCount se
+              haveMessage (haveNone pc)
+
+        handleMessage msg @ (SuggestPiece ix)
+          = checkExtension msg ExtFast $ do
+            undefined
+
+        handleMessage msg @ (RejectRequest ix)
+          = checkExtension msg ExtFast $ do
+            undefined
+
+        handleMessage msg @ (AllowedFast pix)
+          = checkExtension msg ExtFast $ do
+            undefined
+
+        haveMessage bf = do
+          cbf <- liftIO $ readIORef $ clientBitfield swarmSession
+          if undefined -- ix `member` bf
+            then nextEvent se
+            else return $ Available diff
+
+        checkExtension msg requredExtension action
+            | requredExtension `elem` enabledExtensions = action
+            | otherwise = liftIO $ throwIO $ userError errorMsg
+          where
+            errorMsg = show (ppExtension requredExtension)
+                    ++  "not enabled, but peer sent"
+                    ++ show (ppMessage msg)
+
+
+
+getPieceCount :: PeerSession -> IO PieceCount
+getPieceCount = undefined
+
 signalEvent  :: Event -> P2P ()
--}
--}
\ No newline at end of file
+signalEvent = undefined
diff --git a/src/Network/BitTorrent/Extension.hs b/src/Network/BitTorrent/Extension.hs
index 0526ace7..13a30581 100644
--- a/src/Network/BitTorrent/Extension.hs
+++ b/src/Network/BitTorrent/Extension.hs
@@ -12,8 +12,8 @@
 --
 {-# LANGUAGE OverloadedStrings #-}
 module Network.BitTorrent.Extension
-       ( Capabilities, ppCaps, defaultCaps, enabledCaps
-       , Extension, ppExtension, encodeExts, decodeExts
+       ( Capabilities,  ppCaps, defaultCaps, enabledCaps
+       , Extension(..), ppExtension, encodeExts, decodeExts
        ) where
 
 import Data.Bits
-- 
cgit v1.2.3