Combinatorrent 0.3.1 → 0.3.2
raw patch · 11 files changed
+58/−76 lines, 11 filesdep ~attoparsec
Dependency ranges changed: attoparsec
Files
- Combinatorrent.cabal +2/−2
- src/Combinatorrent.hs +16/−13
- src/Data/PieceSet.hs +0/−20
- src/Process.hs +1/−2
- src/Process/DirWatcher.hs +1/−1
- src/Process/Listen.hs +19/−9
- src/Process/Peer/Sender.hs +3/−5
- src/Process/PieceMgr.hs +1/−0
- src/Process/Tracker.hs +3/−4
- src/Torrent.hs +5/−19
- src/Version.hs.in +7/−1
Combinatorrent.cabal view
@@ -1,6 +1,6 @@ name: Combinatorrent category: Network-version: 0.3.1+version: 0.3.2 category: Network description: Combinatorrent provides a BitTorrent client, based on STM for concurrency. This is an early preview release which is capable of@@ -52,7 +52,7 @@ build-depends: array >= 0.3,- attoparsec,+ attoparsec >= 0.8, base >= 3.0, base < 5.0, bytestring,
src/Combinatorrent.hs view
@@ -6,6 +6,7 @@ import Control.Monad import Control.Monad.State +import Data.Maybe import Data.List import System.Environment@@ -51,6 +52,17 @@ , Option ['S'] ["statfile"] (ReqArg StatFile "FILE") "Choose a file to gather stats into" ] +(~=) :: Flag -> Flag -> Bool+Version ~= Version = True+Debug ~= Debug = True+LogFile _ ~= LogFile _ = True+WatchDir _ ~= WatchDir _ = True+StatFile _ ~= StatFile _ = True+_ ~= _ = False++flag :: Flag -> [Flag] -> Maybe Flag+flag x = find (x ~=)+ progOpts :: [String] -> IO ([Flag], [String]) progOpts args = do case getOpt Permute options args of@@ -63,7 +75,7 @@ if Version `elem` flags then progHeader else case files of- [] -> putStrLn "No torrentfile input"+ [] | isNothing $ flag (WatchDir "") flags -> putStrLn "No torrentfile input" names -> progHeader >> download flags names progHeader :: IO ()@@ -72,20 +84,17 @@ setupLogging :: [Flag] -> IO () setupLogging flags = do- fLog <- case logFlag flags of+ fLog <- case flag (LogFile "") flags of Nothing -> streamHandler SIO.stdout DEBUG Just (LogFile fp) -> fileHandler fp DEBUG Just _ -> error "Impossible match" when (Debug `elem` flags) (updateGlobalLogger rootLoggerName (setHandlers [fLog] . (setLevel DEBUG)))- where logFlag = find (\e -> case e of- LogFile _ -> True- _ -> False) setupDirWatching :: [Flag] -> TorrentManager.TorrentMgrChan -> IO [Child] setupDirWatching flags watchC = do- case dirWatchFlag flags of+ case flag (WatchDir "") flags of Nothing -> return [] Just (WatchDir dir) -> do ex <- doesDirectoryExist dir@@ -94,19 +103,13 @@ else do putStrLn $ "Directory does not exist, not watching" return [] Just _ -> error "Impossible match"- where dirWatchFlag = find (\e -> case e of- WatchDir _ -> True- _ -> False) setupStatus :: [Flag] -> Status.StatusChannel -> TVar [Status.PStat] -> Child setupStatus flags statusC stv =- case statFileFlag flags of+ case flag (StatFile "") flags of Nothing -> Worker $ Status.start Nothing statusC stv Just (StatFile fn) -> Worker $ Status.start (Just fn) statusC stv Just _ -> error "Impossible match"- where statFileFlag = find (\e -> case e of- StatFile _ -> True- _ -> False) generatePeerId :: IO PeerId generatePeerId = do
src/Data/PieceSet.hs view
@@ -4,7 +4,6 @@ , new , size , full- , copy , delete , Data.PieceSet.null , insert@@ -55,11 +54,6 @@ insert n (PieceSet ps) = {-# SCC "Data.PieceSet/insert" #-} liftIO $ writeArray ps n True -copy :: MonadIO m => PieceSet -> m PieceSet-copy (PieceSet ps) = liftIO $ do- newArr <- mapArray id ps- return $ PieceSet $ newArr- size :: MonadIO m => PieceSet -> m Int size (PieceSet arr) = {-# SCC "Data.PieceSet/size" #-} liftIO $ do@@ -118,7 +112,6 @@ , testCase "Intersection" testIntersect , testCase "Membership" testMember , testCase "Insert/Delete" testInsertDelete- , testCase "Copy" testCopy ] testNewSize :: Assertion@@ -182,17 +175,4 @@ assertBool "Ins/del #4" =<< liftM not (member 3 ps) insert 5 ps assertBool "Ins/del #5" =<< member 5 ps--testCopy :: Assertion-testCopy = do- ps <- new 10- insert 3 ps- pc <- copy ps- insert 4 pc- delete 3 pc- assertBool "#1" =<< member 3 ps- assertBool "#2" =<< liftM not (member 3 pc)- assertBool "#3" =<< member 4 pc- assertBool "#4" =<< liftM not (member 4 ps)-
src/Process.hs view
@@ -1,6 +1,7 @@ -- | Core Process code {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving,+ ScopedTypeVariables, MultiParamTypeClasses, CPP #-} -- required for deriving Typeable {-# OPTIONS_GHC -fglasgow-exts #-}@@ -42,9 +43,7 @@ -- channels, and the state the internal process state. It is implemented by means of a transformer -- stack on top of IO. newtype Process a b c = Process (ReaderT a (StateT b IO) c)-#ifndef __HADDOCK__ deriving (Functor, Monad, MonadIO, MonadState b, MonadReader a)-#endif data StopException = StopException deriving (Show, Typeable)
src/Process/DirWatcher.hs view
@@ -50,7 +50,7 @@ processDirectory :: Process CF ST () processDirectory = do watchDir <- asks dirToWatch- files <- liftIO $ getDirectoryContents watchDir+ files <- liftIO $ map (watchDir </>) `fmap` getDirectoryContents watchDir let torrents = S.fromList $ filter (\fp -> (== ".torrent") $ snd . splitExtension $ fp) files running <- get let (added, removed) = (S.toList $ S.difference torrents running,
src/Process/Listen.hs view
@@ -5,11 +5,15 @@ import Control.Concurrent import Control.Concurrent.STM+import Control.Exception (bracketOnError) import Control.Monad.Reader -import Network-import Network.Socket as S+import Data.Word +import Network hiding (accept)+import Network.Socket+import Network.BSD+ import Process import Process.PeerMgr hiding (start) import Supervisor@@ -19,23 +23,29 @@ instance Logging CF where logName _ = "Process.Listen" -start :: PortNumber -> PeerMgrChannel -> SupervisorChannel -> IO ThreadId+start :: Word16 -> PeerMgrChannel -> SupervisorChannel -> IO ThreadId start port peerMgrC supC = do spawnP (CF peerMgrC) () ({-# SCC "Listen" #-} catchP (openListen port >>= eventLoop) (defaultStopHandler supC)) -- TODO: Close socket resource! -openListen :: PortNumber -> Process CF () Socket+openListen :: Word16 -> Process CF () Socket openListen port = liftIO $ do- s <- S.socket S.AF_INET S.Stream S.defaultProtocol- S.bindSocket s (S.SockAddrInet port S.iNADDR_ANY)- S.listen s 10- return s+ proto <- getProtocolNumber "tcp"+ bracketOnError+ (socket AF_INET Stream proto)+ (sClose)+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bindSocket sock (SockAddrInet (toEnum $ fromIntegral port) iNADDR_ANY)+ listen sock maxListenQueue+ return sock+ ) eventLoop :: Socket -> Process CF () () eventLoop sockFd = do c <- asks peerMgrCh liftIO $ do- conn <- S.accept sockFd+ conn <- accept sockFd atomically $ writeTChan c (NewIncoming conn) eventLoop sockFd
src/Process/Peer/Sender.hs view
@@ -25,11 +25,9 @@ -- | The raw sender process, it does nothing but send out what it syncs on. start :: Socket -> TMVar L.ByteString -> SupervisorChannel -> IO ThreadId start s ch supC = spawnP (CF ch s) () ({-# SCC "Sender" #-}- catchP pgm- (do t <- liftIO $ myThreadId- liftIO . atomically $ writeTChan supC $ IAmDying t- liftIO $ sClose s))-+ (cleanupP pgm+ (defaultStopHandler supC)+ (liftIO $ sClose s))) pgm :: Process CF () () pgm = do ch <- asks chan
src/Process/PieceMgr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} module Process.PieceMgr ( PieceMgrMsg(..) , PieceMgrChannel
src/Process/Tracker.hs view
@@ -90,11 +90,11 @@ torrentInfo :: TorrentInfo , peerId :: PeerId , state :: TrackerEvent- , localPort :: S.PortNumber+ , localPort :: Word16 , nextTick :: Integer } -start :: InfoHash -> TorrentInfo -> PeerId -> S.PortNumber+start :: InfoHash -> TorrentInfo -> PeerId -> Word16 -> Status.StatusChannel -> TrackerChannel -> PeerMgr.PeerMgrChannel -> SupervisorChannel -> IO ThreadId start ih ti pid port statusC msgC pc supC =@@ -286,8 +286,7 @@ (trackerfyEvent $ state s) prt :: Process CF ST Integer prt = do lp <- gets localPort- case lp of- PortNum pnum -> return $ fromIntegral pnum+ return $! fromIntegral lp trackerfyEvent ev = case ev of Running -> []
src/Torrent.hs view
@@ -16,12 +16,10 @@ , Block(..) , Capabilities(..) -- * Interface- , determineState , bytesLeft , defaultBlockSize , defaultOptimisticSlots , defaultPort- , haskellTorrentVersion , mkPeerId , mkTorrentInfo )@@ -32,12 +30,10 @@ import Data.Array import Data.List-import qualified Data.Foldable as F import qualified Data.ByteString as B import qualified Data.Map as M+import Data.Word -import Network-import Network.Socket import Numeric import System.Random@@ -45,6 +41,7 @@ import Protocol.BCode import Digest+import Version -- | The type of Infohashes as used in torrents. These are identifiers -- of torrents@@ -90,11 +87,6 @@ -- | The PiecesDoneMap is a map which is true if we have the piece and false otherwise type PiecesDoneMap = M.Map PieceNum Bool --- | Given what pieces that are done, return the current state of the client.-determineState :: PiecesDoneMap -> TorrentState-determineState pd | F.all (==True) pd = Seeding- | otherwise = Leeching- -- | Return the amount of bytes left on a torrent given what pieces are done and the -- map of the shape of the torrent in question. bytesLeft :: PiecesDoneMap -> PieceMap -> Integer@@ -128,14 +120,8 @@ defaultOptimisticSlots = 2 -- | Default port to communicate on-defaultPort :: PortNumber-defaultPort = PortNum $ fromInteger 1579---- | The current version of the Combinatorrent protocol string. This is bumped--- whenever we make a radical change to the protocol communication or fix a grave bug.--- It provides a way for trackers to disallow versions of the client which are misbehaving.-haskellTorrentVersion :: String-haskellTorrentVersion = "d001"+defaultPort :: Word16+defaultPort = 1579 -- | Convert a BCode block into its corresponding TorrentInfo block, perhaps -- failing in the process.@@ -158,4 +144,4 @@ randomList n = take n . unfoldr (Just . random) rs = randomList 10 gen ranString = concatMap (\i -> showHex (abs i) "") rs- header = "-HT" ++ haskellTorrentVersion ++ "-"+ header = "-CT" ++ protoVersion ++ "-"
src/Version.hs.in view
@@ -1,5 +1,11 @@ -- | Combinatorrent version-module Version (version) where+module Version (protoVersion, version) where++-- | The current version of the Combinatorrent protocol string. This is bumped+-- whenever we make a radical change to the protocol communication or fix a grave bug.+-- It provides a way for trackers to disallow versions of the client which are misbehaving.+protoVersion :: String+protoVersion = "d001" githead :: String githead = "@GITHEAD@"