xdcc (empty) → 1.0.0
raw patch · 7 files changed
+509/−0 lines, 7 filesdep +ascii-progressdep +basedep +bytestringsetup-changed
Dependencies added: ascii-progress, base, bytestring, case-insensitive, concurrent-extra, concurrent-output, errors, iproute, irc-ctcp, irc-dcc, network, optparse-applicative, path, random, simpleirc, transformers, unix
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- src/Dcc.hs +99/−0
- src/Irc.hs +142/−0
- src/Main.hs +157/−0
- src/Xdcc.hs +42/−0
- xdcc.cabal +46/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Jan Gerlinger <git@jangerlinger.de>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Dcc.hs view
@@ -0,0 +1,99 @@+module Dcc ( module Irc+ , module Network.IRC.DCC+ , DccIO+ , DccEnv(..)+ , FileMetadata (..)+ , canResume+ , resumeFile+ , acceptFile+ , offerSink+ ) where++import Irc++import Control.Concurrent.Broadcast (Broadcast, broadcast)+import Control.Error+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask)+import Data.ByteString.Char8 (ByteString)+import Data.IP (IPv4)+import Network.IRC.CTCP (getUnderlyingByteString)+import Network.IRC.DCC+import Network.IRC.DCC.FileTransfer+import Network.Socket (PortNumber)+import Path (fromRelFile)+import Prelude hiding (length, null)+import System.Console.Concurrent (outputConcurrent)+import System.Posix.Files (fileExist, getFileStatus,+ isRegularFile)+import qualified System.Posix.Files as Files (fileSize)++type DccIO = ReaderT DccEnv IrcIO++data DccEnv = DccEnv { connection :: Connection+ , remoteNick :: Nickname+ , publicIp :: Maybe IPv4 }++sendResumeRequest :: OfferFile -> FileOffset -> DccIO FileOffset+sendResumeRequest (OfferFile tt f) pos =+ let tryResume = TryResumeFile tt f pos in+ do env <- ask+ lift $ sendAndWaitForAck (connection env)+ (remoteNick env)+ (asByteString tryResume)+ (onResumeAccepted tryResume)+ "Timeout when waiting for resume"++onResumeAccepted :: TryResumeFile -> Nickname -> Broadcast FileOffset+ -> EventFunc+onResumeAccepted t rNick resumeAccepted _ =+ onCtcpMessage (from rNick) (\ msg ->+ case runParser (parseAcceptResumeFile t) msg of+ Right (AcceptResumeFile _ _ pos) -> broadcast resumeAccepted pos+ Left e -> outputConcurrent e )++canResume :: OfferFile -> DccIO (Maybe FileOffset)+canResume o@(OfferFile _ (FileMetadata fn fs)) =+ do curSize <- liftIO $ getFileSizeSafe (fromRelFile fn)+ case (curSize, fs) of+ (Just s, Just fs')+ | s < fs' -> do+ liftIO $ outputConcurrent+ ("Resumable file found with size " ++ show s ++ ".\n")+ Just <$> sendResumeRequest o s+ | otherwise ->+ lift $ throwE "File already exists and seems complete."+ (Just _, Nothing) ->+ lift $ throwE "File already exists. Resuming not supported."+ (Nothing, _) ->+ do liftIO $ outputConcurrent+ "No resumable file found, starting from zero.\n"+ return Nothing++getFileSizeSafe :: FilePath -> IO (Maybe FileOffset)+getFileSizeSafe file =+ do exists <- fileExist file+ if exists+ then do stats <- getFileStatus file+ if isRegularFile stats+ then return $ Just (fromIntegral (Files.fileSize stats))+ else return Nothing+ else return Nothing++offerSink :: DccEnv -> OfferFile -> PortNumber -> IrcIO ()+offerSink env (OfferFile (Passive _ t) f) p =+ case publicIp env of+ Just i -> lift $ send (connection env)+ (remoteNick env)+ (asByteString (OfferFileSink t f i p))+ Nothing -> throwE ( "Passive connections are only supported, if you "+ ++ "provide your external IP address on the command "+ ++ "line using the '--publicIp' option. You could "+ ++ "also try something like: "+ ++ "'--publicIP `curl -s https://4.ifcfg.me`'." )+-- Only passive connections can offer a sink to connect to+offerSink _ _ _ = lift $ return ()++asByteString :: CtcpCommand a => a -> ByteString+asByteString = getUnderlyingByteString . encodeCtcp
+ src/Irc.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Irc ( IrcIO+ , Connection+ , Network+ , Nickname+ , Channel+ , Pack+ , EventFunc+ , connectTo+ , sendAndWaitForAck+ , send+ , disconnectFrom+ , onMessage+ , onCtcpMessage+ , from+ , and+ , msgHasPrefix+ , logMsg+ ) where++import Control.Concurrent.Broadcast (Broadcast, broadcast)+import qualified Control.Concurrent.Broadcast as Broadcast (listenTimeout, new)+import Control.Error+import Control.Monad (replicateM, when)+import Control.Monad.Trans.Class (lift)+import Data.ByteString.Char8 hiding (length, map, zip)+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.Monoid ((<>))+import Network.IRC.CTCP (CTCPByteString, asCTCP)+import Prelude hiding (and)+import System.Console.Concurrent (outputConcurrent)+import System.IO.Error (ioeGetErrorString)++import Network.SimpleIRC++type Network = String+type Nickname = String+type Channel = CI String+type Pack = Int+type Connection = MIrc++type IrcIO = ExceptT String IO++config :: Network -> Nickname -> [(Channel, Broadcast ())] -> IrcConfig+config network nick chansWithBroadcasts = (mkDefaultConfig network nick)+ { cChannels = map (CI.original . fst) chansWithBroadcasts+ , cEvents = map asOnJoinEvent chansWithBroadcasts }+ where asOnJoinEvent (chan, b) = Join (onJoin chan b)++connectTo :: Network -> Nickname -> [Channel] -> Bool -> IO () -> IO ()+ -> IrcIO Connection+connectTo network nick chans withDebug onConnected onJoined =+ do bcs <- lift $ replicateM (length chans) Broadcast.new+ con <- connect' (config' bcs) withDebug+ lift onConnected+ joined <- lift $ waitForAll bcs+ case sequence joined of+ Just _ -> do lift onJoined+ return con+ Nothing -> throwE "Timeout when waiting on joining all channels."+ where config' bcs = config network nick (chans `zip` bcs)++connect' :: IrcConfig -> Bool -> IrcIO Connection+connect' conf withDebug =+ do con <- lift $ hoistEither <$> connect conf True withDebug+ catchE con (throwE . ioeGetErrorString)++waitForAll :: [Broadcast ()] -> IO [Maybe ()]+waitForAll = mapM (`Broadcast.listenTimeout` 30000000)++sendAndWaitForAck :: Connection+ -> Nickname+ -> ByteString+ -> (Nickname -> Broadcast b -> EventFunc)+ -> String+ -> IrcIO b+sendAndWaitForAck con rNick cmd broadCastIfMsg errMsg =+ do bc <- lift Broadcast.new+ v <- lift $ do changeEvents con+ [ Privmsg (broadCastIfMsg rNick bc)+ , Notice logMsg ]+ send con rNick cmd+ v <- Broadcast.listenTimeout bc 30000000+ changeEvents con [ Notice logMsg ]+ return v+ failWith errMsg v++send :: Connection -> Nickname -> ByteString -> IO ()+send con rNick msg =+ do sendCmd con command+ outputConcurrent (show command ++ "\n")+ where command = MPrivmsg (pack rNick) msg++disconnectFrom :: Connection -> IO ()+disconnectFrom = flip disconnect "bye"++onJoin :: Channel -> Broadcast () -> EventFunc+onJoin channel notifyJoined con ircMessage =+ do curNick <- getNickname con+ onMessage (for curNick `and` msgEqCi channel) (\_ ->+ broadcast notifyJoined ()) ircMessage++logMsg :: EventFunc+logMsg _ IrcMessage { mOrigin = Just origin, mCode, mMsg } =+ outputConcurrentBs (mCode <> " " <> origin <>": " <> mMsg <> "\n")+logMsg _ IrcMessage { mCode, mMsg } =+ outputConcurrentBs (mCode <> ": " <> mMsg <> "\n")++outputConcurrentBs :: ByteString -> IO ()+outputConcurrentBs = outputConcurrent . unpack++onMessage :: (a -> Bool)+ -> (a -> IO ())+ -> a+ -> IO ()+onMessage p f x = when (p x) $ f x++onCtcpMessage :: (IrcMessage -> Bool)+ -> (CTCPByteString -> IO ())+ -> IrcMessage+ -> IO ()+onCtcpMessage p f = onMessage p (sequence_ . fmap f . asCTCP . mMsg)++for :: ByteString -> IrcMessage -> Bool+for nick IrcMessage { mNick = Just recipient } = nick == recipient+for _ _ = False++from :: Nickname -> IrcMessage -> Bool+from rNick IrcMessage { mOrigin = Just origin } = pack rNick == origin+from _ _ = False++msgEqCi :: CI String -> IrcMessage -> Bool+msgEqCi msg IrcMessage { mMsg } = msg == CI.mk (unpack mMsg)++msgHasPrefix :: ByteString -> IrcMessage -> Bool+msgHasPrefix prefix IrcMessage { mMsg } = prefix `isPrefixOf` mMsg++and :: (a -> Bool) -> (a -> Bool) -> a -> Bool+and f g x = f x && g x
+ src/Main.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import Irc+import Xdcc++import Control.Error+import Control.Monad (replicateM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask, runReaderT)+import qualified Data.CaseInsensitive as CI (mk)+import Data.IP (IPv4)+import Options.Applicative+import Path (fromRelFile)+import System.Console.AsciiProgress hiding (Options)+import System.Console.Concurrent (outputConcurrent,+ withConcurrentOutput)+import System.Random (randomRIO)++data Options = Options { network :: Network+ , mainChannel :: Channel+ , rNick :: Nickname+ , pack :: Pack+ , nick :: Nickname+ , additionalChannels :: [Channel]+ , publicIp :: Maybe IPv4+ , verbose :: Bool }+ deriving (Show)++options :: String -> ParserInfo Options+options defaultNick = info ( helper <*> opts )+ ( fullDesc+ <> header "xdcc - an XDCC file downloader"+ <> progDesc ( "A wget-like utility for retrieving "+ ++ "files from XDCC bots on IRC" ))+ where opts = Options+ <$> strArgument+ ( metavar "HOST"+ <> help "Host address of the IRC network" )+ <*> ( CI.mk <$> strArgument+ ( metavar "CHANNEL"+ <> help "Main channel to join on network" ))+ <*> strArgument+ ( metavar "USER"+ <> help "Nickname of the user or bot to download from" )+ <*> argument auto+ ( metavar "#PACK"+ <> help "Pack number of the file to download" )+ <*> strOption+ ( long "nickname"+ <> short 'n'+ <> metavar "NAME"+ <> value defaultNick+ <> help "Nickname to use for the IRC connection" )+ <*> many ( CI.mk <$> strOption+ ( long "join"+ <> short 'j'+ <> metavar "CHANNEL" ))+ <*> optional ( option auto+ ( long "publicIp"+ <> short 'i'+ <> metavar "IP"+ <> help ( "IPv4 address where you are reachable (only needed for "+ ++ "Reverse DCC support)." )))+ <*> switch+ ( long "verbose"+ <> short 'v'+ <> help "Enable verbose mode: verbosity level \"debug\"" )++main :: IO ()+main = withConcurrentOutput . displayConsoleRegions $+ do defaultNick <- randomNick+ opts <- execParser $ options defaultNick+ result <- runExceptT $ runWith opts+ case result of+ Left e -> outputConcurrent ("FAILURE xdcc: " ++ e ++ "\n")+ Right _ -> return ()++randomNick :: IO String+randomNick = replicateM 10 $ randomRIO ('a', 'z')++runWith :: Options -> ExceptT String IO ()+runWith opts = withIrcConnection opts . withDccEnv opts $+ runReaderT $ do o <- request (pack opts)+ pos <- canResume o+ case pos of+ Just p -> resume o p+ Nothing -> download o++withIrcConnection :: Options -> (Connection -> ExceptT String IO a)+ -> ExceptT String IO a+withIrcConnection Options {..} =+ bracket (connectAndJoin network nick channels verbose)+ (lift . disconnectFrom)+ where channels = mainChannel : additionalChannels++withDccEnv :: Options -> (DccEnv -> a) -> Connection -> a+withDccEnv Options {..} f con = f DccEnv { connection = con+ , publicIp = publicIp+ , remoteNick = rNick }++connectAndJoin :: Network -> Nickname -> [Channel] -> Bool+ -> ExceptT String IO Connection+connectAndJoin network nick chans withDebug = do+ lift $+ outputConcurrent $ "Connecting to " ++ network ++ " as " ++ nick ++ "… "+ connectTo network nick chans withDebug+ (outputConcurrent "Connected.\n")+ (outputConcurrent $ "Joined " ++ show chans ++ ".\n")++download :: OfferFile -> DccIO ()+download o@(OfferFile _ f) = do+ env <- ask+ lift $ withProgressBar f 0 $+ acceptFile o (offerSink env o)++resume :: OfferFile -> FileOffset -> DccIO ()+resume o@(OfferFile tt f) pos = do+ env <- ask+ lift $ withProgressBar f pos $+ resumeFile (AcceptResumeFile tt f pos) (offerSink env o)++withProgressBar :: FileMetadata+ -> FileOffset+ -> ((FileOffset -> IO ()) -> ExceptT String IO ())+ -> ExceptT String IO ()+withProgressBar file pos f = do+ progressBar <- liftIO $ newProgressBar opts+ liftIO $ tickN' progressBar pos+ f (tickN' progressBar)+ where opts = def+ { pgTotal = fromIntegral (fromMaybe maxBound (fileSize file))+ , pgWidth = 100+ , pgFormat = maybe formatUnknown (const format) (fileSize file) }+ cappedFn = cap 30 (fromRelFile (fileName file))+ format = cappedFn ++ " [:bar] :percent (:current/:total)"+ formatUnknown = cappedFn ++ " [:bar] (:current/unknown)"++tickN' :: Integral a => ProgressBar -> a -> IO ()+tickN' p = tickN p . fromIntegral++cap :: Int -> String -> String+cap bound s+ | length s > bound && bound > 1+ = take (bound - 1) s ++ "…"+ | otherwise = s++bracket :: (Monad m) =>+ ExceptT e m a -> (a -> ExceptT e m b) -> (a -> ExceptT e m c)+ -> ExceptT e m c+bracket acquire release apply = do+ r <- acquire+ z <- lift $ runExceptT $ apply r+ _ <- release r+ hoistEither z
+ src/Xdcc.hs view
@@ -0,0 +1,42 @@+module Xdcc ( module Dcc+ , request+ ) where++import Dcc++import Control.Concurrent.Broadcast (Broadcast, broadcast)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask)+import Data.ByteString.Char8 (pack)+import System.Console.Concurrent (outputConcurrent)++request :: Pack -> DccIO OfferFile+request p =+ do env <- ask+ liftIO $ outputConcurrent ( "Requesting pack #" ++ show p ++ " from "+ ++ remoteNick env ++ ", awaiting file offer…\n" )+ o@(OfferFile _ f) <- requestFile p+ liftIO $ outputConcurrent+ ( "Received file offer for " ++ show (fileName f)+ ++ (case fileSize f of+ Just fs -> " of size " ++ show fs ++ " bytes.\n"+ Nothing -> ", no file size provided.\n") )+ return o++-- TODO XDCC CANCEL on failure+requestFile :: Pack -> DccIO OfferFile+requestFile num =+ do env <- ask+ lift $ sendAndWaitForAck (connection env)+ (remoteNick env)+ (pack ("XDCC SEND #" ++ show num))+ onFileOfferReceived+ "Timeout when waiting for file offer."++onFileOfferReceived :: Nickname -> Broadcast OfferFile -> EventFunc+onFileOfferReceived rNick bc _ =+ onCtcpMessage (from rNick)+ (\ msg -> case runParser parseService msg of+ Right (FileTransfer o) -> broadcast bc o+ _ -> return ())
+ xdcc.cabal view
@@ -0,0 +1,46 @@+name: xdcc+version: 1.0.0+synopsis: A wget-like utility for retrieving files from XDCC bots on+ IRC+description: XDCC (eXtended DCC) is a protocol used by IRC bots to make+ files available for transfer. This utility can be used to+ retrieve such files.+ .+ See <https://de.wikipedia.org/wiki/XDCC> for+ more details.+license: MIT+license-file: LICENSE+homepage: https://github.com/JanGe/xdcc+bug-reports: https://github.com/JanGe/xdcc/issues+author: Jan Gerlinger+maintainer: git@jangerlinger.de+category: Network+-- copyright:+build-type: Simple+cabal-version: >=1.10++executable xdcc+ hs-source-dirs: src+ main-is: Main.hs+ other-modules: Irc+ , Dcc+ , Xdcc+ build-depends: base >= 4.7 && < 5+ , ascii-progress >= 0.3.2.0 && < 0.4+ , bytestring >= 0.10.6.0 && < 0.11+ , case-insensitive >= 1.2.0.6 && < 1.3+ , concurrent-extra >= 0.7.0.10 && < 0.8+ , concurrent-output >= 1.7.4 && < 1.8+ , errors >= 2.1.2 && < 2.2+ , iproute >= 1.7.0 && < 1.8+ , irc-ctcp >= 0.1.3.0 && < 0.2+ , irc-dcc >= 1.0.0 && < 1.2+ , network >= 2.6.2.1 && < 2.7+ , optparse-applicative >= 0.12.1.0 && < 0.13+ , path >= 0.5.7 && < 0.6+ , random == 1.1.*+ , simpleirc >= 0.3.1 && < 0.4+ , transformers >= 0.4.2.0 && < 0.5+ , unix >= 2.7.1.0 && < 2.8+ default-language: Haskell2010+ ghc-options: -Wall