summaryrefslogtreecommitdiff
path: root/bittorrent/examples/MkTorrent.hs
diff options
context:
space:
mode:
Diffstat (limited to 'bittorrent/examples/MkTorrent.hs')
-rw-r--r--bittorrent/examples/MkTorrent.hs500
1 files changed, 0 insertions, 500 deletions
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 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE StandaloneDeriving #-}
5{-# OPTIONS -fno-warn-orphans #-}
6module Main (main) where
7
8import Prelude as P
9import Control.Concurrent
10import Control.Concurrent.Async.Lifted
11import Control.Concurrent.ParallelIO
12import Control.Exception
13import Control.Lens hiding (argument, (<.>))
14import Control.Monad as M
15import Control.Monad.Trans
16import Data.Conduit as C
17import Data.Conduit.List as C
18import Data.List as L
19import Data.Maybe as L
20import Data.Monoid
21import Data.Text as T
22import qualified Data.Text.IO as T
23import Data.Text.Read as T
24import Data.Version
25import Network
26import Network.URI
27import Options.Applicative
28import System.Exit
29import System.FilePath
30import System.Log
31import System.Log.Logger
32import Text.Read
33import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
34
35import Paths_bittorrent (version)
36import Data.Torrent hiding (Magnet (Magnet))
37import Network.Address
38import Network.BitTorrent.DHT.Session hiding (Options, options)
39import Network.BitTorrent.DHT as DHT hiding (Options)
40import Network.BitTorrent.Exchange.Bitfield as BF
41import Network.BitTorrent.Exchange.Connection hiding (Options)
42import Network.BitTorrent.Exchange.Message
43import Network.BitTorrent.Exchange.Session
44import System.Torrent.Storage
45
46#if MIN_VERSION_optparse_applicative(0,13,0)
47-- maybeReader imported from Options.Applicative.Builder
48#elif MIN_VERSION_optparse_applicative(0,11,0)
49maybeReader f = eitherReader (maybe (Left ":(") Right . f)
50#else
51maybeReader f = f
52#endif
53
54
55{-----------------------------------------------------------------------
56-- Dialogs
57-----------------------------------------------------------------------}
58
59instance Read URI where
60 readsPrec _ = f . parseURI
61 where
62 f Nothing = []
63 f (Just u) = [(u, "")]
64
65question :: Show a => Text -> Maybe a -> IO ()
66question q defVal = do
67 T.putStrLn q
68 case defVal of
69 Nothing -> return ()
70 Just v -> T.putStrLn $ "[default: " <> T.pack (show v) <> "]"
71
72ask :: Read a => Text -> IO a
73ask q = question q (Just True) >> getReply
74 where
75 getReply = do
76 resp <- P.getLine
77 maybe getReply return $ readMaybe resp
78
79askMaybe :: Read a => Text -> IO (Maybe a)
80askMaybe q = question q (Just False) >> getReply
81 where
82 getReply = do
83 resp <- P.getLine
84 if resp == []
85 then return Nothing
86 else maybe getReply return $ readMaybe resp
87
88askURI :: IO URI
89askURI = do
90 s <- P.getLine
91 case parseURI s of
92 Nothing -> T.putStrLn "incorrect URI" >> askURI
93 Just u -> return u
94
95askFreeform :: IO Text
96askFreeform = do
97 s <- T.getLine
98 if T.null s
99 then askFreeform
100 else return s
101
102askInRange :: Int -> Int -> IO Int
103askInRange a b = do
104 s <- T.getLine
105 case T.decimal s of
106 Left msg -> do
107 P.putStrLn msg
108 askInRange a b
109 Right (i, _)
110 | a <= i && i < b -> return i
111 | otherwise -> do
112 T.putStrLn "not in range "
113 askInRange a b
114
115askChoice :: [(Text, a)] -> IO a
116askChoice kvs = do
117 forM_ (L.zip [1 :: Int ..] $ L.map fst kvs) $ \(i, lbl) -> do
118 T.putStrLn $ " " <> T.pack (show i) <> ") " <> lbl
119 T.putStrLn "Your choice?"
120 n <- askInRange 1 (succ (L.length kvs))
121 return $ snd (kvs !! pred n)
122
123{-----------------------------------------------------------------------
124-- Helpers
125-----------------------------------------------------------------------}
126
127torrentFile :: Parser FilePath
128torrentFile = argument (maybeReader Just)
129 ( metavar "TORRENT_FILE_PATH"
130 <> help "A .torrent file"
131 )
132
133{-----------------------------------------------------------------------
134-- Amend command - edit a field of torrent file
135-----------------------------------------------------------------------}
136
137data AmendOpts = AmendOpts FilePath
138 deriving Show
139
140amendInfo :: ParserInfo AmendOpts
141amendInfo = info (helper <*> parser) modifier
142 where
143 modifier = progDesc "Edit info fields of existing torrent"
144 parser = AmendOpts <$> torrentFile
145
146type Amend = Torrent -> Torrent
147
148fields :: [(Text, IO Amend)]
149fields = [ ("announce", set announce . Just <$> askURI)
150 , ("comment", set comment . Just <$> askFreeform)
151 , ("created by", set createdBy . Just <$> askFreeform)
152 , ("publisher url", set publisherURL . Just <$> askURI)
153 ]
154
155askAmend :: IO Amend
156askAmend = join $ T.putStrLn "Choose a field:" >> askChoice fields
157
158amend :: AmendOpts -> IO ()
159amend (AmendOpts tpath) = do
160 t <- fromFile tpath
161 a <- askAmend
162 toFile tpath $ a t
163
164{-----------------------------------------------------------------------
165-- Check command -- validate content files using torrent file
166-----------------------------------------------------------------------}
167-- TODO progress bar
168
169data CheckOpts = CheckOpts
170 { checkTorrentPath :: FilePath -- ^ validation torrent file
171 , checkContentPath :: FilePath -- ^ root dir for content files
172 } deriving Show
173
174checkInfo :: ParserInfo CheckOpts
175checkInfo = info (helper <*> parser) modifier
176 where
177 modifier = progDesc "Validate integrity of torrent data"
178 <> header "append +RTS -N$NUMBER_OF_CORES -RTS for parallel execution"
179 parser = CheckOpts
180 <$> torrentFile
181 <*> argument (maybeReader Just)
182 ( metavar "CONTENT_DIR_PATH"
183 <> value "."
184 <> help "Content directory or a single file"
185 )
186
187validatePiece :: Storage -> PieceInfo -> PieceIx -> IO (Maybe PieceIx)
188validatePiece s pinfo pix = do
189 valid <- verifyPiece s pinfo pix
190 if valid
191 then do infoM "check" $ "valid piece " ++ show pix
192 return (Just pix)
193 else do infoM "check" $ "invalid piece " ++ show pix
194 return Nothing
195
196validateStorage :: Storage -> PieceInfo -> IO Bitfield
197validateStorage s pinfo = do
198 infoM "check" "start storage validation"
199 let total = totalPieces s
200 pixs <- parallel $ L.map (validatePiece s pinfo) [0 .. total - 1]
201 infoM "check" "storage validation finished"
202 return $ fromList total $ L.catMaybes pixs
203
204-- TODO use local thread pool
205checkContent :: Storage -> PieceInfo -> IO ()
206checkContent s pinfo = do
207 invalids <- BF.complement <$> validateStorage s pinfo
208 if BF.null invalids
209 then noticeM "check" "all files are complete and valid"
210 else do
211 emergencyM "check" $ "there are some invalid pieces" ++ show invalids
212 exitFailure
213
214checkTorrent :: CheckOpts -> IO ()
215checkTorrent CheckOpts {..} = do
216 infoM "check" "openning torrent file..."
217 InfoDict {..} <- tInfoDict <$> fromFile checkTorrentPath
218 let layout = flatLayout checkContentPath idLayoutInfo
219 infoM "check" "mapping content files..."
220 withStorage ReadOnly (piPieceLength idPieceInfo) layout $ \ s -> do
221 infoM "check" "files mapped"
222 checkContent s idPieceInfo
223 infoM "check" "unmapping files"
224
225{-----------------------------------------------------------------------
226-- Create command
227-----------------------------------------------------------------------}
228-- TODO progress bar
229-- TODO multifile torrents
230-- TODO interactive mode
231-- TODO non interactive mode
232-- TODO --ignore-dot-files
233-- TODO --md5
234-- TODO --piece-size
235
236{-
237createFlags :: Parser CreateFlags
238createFlags = CreateFlags
239 <$> optional (option
240 ( long "piece-size"
241 <> short 's'
242 <> metavar "SIZE"
243 <> help "Set size of torrent pieces"
244 ))
245 <*> switch
246 ( long "md5"
247 <> short '5'
248 <> help "Include md5 hash of each file"
249 )
250 <*> switch
251 ( long "ignore-dot-files"
252 <> short 'd'
253 <> help "Do not include .* files"
254 )
255
256
257createOpts :: Parser CreateOpts
258createOpts = CreateOpts
259 <$> argument (maybeReader Just)
260 ( metavar "PATH"
261 <> help "Content directory or a single file"
262 )
263 <*> optional (argument (maybeReader Just)
264 ( metavar "FILE"
265 <> help "Place for the output .torrent file"
266 ))
267 <*> createFlags
268
269createInfo :: ParserInfo CreateOpts
270createInfo = info (helper <*> createOpts) modifier
271 where
272 modifier = progDesc "Make a new .torrent file"
273-}
274
275{-----------------------------------------------------------------------
276-- Magnet command -- print magnet link for given torrent file
277-----------------------------------------------------------------------}
278
279data MagnetOpts = MagnetOpts
280 { magnetFile :: FilePath -- ^ path to torrent file
281 , detailed :: Bool -- ^ whether to append additional uri params
282 } deriving Show
283
284magnetInfo :: ParserInfo MagnetOpts
285magnetInfo = info (helper <*> parser) modifier
286 where
287 modifier = progDesc "Print magnet link"
288 parser = MagnetOpts
289 <$> torrentFile
290 <*> switch ( long "detailed" )
291
292magnet :: MagnetOpts -> IO ()
293magnet MagnetOpts {..} = print . magnetLink =<< fromFile magnetFile
294 where
295 magnetLink = if detailed then detailedMagnet else simpleMagnet
296
297{-----------------------------------------------------------------------
298-- Show command - print torrent file information
299-----------------------------------------------------------------------}
300
301data ShowOpts = ShowOpts
302 { showPath :: FilePath -- ^ torrent file to inspect;
303 , infoHashOnly :: Bool -- ^ omit everything except infohash.
304 } deriving Show
305
306showInfo :: ParserInfo ShowOpts
307showInfo = info (helper <*> parser) modifier
308 where
309 modifier = progDesc "Print .torrent file metadata"
310 parser = ShowOpts
311 <$> torrentFile
312 <*> switch
313 ( long "infohash"
314 <> help "Show only hash of the torrent info part"
315 )
316
317showTorrent :: ShowOpts -> Torrent -> ShowS
318showTorrent ShowOpts {..} torrent
319 | infoHashOnly = shows $ idInfoHash (tInfoDict torrent)
320 | otherwise = shows $ pPrint torrent
321
322putTorrent :: ShowOpts -> IO ()
323putTorrent opts @ ShowOpts {..} = do
324 torrent <- fromFile showPath `onException` putStrLn msg
325 putStrLn $ showTorrent opts torrent []
326 where
327 msg = "Torrent file is either invalid or do not exist"
328
329{-----------------------------------------------------------------------
330-- Get command - fetch torrent by infohash
331-----------------------------------------------------------------------}
332
333data GetOpts = GetOpts
334 { topic :: InfoHash
335 , servPort :: PortNumber
336 , bootNode :: NodeAddr IPv4
337 , buckets :: Int
338 } deriving Show
339
340#if !MIN_VERSION_network(2,6,3)
341instance Read PortNumber where
342 readsPrec i s = [ (toEnum a, t) | (a, t) <- readsPrec i s]
343#endif
344
345paramsParser :: Parser GetOpts
346paramsParser = GetOpts
347 <$> argument (maybeReader readMaybe)
348 (metavar "SHA1" <> help "infohash of torrent file")
349 <*> option auto (long "port" <> short 'p'
350 <> value 7000 <> showDefault
351 <> metavar "NUM" <> help "port number to bind"
352 )
353 <*> option auto (long "boot" <> short 'b'
354 <> metavar "NODE" <> help "bootstrap node address"
355 )
356 <*> option auto (long "bucket" <> short 'n'
357 <> value 2 <> showDefault
358 <> metavar "NUM" <> help "number of buckets to maintain"
359 )
360
361getInfo :: ParserInfo GetOpts
362getInfo = info (helper <*> paramsParser)
363 ( fullDesc
364 <> progDesc "Get torrent file by infohash"
365 <> header "get torrent file by infohash"
366 )
367
368 -- TODO add tNodes, tCreated, etc?
369getTorrent :: GetOpts -> IO ()
370getTorrent GetOpts {..} = do
371 infoM "get" "searching for peers..."
372 s <- newSession (\ _ _ _ _ -> return ()) (PeerAddr Nothing Nothing 7000) "/tmp" (Left topic)
373 dht (def { optBucketCount = buckets }) (NodeAddr "0.0.0.0" servPort) $ do
374 bootstrap [bootNode]
375 infodict <- withAsync (DHT.lookup topic $$ connectSink s)
376 (const (liftIO $ waitMetadata s))
377 liftIO $ toFile (show topic <.> torrentExt) $ nullTorrent infodict
378 infoM "get" "saved torrent file"
379
380{-----------------------------------------------------------------------
381-- Command
382-----------------------------------------------------------------------}
383
384data Command
385 = Amend AmendOpts
386 | Check CheckOpts
387-- | Create CreateOpts
388 | Get GetOpts
389 | Magnet MagnetOpts
390 | Show ShowOpts
391 deriving Show
392
393commandOpts :: Parser Command
394commandOpts = subparser $ mconcat
395 [ command "amend" (Amend <$> amendInfo)
396 , command "check" (Check <$> checkInfo)
397-- , command "create" (Create <$> createInfo)
398 , command "get" (Get <$> getInfo)
399 , command "magnet" (Magnet <$> magnetInfo)
400 , command "show" (Show <$> showInfo)
401 ]
402
403{-----------------------------------------------------------------------
404-- Global Options
405-----------------------------------------------------------------------}
406
407data GlobalOpts = GlobalOpts
408 { verbosity :: Priority
409 } deriving Show
410
411#if !MIN_VERSION_hslogger(1,2,9)
412deriving instance Enum Priority
413deriving instance Bounded Priority
414#endif
415
416priorities :: [Priority]
417priorities = [minBound..maxBound]
418
419defaultPriority :: Priority
420defaultPriority = WARNING
421
422verbosityOpts :: Parser Priority
423verbosityOpts = verbosityP <|> verboseP <|> quietP
424 where
425 verbosityP = option auto
426 ( long "verbosity"
427 <> metavar "LEVEL"
428 <> help ("Set verbosity level\n"
429 ++ "Possible values are " ++ show priorities)
430 )
431
432 verboseP = flag defaultPriority INFO
433 ( long "verbose"
434 <> short 'v'
435 <> help "Verbose mode"
436 )
437
438 quietP = flag defaultPriority CRITICAL
439 ( long "quiet"
440 <> short 'q'
441 <> help "Silent mode"
442 )
443
444
445globalOpts :: Parser GlobalOpts
446globalOpts = GlobalOpts <$> verbosityOpts
447
448data Options = Options
449 { cmdOpts :: Command
450 , globOpts :: GlobalOpts
451 } deriving Show
452
453options :: Parser Options
454options = Options <$> commandOpts <*> globalOpts
455
456versioner :: String -> Version -> Parser (a -> a)
457#if MIN_VERSION_optparse_applicative(0,10,0)
458versioner prog ver = nullOption disabled $ mconcat
459#else
460versioner prog ver = nullOption $ mconcat
461#endif
462 [ long "version"
463 , help "Show program version and exit"
464 , value id
465 , metavar ""
466 , hidden
467 , mempty -- reader $ const $ undefined -- Left $ ErrorMsg versionStr
468 ]
469 where
470 versionStr = prog ++ " version " ++ showVersion ver
471
472parserInfo :: ParserInfo Options
473parserInfo = info parser modifier
474 where
475 parser = helper <*> versioner "mktorrent" version <*> options
476 modifier = header synopsis <> progDesc description <> fullDesc
477 synopsis = "Torrent management utility"
478 description = "" -- TODO
479
480{-----------------------------------------------------------------------
481-- Dispatch
482-----------------------------------------------------------------------}
483
484run :: Command -> IO ()
485run (Amend opts) = amend opts
486run (Check opts) = checkTorrent opts
487--run (Create opts) = createTorrent opts
488run (Get opts) = getTorrent opts
489run (Magnet opts) = magnet opts
490run (Show opts) = putTorrent opts
491
492prepare :: GlobalOpts -> IO ()
493prepare GlobalOpts {..} = do
494 updateGlobalLogger rootLoggerName (setLevel verbosity)
495
496main :: IO ()
497main = do
498 Options {..} <- execParser parserInfo
499 prepare globOpts
500 run cmdOpts
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 13:44:19 +0000