From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- bittorrent/examples/Client.hs | 74 ------ bittorrent/examples/FS.hs | 74 ------ bittorrent/examples/MkTorrent.hs | 500 --------------------------------------- 3 files changed, 648 deletions(-) delete mode 100644 bittorrent/examples/Client.hs delete mode 100644 bittorrent/examples/FS.hs delete mode 100644 bittorrent/examples/MkTorrent.hs (limited to 'bittorrent/examples') diff --git a/bittorrent/examples/Client.hs b/bittorrent/examples/Client.hs deleted file mode 100644 index 26711676..00000000 --- a/bittorrent/examples/Client.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} -module Main (main) where -import Control.Concurrent -import Control.Monad.Trans -import Data.Maybe -import Options.Applicative -import System.Environment -import System.Exit -import System.IO -import Text.Read - -import Network.BitTorrent - -#if MIN_VERSION_optparse_applicative(0,13,0) --- maybeReader imported from Options.Applicative.Builder -#elif MIN_VERSION_optparse_applicative(0,11,0) -maybeReader f = eitherReader (maybe (Left ":(") Right . f) -#else -maybeReader f = f -#endif - -{----------------------------------------------------------------------- --- Command line arguments ------------------------------------------------------------------------} - -data TorrentBox = forall s. TorrentSource s => TorrentBox { unTorrentBox :: s } - -data Args = Args - { topic :: TorrentBox - , contentDir :: FilePath - } - -argsParser :: Parser Args -argsParser = Args <$> (TorrentBox <$> infohashP <|> TorrentBox <$> torrentP) - <*> destDirP - where - infohashP :: Parser InfoHash - infohashP = argument (maybeReader readMaybe) - (metavar "SHA1" <> help "infohash of torrent file") - - torrentP :: Parser FilePath - torrentP = argument (maybeReader Just) - ( metavar "FILE" - <> help "A .torrent file" - ) - - destDirP :: Parser FilePath - destDirP = argument (maybeReader Just) - ( metavar "DIR" - <> help "Directory to put content" - ) - -argsInfo :: ParserInfo Args -argsInfo = info (helper <*> argsParser) - ( fullDesc - <> progDesc "A simple CLI bittorrent client" - <> header "foo" - ) - -{----------------------------------------------------------------------- --- Client ------------------------------------------------------------------------} - -run :: Args -> BitTorrent () -run (Args (TorrentBox t) dir) = do - h <- openHandle dir t - start h - liftIO $ threadDelay 10000000000 - -main :: IO () -main = execParser argsInfo >>= simpleClient . run diff --git a/bittorrent/examples/FS.hs b/bittorrent/examples/FS.hs deleted file mode 100644 index 550d85a7..00000000 --- a/bittorrent/examples/FS.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Main (main) where - -import Control.Arrow -import Data.ByteString.Char8 as BC -import Data.List as L -import Data.Map as M -import Data.Torrent as T -import Data.Torrent.Tree as T -import System.Environment -import System.Fuse -import System.FilePath -import System.Posix.Files - - -defStat :: FileStat -defStat = FileStat - { statEntryType = Unknown - , statFileMode = ownerReadMode - , statLinkCount = 2 - - , statFileOwner = 0 - , statFileGroup = 0 - - , statSpecialDeviceID = 0 - - , statFileSize = 0 - , statBlocks = 0 - - , statAccessTime = 0 - , statModificationTime = 0 - , statStatusChangeTime = 0 - } - -dirStat :: FileStat -dirStat = defStat { - statEntryType = Directory - } - -type Result a = IO (Either Errno a) -type Result' = IO Errno - -fsGetFileStat :: Torrent -> FilePath -> Result FileStat -fsGetFileStat _ path = return $ Right dirStat - -fsOpenDirectory :: Torrent -> FilePath -> Result' -fsOpenDirectory _ _ = return eOK - -fsReadDirectory :: Torrent -> FilePath -> Result [(FilePath, FileStat)] -fsReadDirectory Torrent {tInfoDict = InfoDict {..}} path - | Just cs <- T.lookupDir (L.tail (splitDirectories path)) tree = - return $ Right $ L.map (BC.unpack *** const defStat) cs - | otherwise = return $ Left eNOENT - where - tree = build $ idLayoutInfo - -fsReleaseDirectory :: Torrent -> FilePath -> Result' -fsReleaseDirectory _ _ = return eOK - -exfsOps :: Torrent -> FuseOperations () -exfsOps t = defaultFuseOps - { fuseGetFileStat = fsGetFileStat t - - , fuseOpenDirectory = fsOpenDirectory t - , fuseReadDirectory = fsReadDirectory t - , fuseReleaseDirectory = fsReleaseDirectory t - } - -main :: IO () -main = do - x : xs <- getArgs - t <- fromFile x - withArgs xs $ do - fuseMain (exfsOps t) defaultExceptionHandler \ No newline at end of file diff --git a/bittorrent/examples/MkTorrent.hs b/bittorrent/examples/MkTorrent.hs deleted file mode 100644 index 88a84893..00000000 --- a/bittorrent/examples/MkTorrent.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS -fno-warn-orphans #-} -module Main (main) where - -import Prelude as P -import Control.Concurrent -import Control.Concurrent.Async.Lifted -import Control.Concurrent.ParallelIO -import Control.Exception -import Control.Lens hiding (argument, (<.>)) -import Control.Monad as M -import Control.Monad.Trans -import Data.Conduit as C -import Data.Conduit.List as C -import Data.List as L -import Data.Maybe as L -import Data.Monoid -import Data.Text as T -import qualified Data.Text.IO as T -import Data.Text.Read as T -import Data.Version -import Network -import Network.URI -import Options.Applicative -import System.Exit -import System.FilePath -import System.Log -import System.Log.Logger -import Text.Read -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) - -import Paths_bittorrent (version) -import Data.Torrent hiding (Magnet (Magnet)) -import Network.Address -import Network.BitTorrent.DHT.Session hiding (Options, options) -import Network.BitTorrent.DHT as DHT hiding (Options) -import Network.BitTorrent.Exchange.Bitfield as BF -import Network.BitTorrent.Exchange.Connection hiding (Options) -import Network.BitTorrent.Exchange.Message -import Network.BitTorrent.Exchange.Session -import System.Torrent.Storage - -#if MIN_VERSION_optparse_applicative(0,13,0) --- maybeReader imported from Options.Applicative.Builder -#elif MIN_VERSION_optparse_applicative(0,11,0) -maybeReader f = eitherReader (maybe (Left ":(") Right . f) -#else -maybeReader f = f -#endif - - -{----------------------------------------------------------------------- --- Dialogs ------------------------------------------------------------------------} - -instance Read URI where - readsPrec _ = f . parseURI - where - f Nothing = [] - f (Just u) = [(u, "")] - -question :: Show a => Text -> Maybe a -> IO () -question q defVal = do - T.putStrLn q - case defVal of - Nothing -> return () - Just v -> T.putStrLn $ "[default: " <> T.pack (show v) <> "]" - -ask :: Read a => Text -> IO a -ask q = question q (Just True) >> getReply - where - getReply = do - resp <- P.getLine - maybe getReply return $ readMaybe resp - -askMaybe :: Read a => Text -> IO (Maybe a) -askMaybe q = question q (Just False) >> getReply - where - getReply = do - resp <- P.getLine - if resp == [] - then return Nothing - else maybe getReply return $ readMaybe resp - -askURI :: IO URI -askURI = do - s <- P.getLine - case parseURI s of - Nothing -> T.putStrLn "incorrect URI" >> askURI - Just u -> return u - -askFreeform :: IO Text -askFreeform = do - s <- T.getLine - if T.null s - then askFreeform - else return s - -askInRange :: Int -> Int -> IO Int -askInRange a b = do - s <- T.getLine - case T.decimal s of - Left msg -> do - P.putStrLn msg - askInRange a b - Right (i, _) - | a <= i && i < b -> return i - | otherwise -> do - T.putStrLn "not in range " - askInRange a b - -askChoice :: [(Text, a)] -> IO a -askChoice kvs = do - forM_ (L.zip [1 :: Int ..] $ L.map fst kvs) $ \(i, lbl) -> do - T.putStrLn $ " " <> T.pack (show i) <> ") " <> lbl - T.putStrLn "Your choice?" - n <- askInRange 1 (succ (L.length kvs)) - return $ snd (kvs !! pred n) - -{----------------------------------------------------------------------- --- Helpers ------------------------------------------------------------------------} - -torrentFile :: Parser FilePath -torrentFile = argument (maybeReader Just) - ( metavar "TORRENT_FILE_PATH" - <> help "A .torrent file" - ) - -{----------------------------------------------------------------------- --- Amend command - edit a field of torrent file ------------------------------------------------------------------------} - -data AmendOpts = AmendOpts FilePath - deriving Show - -amendInfo :: ParserInfo AmendOpts -amendInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Edit info fields of existing torrent" - parser = AmendOpts <$> torrentFile - -type Amend = Torrent -> Torrent - -fields :: [(Text, IO Amend)] -fields = [ ("announce", set announce . Just <$> askURI) - , ("comment", set comment . Just <$> askFreeform) - , ("created by", set createdBy . Just <$> askFreeform) - , ("publisher url", set publisherURL . Just <$> askURI) - ] - -askAmend :: IO Amend -askAmend = join $ T.putStrLn "Choose a field:" >> askChoice fields - -amend :: AmendOpts -> IO () -amend (AmendOpts tpath) = do - t <- fromFile tpath - a <- askAmend - toFile tpath $ a t - -{----------------------------------------------------------------------- --- Check command -- validate content files using torrent file ------------------------------------------------------------------------} --- TODO progress bar - -data CheckOpts = CheckOpts - { checkTorrentPath :: FilePath -- ^ validation torrent file - , checkContentPath :: FilePath -- ^ root dir for content files - } deriving Show - -checkInfo :: ParserInfo CheckOpts -checkInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Validate integrity of torrent data" - <> header "append +RTS -N$NUMBER_OF_CORES -RTS for parallel execution" - parser = CheckOpts - <$> torrentFile - <*> argument (maybeReader Just) - ( metavar "CONTENT_DIR_PATH" - <> value "." - <> help "Content directory or a single file" - ) - -validatePiece :: Storage -> PieceInfo -> PieceIx -> IO (Maybe PieceIx) -validatePiece s pinfo pix = do - valid <- verifyPiece s pinfo pix - if valid - then do infoM "check" $ "valid piece " ++ show pix - return (Just pix) - else do infoM "check" $ "invalid piece " ++ show pix - return Nothing - -validateStorage :: Storage -> PieceInfo -> IO Bitfield -validateStorage s pinfo = do - infoM "check" "start storage validation" - let total = totalPieces s - pixs <- parallel $ L.map (validatePiece s pinfo) [0 .. total - 1] - infoM "check" "storage validation finished" - return $ fromList total $ L.catMaybes pixs - --- TODO use local thread pool -checkContent :: Storage -> PieceInfo -> IO () -checkContent s pinfo = do - invalids <- BF.complement <$> validateStorage s pinfo - if BF.null invalids - then noticeM "check" "all files are complete and valid" - else do - emergencyM "check" $ "there are some invalid pieces" ++ show invalids - exitFailure - -checkTorrent :: CheckOpts -> IO () -checkTorrent CheckOpts {..} = do - infoM "check" "openning torrent file..." - InfoDict {..} <- tInfoDict <$> fromFile checkTorrentPath - let layout = flatLayout checkContentPath idLayoutInfo - infoM "check" "mapping content files..." - withStorage ReadOnly (piPieceLength idPieceInfo) layout $ \ s -> do - infoM "check" "files mapped" - checkContent s idPieceInfo - infoM "check" "unmapping files" - -{----------------------------------------------------------------------- --- Create command ------------------------------------------------------------------------} --- TODO progress bar --- TODO multifile torrents --- TODO interactive mode --- TODO non interactive mode --- TODO --ignore-dot-files --- TODO --md5 --- TODO --piece-size - -{- -createFlags :: Parser CreateFlags -createFlags = CreateFlags - <$> optional (option - ( long "piece-size" - <> short 's' - <> metavar "SIZE" - <> help "Set size of torrent pieces" - )) - <*> switch - ( long "md5" - <> short '5' - <> help "Include md5 hash of each file" - ) - <*> switch - ( long "ignore-dot-files" - <> short 'd' - <> help "Do not include .* files" - ) - - -createOpts :: Parser CreateOpts -createOpts = CreateOpts - <$> argument (maybeReader Just) - ( metavar "PATH" - <> help "Content directory or a single file" - ) - <*> optional (argument (maybeReader Just) - ( metavar "FILE" - <> help "Place for the output .torrent file" - )) - <*> createFlags - -createInfo :: ParserInfo CreateOpts -createInfo = info (helper <*> createOpts) modifier - where - modifier = progDesc "Make a new .torrent file" --} - -{----------------------------------------------------------------------- --- Magnet command -- print magnet link for given torrent file ------------------------------------------------------------------------} - -data MagnetOpts = MagnetOpts - { magnetFile :: FilePath -- ^ path to torrent file - , detailed :: Bool -- ^ whether to append additional uri params - } deriving Show - -magnetInfo :: ParserInfo MagnetOpts -magnetInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Print magnet link" - parser = MagnetOpts - <$> torrentFile - <*> switch ( long "detailed" ) - -magnet :: MagnetOpts -> IO () -magnet MagnetOpts {..} = print . magnetLink =<< fromFile magnetFile - where - magnetLink = if detailed then detailedMagnet else simpleMagnet - -{----------------------------------------------------------------------- --- Show command - print torrent file information ------------------------------------------------------------------------} - -data ShowOpts = ShowOpts - { showPath :: FilePath -- ^ torrent file to inspect; - , infoHashOnly :: Bool -- ^ omit everything except infohash. - } deriving Show - -showInfo :: ParserInfo ShowOpts -showInfo = info (helper <*> parser) modifier - where - modifier = progDesc "Print .torrent file metadata" - parser = ShowOpts - <$> torrentFile - <*> switch - ( long "infohash" - <> help "Show only hash of the torrent info part" - ) - -showTorrent :: ShowOpts -> Torrent -> ShowS -showTorrent ShowOpts {..} torrent - | infoHashOnly = shows $ idInfoHash (tInfoDict torrent) - | otherwise = shows $ pPrint torrent - -putTorrent :: ShowOpts -> IO () -putTorrent opts @ ShowOpts {..} = do - torrent <- fromFile showPath `onException` putStrLn msg - putStrLn $ showTorrent opts torrent [] - where - msg = "Torrent file is either invalid or do not exist" - -{----------------------------------------------------------------------- --- Get command - fetch torrent by infohash ------------------------------------------------------------------------} - -data GetOpts = GetOpts - { topic :: InfoHash - , servPort :: PortNumber - , bootNode :: NodeAddr IPv4 - , buckets :: Int - } deriving Show - -#if !MIN_VERSION_network(2,6,3) -instance Read PortNumber where - readsPrec i s = [ (toEnum a, t) | (a, t) <- readsPrec i s] -#endif - -paramsParser :: Parser GetOpts -paramsParser = GetOpts - <$> argument (maybeReader readMaybe) - (metavar "SHA1" <> help "infohash of torrent file") - <*> option auto (long "port" <> short 'p' - <> value 7000 <> showDefault - <> metavar "NUM" <> help "port number to bind" - ) - <*> option auto (long "boot" <> short 'b' - <> metavar "NODE" <> help "bootstrap node address" - ) - <*> option auto (long "bucket" <> short 'n' - <> value 2 <> showDefault - <> metavar "NUM" <> help "number of buckets to maintain" - ) - -getInfo :: ParserInfo GetOpts -getInfo = info (helper <*> paramsParser) - ( fullDesc - <> progDesc "Get torrent file by infohash" - <> header "get torrent file by infohash" - ) - - -- TODO add tNodes, tCreated, etc? -getTorrent :: GetOpts -> IO () -getTorrent GetOpts {..} = do - infoM "get" "searching for peers..." - s <- newSession (\ _ _ _ _ -> return ()) (PeerAddr Nothing Nothing 7000) "/tmp" (Left topic) - dht (def { optBucketCount = buckets }) (NodeAddr "0.0.0.0" servPort) $ do - bootstrap [bootNode] - infodict <- withAsync (DHT.lookup topic $$ connectSink s) - (const (liftIO $ waitMetadata s)) - liftIO $ toFile (show topic <.> torrentExt) $ nullTorrent infodict - infoM "get" "saved torrent file" - -{----------------------------------------------------------------------- --- Command ------------------------------------------------------------------------} - -data Command - = Amend AmendOpts - | Check CheckOpts --- | Create CreateOpts - | Get GetOpts - | Magnet MagnetOpts - | Show ShowOpts - deriving Show - -commandOpts :: Parser Command -commandOpts = subparser $ mconcat - [ command "amend" (Amend <$> amendInfo) - , command "check" (Check <$> checkInfo) --- , command "create" (Create <$> createInfo) - , command "get" (Get <$> getInfo) - , command "magnet" (Magnet <$> magnetInfo) - , command "show" (Show <$> showInfo) - ] - -{----------------------------------------------------------------------- --- Global Options ------------------------------------------------------------------------} - -data GlobalOpts = GlobalOpts - { verbosity :: Priority - } deriving Show - -#if !MIN_VERSION_hslogger(1,2,9) -deriving instance Enum Priority -deriving instance Bounded Priority -#endif - -priorities :: [Priority] -priorities = [minBound..maxBound] - -defaultPriority :: Priority -defaultPriority = WARNING - -verbosityOpts :: Parser Priority -verbosityOpts = verbosityP <|> verboseP <|> quietP - where - verbosityP = option auto - ( long "verbosity" - <> metavar "LEVEL" - <> help ("Set verbosity level\n" - ++ "Possible values are " ++ show priorities) - ) - - verboseP = flag defaultPriority INFO - ( long "verbose" - <> short 'v' - <> help "Verbose mode" - ) - - quietP = flag defaultPriority CRITICAL - ( long "quiet" - <> short 'q' - <> help "Silent mode" - ) - - -globalOpts :: Parser GlobalOpts -globalOpts = GlobalOpts <$> verbosityOpts - -data Options = Options - { cmdOpts :: Command - , globOpts :: GlobalOpts - } deriving Show - -options :: Parser Options -options = Options <$> commandOpts <*> globalOpts - -versioner :: String -> Version -> Parser (a -> a) -#if MIN_VERSION_optparse_applicative(0,10,0) -versioner prog ver = nullOption disabled $ mconcat -#else -versioner prog ver = nullOption $ mconcat -#endif - [ long "version" - , help "Show program version and exit" - , value id - , metavar "" - , hidden - , mempty -- reader $ const $ undefined -- Left $ ErrorMsg versionStr - ] - where - versionStr = prog ++ " version " ++ showVersion ver - -parserInfo :: ParserInfo Options -parserInfo = info parser modifier - where - parser = helper <*> versioner "mktorrent" version <*> options - modifier = header synopsis <> progDesc description <> fullDesc - synopsis = "Torrent management utility" - description = "" -- TODO - -{----------------------------------------------------------------------- --- Dispatch ------------------------------------------------------------------------} - -run :: Command -> IO () -run (Amend opts) = amend opts -run (Check opts) = checkTorrent opts ---run (Create opts) = createTorrent opts -run (Get opts) = getTorrent opts -run (Magnet opts) = magnet opts -run (Show opts) = putTorrent opts - -prepare :: GlobalOpts -> IO () -prepare GlobalOpts {..} = do - updateGlobalLogger rootLoggerName (setLevel verbosity) - -main :: IO () -main = do - Options {..} <- execParser parserInfo - prepare globOpts - run cmdOpts -- cgit v1.2.3