diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 Jan Gerlinger + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Dcc.hs b/src/Dcc.hs new file mode 100644 --- /dev/null +++ b/src/Dcc.hs @@ -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 diff --git a/src/Irc.hs b/src/Irc.hs new file mode 100644 --- /dev/null +++ b/src/Irc.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Xdcc.hs b/src/Xdcc.hs new file mode 100644 --- /dev/null +++ b/src/Xdcc.hs @@ -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 ()) diff --git a/xdcc.cabal b/xdcc.cabal new file mode 100644 --- /dev/null +++ b/xdcc.cabal @@ -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 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