summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent/Exchange/Session.hs53
1 files changed, 34 insertions, 19 deletions
diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs
index 4b9b0fdb..57d21579 100644
--- a/src/Network/BitTorrent/Exchange/Session.hs
+++ b/src/Network/BitTorrent/Exchange/Session.hs
@@ -97,12 +97,14 @@ data Session = Session
97 , sessionLogger :: !(LogFun) 97 , sessionLogger :: !(LogFun)
98 , sessionEvents :: !(SendPort SessionEvent) 98 , sessionEvents :: !(SendPort SessionEvent)
99 99
100------------------------------------------------------------------------
100 , metadata :: !(MVar Metadata.Status) 101 , metadata :: !(MVar Metadata.Status)
101 , infodict :: !(MVar (Cached InfoDict)) 102 , infodict :: !(MVar (Cached InfoDict))
102 103
103 , status :: !(MVar SessionStatus) 104 , status :: !(MVar SessionStatus)
104 , storage :: !(Storage) 105 , sessionStorage :: !(MVar Storage)
105 106
107------------------------------------------------------------------------
106 , connectionsPrefs :: !ConnectionPrefs 108 , connectionsPrefs :: !ConnectionPrefs
107 109
108 -- | Connections either waiting for TCP/uTP 'connect' or waiting 110 -- | Connections either waiting for TCP/uTP 'connect' or waiting
@@ -133,28 +135,32 @@ newSession :: LogFun
133 -> IO Session -- ^ 135 -> IO Session -- ^
134newSession logFun addr rootPath dict = do 136newSession logFun addr rootPath dict = do
135 pid <- maybe genPeerId return (peerId addr) 137 pid <- maybe genPeerId return (peerId addr)
136 store <- openInfoDict ReadWriteEx rootPath dict 138 let ih = idInfoHash dict
137 statusVar <- newMVar $ sessionStatus (BF.haveNone (totalPieces store)) 139 eventStream <- newSendPort
140
141 storage <- openInfoDict ReadWriteEx rootPath dict
142 storageVar <- newMVar storage
143
144 statusVar <- newMVar $ sessionStatus (BF.haveNone (totalPieces storage))
138 (piPieceLength (idPieceInfo dict)) 145 (piPieceLength (idPieceInfo dict))
146
139 metadataVar <- newMVar (error "sessionMetadata") 147 metadataVar <- newMVar (error "sessionMetadata")
140 infodictVar <- newMVar (cache dict) 148 infodictVar <- newMVar (cache dict)
141 149
142 pSetVar <- newTVarIO S.empty 150 pSetVar <- newTVarIO S.empty
143 eSetVar <- newTVarIO M.empty 151 eSetVar <- newTVarIO M.empty
144 chan <- newChan 152 chan <- newChan
145 eventStream <- newSendPort
146 153
147 return Session 154 return Session
148 { sessionPeerId = pid 155 { sessionPeerId = pid
149 , sessionTopic = idInfoHash dict 156 , sessionTopic = ih
150 , sessionLogger = logFun 157 , sessionLogger = logFun
151 , sessionEvents = eventStream 158 , sessionEvents = eventStream
152 159
153 , metadata = metadataVar 160 , metadata = metadataVar
154 , infodict = infodictVar 161 , infodict = infodictVar
155
156 , status = statusVar 162 , status = statusVar
157 , storage = store 163 , sessionStorage = storageVar
158 164
159 , connectionsPrefs = def 165 , connectionsPrefs = def
160 , connectionsPending = pSetVar 166 , connectionsPending = pSetVar
@@ -165,7 +171,8 @@ newSession logFun addr rootPath dict = do
165 171
166closeSession :: Session -> IO () 172closeSession :: Session -> IO ()
167closeSession Session {..} = do 173closeSession Session {..} = do
168 close storage 174 mstorage <- tryReadMVar sessionStorage
175 maybe (return ()) close mstorage
169{- 176{-
170 hSet <- atomically $ do 177 hSet <- atomically $ do
171 pSet <- swapTVar connectionsPending S.empty 178 pSet <- swapTVar connectionsPending S.empty
@@ -448,19 +455,27 @@ handleTransfer (Request bix) = do
448 bitfield <- getThisBitfield 455 bitfield <- getThisBitfield
449 upload <- canUpload <$> use connStatus 456 upload <- canUpload <$> use connStatus
450 when (upload && ixPiece bix `BF.member` bitfield) $ do 457 when (upload && ixPiece bix `BF.member` bitfield) $ do
451 blk <- liftIO $ readBlock bix storage 458 mstorage <- liftIO $ tryReadMVar sessionStorage
452 sendMessage (Message.Piece blk) 459 case mstorage of
460 Nothing -> return ()
461 Just storage -> do
462 blk <- liftIO $ readBlock bix storage
463 sendMessage (Message.Piece blk)
453 464
454handleTransfer (Message.Piece blk) = do 465handleTransfer (Message.Piece blk) = do
455 Session {..} <- asks connSession 466 Session {..} <- asks connSession
456 isSuccess <- withStatusUpdates (SS.pushBlock blk storage) 467 mstorage <- liftIO $ tryReadMVar sessionStorage
457 case isSuccess of 468 case mstorage of
458 Nothing -> liftIO $ throwIO $ userError "block is not requested" 469 Nothing -> return () -- TODO (?) break connection
459 Just isCompleted -> do 470 Just storage -> do
460 when isCompleted $ do 471 isSuccess <- withStatusUpdates (SS.pushBlock blk storage)
461 sendBroadcast (Have (blkPiece blk)) 472 case isSuccess of
462-- maybe send not interested 473 Nothing -> liftIO $ throwIO $ userError "block is not requested"
463 tryFillRequestQueue 474 Just isCompleted -> do
475 when isCompleted $ do
476 sendBroadcast (Have (blkPiece blk))
477-- maybe send not interested
478 tryFillRequestQueue
464 479
465handleTransfer (Cancel bix) = filterQueue (not . (transferResponse bix)) 480handleTransfer (Cancel bix) = filterQueue (not . (transferResponse bix))
466 where 481 where
@@ -546,7 +561,7 @@ mainWire :: Wire Session ()
546mainWire = do 561mainWire = do
547 lift establishedConnection 562 lift establishedConnection
548 Session {..} <- asks connSession 563 Session {..} <- asks connSession
549 lift $ resizeBitfield (totalPieces storage) 564-- lift $ resizeBitfield (totalPieces storage)
550 logEvent "Connection established" 565 logEvent "Connection established"
551 iterM logMessage =$= exchange =$= iterM logMessage 566 iterM logMessage =$= exchange =$= iterM logMessage
552 lift finishedConnection 567 lift finishedConnection