diff --git a/Combinatorrent.cabal b/Combinatorrent.cabal --- a/Combinatorrent.cabal +++ b/Combinatorrent.cabal @@ -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, diff --git a/src/Combinatorrent.hs b/src/Combinatorrent.hs --- a/src/Combinatorrent.hs +++ b/src/Combinatorrent.hs @@ -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 diff --git a/src/Data/PieceSet.hs b/src/Data/PieceSet.hs --- a/src/Data/PieceSet.hs +++ b/src/Data/PieceSet.hs @@ -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) - diff --git a/src/Process.hs b/src/Process.hs --- a/src/Process.hs +++ b/src/Process.hs @@ -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) diff --git a/src/Process/DirWatcher.hs b/src/Process/DirWatcher.hs --- a/src/Process/DirWatcher.hs +++ b/src/Process/DirWatcher.hs @@ -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, diff --git a/src/Process/Listen.hs b/src/Process/Listen.hs --- a/src/Process/Listen.hs +++ b/src/Process/Listen.hs @@ -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 diff --git a/src/Process/Peer/Sender.hs b/src/Process/Peer/Sender.hs --- a/src/Process/Peer/Sender.hs +++ b/src/Process/Peer/Sender.hs @@ -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 diff --git a/src/Process/PieceMgr.hs b/src/Process/PieceMgr.hs --- a/src/Process/PieceMgr.hs +++ b/src/Process/PieceMgr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module Process.PieceMgr ( PieceMgrMsg(..) , PieceMgrChannel diff --git a/src/Process/Tracker.hs b/src/Process/Tracker.hs --- a/src/Process/Tracker.hs +++ b/src/Process/Tracker.hs @@ -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 -> [] diff --git a/src/Torrent.hs b/src/Torrent.hs --- a/src/Torrent.hs +++ b/src/Torrent.hs @@ -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 ++ "-" diff --git a/src/Version.hs.in b/src/Version.hs.in --- a/src/Version.hs.in +++ b/src/Version.hs.in @@ -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@"