diff --git a/src/DCC.hs b/src/DCC.hs new file mode 100644 --- /dev/null +++ b/src/DCC.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module DCC ( module Network.IRC.DCC + , DccIO + , runDccIO + , Env(..) + , Status(..) + , offerReceivedHandler + , acceptResumeHandler + ) where + +import IRC.Types + +import Control.Error (note) +import Control.Exception.Safe (MonadThrow) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, asks, + runReaderT) +import Data.IP (IPv4) +import Data.Monoid ((<>)) +import qualified Data.Text as T (Text) +import qualified Network.IRC.Client as IRC +import Network.IRC.DCC hiding (Path) +import Network.IRC.DCC.Client.FileTransfer +import Network.Socket (PortNumber) +import Path (File, Path, Rel, + fromRelFile) +import Prelude hiding (length, null) +import System.Console.AsciiProgress (ProgressBar) +import System.Console.Concurrent (outputConcurrent) +import System.PosixCompat.Files (fileExist, getFileStatus, + isRegularFile) +import qualified System.PosixCompat.Files as Files (fileSize) + +newtype DccIO s a = DccIO (ReaderT (Env s) (ReaderT (IRC.IRCState s) IO) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) + +runDccIO :: Env s -> DccIO s a -> ReaderT (IRC.IRCState s) IO a +runDccIO env (DccIO m) = runReaderT m env + +send :: IRC.UnicodeMessage -> DccIO s () +send msg = DccIO $ do + send' <- asks sendFn + lift $ send' msg + +putDccState :: Status -> DccIO s () +putDccState s = DccIO $ do + putState' <- asks putDccStateFn + lift $ putState' s + +disconnect :: DccIO s () +disconnect = DccIO $ do + disconnect' <- asks disconnectFn + lift disconnect' + +getEnv :: DccIO s (Env s) +getEnv = DccIO ask + +transfer' :: FileTransfer (ReaderT (IRC.IRCState s) IO) -> DccIO s () +transfer' = DccIO . lift . transfer + +class FileOffer a where + fileName :: a -> Path Rel File + size :: a -> Maybe FileOffset + +instance FileOffer DccSend where + fileName (Send p _ _ _) = fromPath p + fileName (SendReverseServer p _ _ _) = fromPath p + + size (Send _ _ _ s) = s + size (SendReverseServer _ _ s _) = Just s + +data Env s = Env { remoteNick :: !Nickname + , publicIP :: !(Maybe IPv4) + , localPort :: !(Maybe PortNumber) + , progressBar :: Path Rel File -> Maybe FileOffset -> IO ProgressBar + , progress :: ProgressBar -> FileOffset -> IO () + , sendFn :: IRC.UnicodeMessage -> IRC.StatefulIRC s () + , putDccStateFn :: Status -> IRC.StatefulIRC s () + , disconnectFn :: IRC.StatefulIRC s () } + +data Status = Requesting + | Downloading !DccSend + | TryResuming !DccSend + | Resuming !DccSend !FileOffset + | Done + | Aborting + deriving (Eq, Show) + +offerReceivedHandler :: IRC.UnicodeEvent -> DccIO s () +offerReceivedHandler IRC.Event { _source = IRC.User user + , _message = IRC.Privmsg _ (Left msg) } = do + env <- getEnv + when (user == remoteNick env) $ + either (const $ return ()) downloadOrTryResume (fromCtcp msg) +offerReceivedHandler _ = return () + +downloadOrTryResume :: DccSend -> DccIO s () +downloadOrTryResume offer = do + liftIO $ outputConcurrent + ( "Received file offer for " ++ show (fileName offer) + ++ maybe ", no file size provided.\n" + (\s -> " of size " ++ show s ++ " bytes.\n") (size offer) ) + resumable <- liftIO $ isResumable (fileName offer) (size offer) + case resumable of + Right maybePos -> maybe (download FromStart offer) + (tryResume offer) maybePos + Left err -> abort err + +tryResume :: DccSend -> FileOffset -> DccIO s () +tryResume offer pos = do + rNick <- remoteNick <$> getEnv + liftIO $ outputConcurrent ("Resumable file found with size " <> show pos <> ".\n") + putDccState (TryResuming offer) + sendCtcp rNick (resumeFromSend offer pos) + +acceptResumeHandler :: DccSend -> IRC.UnicodeEvent -> DccIO s () +acceptResumeHandler offer IRC.Event { _source = IRC.User user + , _message = IRC.Privmsg _ (Left msg) } = do + env <- getEnv + when (user == remoteNick env) $ + case fromCtcp msg of + Right accept + | accept `matchesSend` offer -> download (ResumeFrom (acceptedPosition accept)) offer + _ -> return () +acceptResumeHandler _ _ = return () + +download :: TransferType -> DccSend -> DccIO s () +download transferType offer = do + env <- getEnv + case connectionType env offer of + Right conType -> do + liftIO $ outputConcurrent (msg transferType) + putDccState (dlStatus transferType) + downloadWithProgress (fileName offer) (size offer) conType transferType + putDccState Done + disconnect + Left err -> abort err + where + msg FromStart = "No resumable file found, starting from zero...\n" + msg (ResumeFrom pos) = "Resume from position " <> show pos <> "...\n" + + dlStatus FromStart = Downloading offer + dlStatus (ResumeFrom pos) = Resuming offer pos + +connectionType :: Env s -> DccSend -> Either T.Text (ConnectionType (ReaderT (IRC.IRCState s) IO)) +connectionType _ (Send _ ip port _) = Right $ Active ip port (return ()) +connectionType env@Env {..} (SendReverseServer path' ip size' token) = + Passive ip localPort . offerSocketReverse <$> publicIP' + where + offerSocketReverse pIP p = runDccIO env $ + sendCtcp remoteNick $ SendReverseClient path' pIP p size' token + publicIP' = note ("Passive connections are only supported if you provide your external IP " + <> "address on the command line using the '--public-ip' option. You could also try something " + <> "like: '--public-ip `curl -s https://4.ifcfg.me`'.") publicIP + +downloadWithProgress :: Path Rel File + -> Maybe FileOffset + -> ConnectionType (ReaderT (IRC.IRCState s) IO) + -> TransferType + -> DccIO s () +downloadWithProgress name size' conType transType = do + env <- getEnv + pBar <- liftIO $ progressBar env name size' + liftIO $ progress env pBar (pos transType) + transfer' Download + { _fileName = name + , _connectionType = conType + , _transferType = transType + , _onChunk = liftIO . progress env pBar + } + where + pos FromStart = 0 + pos (ResumeFrom p) = p + +abort :: T.Text -> DccIO s () +abort err = do + liftIO $ outputConcurrent err + putDccState Aborting + disconnect + +sendCtcp :: CtcpCommand a => Nickname -> a -> DccIO s () +sendCtcp nick = send . IRC.Privmsg nick . Left . toCtcp + +isResumable :: Path Rel File -> Maybe FileOffset -> IO (Either T.Text (Maybe FileOffset)) +isResumable file totalSize = do + curSize <- getFileSizeSafe (fromRelFile file) + case (curSize, totalSize) of + (Just pos, Just total) + | pos >= total -> return $ Left "File already exists and seems complete." + (Just _, Nothing) -> return $ Left "File already exists. Resuming not supported." + (maybePos, _) -> return $ Right maybePos + +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 diff --git a/src/Dcc.hs b/src/Dcc.hs deleted file mode 100644 --- a/src/Dcc.hs +++ /dev/null @@ -1,100 +0,0 @@ -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.PosixCompat.Files (fileExist, getFileStatus, - isRegularFile) -import qualified System.PosixCompat.Files as Files (fileSize) - -type DccIO = ReaderT DccEnv IrcIO - -data DccEnv = DccEnv { connection :: Connection - , remoteNick :: Nickname - , publicIp :: Maybe IPv4 - , localPort :: Maybe PortNumber } - -sendResumeRequest :: OfferFile -> FileOffset -> DccIO FileOffset -sendResumeRequest (OfferFile tt f) pos = do - let tryResume = TryResumeFile tt f pos - 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 totalSize)) = do - curSize <- liftIO $ getFileSizeSafe (fromRelFile fn) - case (curSize, totalSize) of - (Just pos, Just total) - | pos < total -> do - liftIO $ outputConcurrent - ( "Resumable file found with size " ++ show pos ++ ".\n" ) - Just <$> sendResumeRequest o pos - | 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 '--public-ip' option. You could " - ++ "also try something like: " - ++ "'--public-ip `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/Types.hs b/src/IRC/Types.hs --- a/src/IRC/Types.hs +++ b/src/IRC/Types.hs @@ -1,38 +1,22 @@ module IRC.Types - ( IrcIO - , IrcParams(..) - , Network + ( Network , Channel , Nickname , Password - , Pack - , Connection , Hook(..) ) where -import Control.Error (ExceptT) -import Data.CaseInsensitive (CI) -import Network.SimpleIRC (IrcEvent, MIrc) -import Network.Socket (PortNumber) - -type Network = String -type Channel = CI String -type Nickname = String -type Password = String -type Pack = Int -type Connection = MIrc - -type IrcIO = ExceptT String IO +import Data.ByteString.Char8 (ByteString) +import Data.CaseInsensitive (CI) +import qualified Data.Text as T (Text) +import Network.IRC.Client (EventHandler, StatefulIRC) -data IrcParams = IrcParams { host :: Network - , port :: PortNumber - , secure :: Bool - , username :: Nickname - , password :: Maybe Password - , nickname :: Nickname - , channels :: [Channel] - , hooks :: [Hook] } +type Network = ByteString +type Channel = CI T.Text +type Nickname = T.Text +type Password = T.Text -data Hook = Hook { onConnect :: Connection -> IO () - , events :: [IrcEvent] - , onDisconnect :: Connection -> IO () } +data Hook s = Hook { onConnect :: StatefulIRC s () + , events :: [EventHandler s] + , onDisconnect :: StatefulIRC s () + } diff --git a/src/Irc.hs b/src/Irc.hs deleted file mode 100644 --- a/src/Irc.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Irc ( IrcIO - , IrcParams (..) - , Connection - , Network - , Nickname - , Password - , Channel - , Pack - , EventFunc - , connectTo - , sendAndWaitForAck - , send - , disconnectFrom - , onMessage - , onCtcpMessage - , from - , and - , msgHasPrefix - , logMsg - ) where - -import IRC.Types - -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 (ByteString, isPrefixOf, pack, - unpack) -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 Control.Exception.Lifted - -import Network.SimpleIRC - -connectTo :: IrcParams - -> Bool - -> IO () - -> (Channel -> IO ()) - -> IrcIO Connection -connectTo params withDebug onConnected onJoined = do - (conf, bcs) <- lift $ config params - con <- connect' conf withDebug - joined <- lift ( do mapM_ (`onConnect` con) (hooks params) - onConnected - waitForJoin bcs onJoined ) - `catch` rethrowAfter (disconnectFrom params con) - case joined of - Just _ -> return con - Nothing -> throwE "Timeout when waiting on joining all channels." - -disconnectFrom :: IrcParams -> Connection -> IrcIO () -disconnectFrom IrcParams { hooks } con = - lift ( do mapM_ (`onDisconnect` con) hooks - disconnect con "bye" ) - `catch` ignore - -config :: IrcParams -> IO (IrcConfig, [Broadcast Channel]) -config IrcParams {..} = do - bcs <- replicateM (length channels) Broadcast.new - let conf = (mkDefaultConfig host nickname) - { cPort = fromIntegral port - , cSecure = secure - , cUsername = username - , cPass = password - , cChannels = map CI.original channels - , cEvents = concatMap events hooks - ++ zipWith ((Join .) . onJoin) channels bcs } - return (conf, bcs) - -connect' :: IrcConfig -> Bool -> IrcIO Connection -connect' conf withDebug = do - con <- lift $ hoistEither <$> connect conf True withDebug - catchE con (throwE . ioeGetErrorString) - -waitForJoin :: [Broadcast Channel] -> (Channel -> IO ()) -> IO (Maybe [Channel]) -waitForJoin bcs onJoined = do - joined <- sequence <$> waitForAll bcs - case joined of - Just chans -> mapM_ onJoined chans - Nothing -> return () - return joined - -waitForAll :: [Broadcast a] -> IO [Maybe a] -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 - -onJoin :: Channel -> Broadcast Channel -> EventFunc -onJoin channel notifyJoined con ircMessage = do - curNick <- getNickname con - onMessage (for curNick `and` msgEqCi channel) - (\_ -> broadcast notifyJoined channel) - 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 - -rethrowAfter :: IrcIO a -> SomeException -> IrcIO b -rethrowAfter f ex = f >> throw ex - -ignore :: SomeException -> IrcIO () -ignore _ = return () diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,41 +2,44 @@ module Main where -import Irc -import Xdcc -import qualified Znc +import qualified DCC +import IRC.Types +import XDCC +import qualified ZNC -import Control.Error -import Control.Exception.Lifted (bracket) +import Control.Concurrent.Async (async, waitCatch) +import Control.Exception (SomeException) 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.ByteString.Char8 as B (pack, unpack) import qualified Data.CaseInsensitive as CI (mk, original) import Data.IP (IPv4) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import qualified Data.Text as T (pack, unpack) +import qualified Network.IRC.Client as IRC import Network.Socket (PortNumber) import Options.Applicative.Extended -import Path (fromRelFile) +import Path (File, Path, Rel, fromRelFile) import System.Console.AsciiProgress hiding (Options) import System.Console.Concurrent (outputConcurrent, withConcurrentOutput) +import System.Exit (exitFailure, exitSuccess) import System.Random (randomRIO) -data Options = Options { network :: Network - , mainChannel :: Channel - , rNick :: Nickname - , packno :: Pack - , rPort :: PortNumber - , useSecure :: Bool - , user :: Nickname - , pass :: Maybe Password - , nick :: Nickname - , additionalChannels :: [Channel] - , publicIp :: Maybe IPv4 - , lPort :: Maybe PortNumber - , zncAutoConnect :: Bool - , verbose :: Bool } +data Options = Options { network :: !Network + , mainChannel :: !Channel + , remoteNick :: !Nickname + , packNumber :: !Pack + , remotePort :: !PortNumber + , useSecure :: !Bool + , username :: !Nickname + , password :: !(Maybe Password) + , nickname :: !Nickname + , additionalChannels :: ![Channel] + , publicIP :: !(Maybe IPv4) + , localPort :: !(Maybe PortNumber) + , zncAutoConnect :: !Bool + , verbose :: !Bool } deriving (Show) options :: String -> ParserInfo Options @@ -46,16 +49,16 @@ <> progDesc ( "A wget-like utility for retrieving " ++ "files from XDCC bots on IRC" )) where opts = Options - <$> strArgument + <$> ( B.pack <$> strArgument ( metavar "HOST" - <> help "Host address of the IRC network" ) - <*> ( CI.mk <$> strArgument + <> help "Host address of the IRC network" )) + <*> ( CI.mk . T.pack <$> strArgument ( metavar "CHANNEL" <> help "Main channel to join on network" )) - <*> strArgument + <*> ( T.pack <$> strArgument ( metavar "USER" - <> help "Nickname of the user or bot to download from" ) - <*> argument auto + <> help "Nickname of the user or bot to download from" )) + <*> argument packNum ( metavar "#PACK" <> help "Pack number of the file to download" ) <*> option tcpPort @@ -68,24 +71,24 @@ ( long "secure" <> short 's' <> help "Use a secure transport (TLS) for the IRC connection" ) - <*> strOption + <*> ( T.pack <$> strOption ( long "username" <> short 'u' <> metavar "USERNAME" <> value defaultNick - <> help "Username used to authenticate on IRC network" ) - <*> optional ( strOption + <> help "Username used to authenticate on IRC network" )) + <*> optional ( T.pack <$> strOption ( long "password" <> short 'p' <> metavar "PASSWORD" - <> help "Username used to authenticate on IRC network" )) - <*> strOption + <> help "Password used to authenticate on IRC network" )) + <*> ( T.pack <$> strOption ( long "nickname" <> short 'n' <> metavar "NICKNAME" <> value defaultNick - <> help "Nickname to use for the IRC connection" ) - <*> many ( CI.mk <$> strOption + <> help "Nickname to use for the IRC connection" )) + <*> many ( CI.mk . T.pack <$> strOption ( long "join" <> short 'j' <> metavar "CHANNEL" @@ -115,87 +118,82 @@ 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 () + defaultNick <- randomNick + opts <- execParser $ options defaultNick + result <- mainWith opts + case result of + Left ex -> outputConcurrent ("FAILURE xdcc: " ++ show ex ++ "\n") >> exitFailure + _ -> exitSuccess -randomNick :: IO String -randomNick = replicateM 10 $ randomRIO ('a', 'z') + where + randomNick = replicateM 10 $ randomRIO ('a', 'z') -runWith :: Options -> ExceptT String IO () -runWith opts = withIrcConnection opts . withDccEnv opts $ - runReaderT $ do o <- request (packno opts) - pos <- canResume o - case pos of - Just p -> resume o p - Nothing -> download o +-- TODO ZNC hooks +mainWith :: Options -> IO (Either SomeException ()) +mainWith Options {..} = do + outputConcurrent ( "Connecting to " ++ B.unpack network ++ " on port " + ++ show remotePort ++ " as " ++ T.unpack nickname ++ "…\n" ) + conn <- connectWith logger network (fromIntegral remotePort) 1 -withIrcConnection :: Options -> (Connection -> ExceptT String IO a) - -> ExceptT String IO a -withIrcConnection Options {..} = - bracket (connectAndJoin params verbose) - (disconnectFrom params) - where params = IrcParams { host = network - , port = rPort - , secure = useSecure - , username = user - , password = pass - , nickname = nick - , channels = mainChannel : additionalChannels - , hooks = [Znc.autoConnectHooks | zncAutoConnect] } + -- Only wait for joining main channel. It doesn't matter that we might not have + -- joined all additional channels when initiating a file transfer. + eventLoop <- async $ IRC.startStateful (connConfig conn) ircConfig initState + waitCatch eventLoop + -- TODO Handle errors -withDccEnv :: Options -> (DccEnv -> a) -> Connection -> a -withDccEnv Options {..} f con = f DccEnv { connection = con - , publicIp = publicIp - , remoteNick = rNick - , localPort = lPort } + where + initState = XDCC.initialState mainChannel -connectAndJoin :: IrcParams -> Bool -> ExceptT String IO Connection -connectAndJoin params withDebug = do - lift $ outputConcurrent - ( "Connecting to " ++ host params ++ " on port " ++ show (port params) - ++ " as " ++ nickname params ++ "… " ) - connectTo params withDebug - (outputConcurrent "Connected.\n") - (\ chan -> outputConcurrent ("Joined " ++ CI.original chan ++ ".\n")) + xdccConfig = XDCC.Env + { packNumber = packNumber + , dccEnv = DCC.Env + { remoteNick = remoteNick + , publicIP = publicIP + , localPort = localPort + , progressBar = pBar + , progress = progressFn + , sendFn = IRC.send + , putDccStateFn = XDCC.putDccState + , disconnectFn = IRC.disconnect + } + } -download :: OfferFile -> DccIO () -download o@(OfferFile _ f) = do - env <- ask - lift $ withProgressBar f 0 (\onChunk -> - runReaderT - (acceptFile o (offerSink env o) onChunk) - (localPort env) ) + connConfig conn' = conn' + { IRC._onconnect = IRC.defaultOnConnect >> mapM_ onConnect hooks + , IRC._ondisconnect = IRC.defaultOnDisconnect >> mapM_ onDisconnect hooks + } -resume :: OfferFile -> FileOffset -> DccIO () -resume o@(OfferFile tt f) pos = do - env <- ask - lift $ withProgressBar f pos (\onChunk -> - runReaderT - (resumeFile (AcceptResumeFile tt f pos) (offerSink env o) onChunk) - (localPort env) ) + ircConfig = (IRC.defaultIRCConf nickname) + { IRC._username = username + , IRC._password = password + , IRC._channels = CI.original <$> mainChannel : additionalChannels + , IRC._eventHandlers = dispatcher xdccConfig + : mconcat (events <$> hooks) + <> IRC.defaultEventHandlers + } -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)" + hooks = [ZNC.autoConnectHooks | zncAutoConnect] -tickN' :: Integral a => ProgressBar -> a -> IO () -tickN' p = tickN p . fromIntegral + connectWith + | useSecure = IRC.connectWithTLS' + | otherwise = IRC.connect' + + logger + | verbose = IRC.stdoutLogger + | otherwise = IRC.noopLogger + +progressFn :: Integral a => ProgressBar -> a -> IO () +progressFn p = tickN p . fromIntegral + +pBar :: Path Rel File -> Maybe DCC.FileOffset -> IO ProgressBar +pBar name size = newProgressBar $ def + { pgTotal = fromIntegral $ fromMaybe maxBound size + , pgFormat = maybe formatUnknown (const format) size + , pgWidth = 100 } + where + cappedName = cap 30 $ fromRelFile name + formatUnknown = cappedName ++ " [:bar] (:current/unknown)" + format = cappedName ++ " [:bar] :percent (:current/:total)" cap :: Int -> String -> String cap bound s diff --git a/src/Options/Applicative/Extended.hs b/src/Options/Applicative/Extended.hs --- a/src/Options/Applicative/Extended.hs +++ b/src/Options/Applicative/Extended.hs @@ -1,12 +1,14 @@ module Options.Applicative.Extended ( module Options.Applicative , tcpPort + , packNum ) where import Data.Word (Word16) import Network.Socket (PortNumber) import Options.Applicative import Text.Read (readMaybe) +import XDCC (Pack (..)) tcpPort :: ReadM PortNumber tcpPort = @@ -14,3 +16,10 @@ case readMaybe arg :: Maybe Word16 of Just n | n > 0 -> Right (fromIntegral n) _ -> Left ("Cannot parse TCP port number: " ++ arg) ) + +packNum :: ReadM Pack +packNum = + eitherReader (\ arg -> + case readMaybe arg :: Maybe Int of + Just n | n > 0 -> Right (Pack n) + _ -> Left ("Cannot parse XDCC pack number: " ++ arg) ) diff --git a/src/XDCC.hs b/src/XDCC.hs new file mode 100644 --- /dev/null +++ b/src/XDCC.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module XDCC + ( Env(..) + , Pack(..) + , initialState + , putDccState + , dispatcher + ) where + +import qualified DCC +import IRC.Types + +import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.CaseInsensitive as CI (mk) +import Data.Monoid ((<>)) +import qualified Data.Text as T (Text, pack) +import qualified Network.IRC.Client as IRC +import System.Console.Concurrent (outputConcurrent) + +class XdccCommand a where + toText :: a -> T.Text + +data XdccSend + = Send !Pack + +instance XdccCommand XdccSend where + toText (Send p) = "XDCC SEND #" <> packToText p + +newtype Pack = Pack { unpack :: Int } + deriving (Eq, Show) + +packToText :: Pack -> T.Text +packToText = T.pack . show . unpack + +newtype XdccIO a = XdccIO { runXdccIO :: IRC.StatefulIRC Stati a } + deriving (Functor, Applicative, Monad, MonadIO) + +putState :: Status -> XdccIO () +putState newS = XdccIO $ do + state <- IRC.stateTVar + liftIO . atomically . modifyTVar state $ \s -> s { xdccStatus = newS } + +addDccHandler :: IRC.EventHandler Stati -> XdccIO () +addDccHandler = XdccIO . IRC.addHandler + +sendXdcc :: XdccCommand a => Nickname -> a -> XdccIO () +sendXdcc nick = XdccIO . IRC.send . IRC.Privmsg nick . Right . toText + +data Stati = Stati { xdccStatus :: Status + , dccStatus :: DCC.Status + } + +initialState :: Channel -> Stati +initialState chan = Stati { xdccStatus = WaitingForJoin chan + , dccStatus = DCC.Requesting + } + +data Env = Env { packNumber :: !Pack + , dccEnv :: !(DCC.Env Stati) } + +data Status + = WaitingForJoin !Channel + | Joined + deriving (Eq, Show) + +dispatcher :: Env -> IRC.EventHandler Stati +dispatcher env = IRC.EventHandler + { _description = "XDCC SEND workflow handling" + , _matchType = IRC.EEverything + , _eventFunc = \ev -> do + status <- xdccStatus <$> IRC.state + case status of + WaitingForJoin chan -> runXdccIO $ joinedHandler env chan ev + _ -> return () + } + +joinedHandler :: Env -> Channel -> IRC.UnicodeEvent -> XdccIO () +joinedHandler Env {..} channel IRC.Event { _message = IRC.Join joined } + | CI.mk joined == channel = do + putState Joined + liftIO $ outputConcurrent ( "Joined " <> joined <> ".\n") + + liftIO $ outputConcurrent + ( "Requesting pack #" <> packToText packNumber <> " from " <> rNick + <> ", awaiting file offer…\n" ) + addDccHandler (dispatcherDcc dccEnv) + sendXdcc rNick (Send packNumber) + where + rNick = DCC.remoteNick dccEnv +joinedHandler _ _ _ = return () + +putDccState :: DCC.Status -> IRC.StatefulIRC Stati () +putDccState newS = do + state <- IRC.stateTVar + liftIO . atomically . modifyTVar state $ \s -> s { dccStatus = newS } + +dispatcherDcc :: DCC.Env Stati -> IRC.EventHandler Stati +dispatcherDcc env = IRC.EventHandler + { _description = "DCC SEND workflow handling" + , _matchType = IRC.EEverything + , _eventFunc = \ev -> do + status <- dccStatus <$> IRC.state + case status of + DCC.Requesting -> DCC.runDccIO env $ DCC.offerReceivedHandler ev + DCC.TryResuming offer -> DCC.runDccIO env $ DCC.acceptResumeHandler offer ev + _ -> return () + } diff --git a/src/Xdcc.hs b/src/Xdcc.hs deleted file mode 100644 --- a/src/Xdcc.hs +++ /dev/null @@ -1,42 +0,0 @@ -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/src/ZNC.hs b/src/ZNC.hs new file mode 100644 --- /dev/null +++ b/src/ZNC.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module ZNC (autoConnectHooks) where + +import IRC.Types + +import qualified Data.Text as T (Text) +import Network.IRC.Client (Event (..), EventHandler (..), + EventType (EPrivmsg), Message (..), + Source (..), StatefulIRC, send) + +{- TODO Additional checks + host == "znc.in" + user == "znc" +-} +pattern ZncStatusUser = User "*status" + +pattern ZncDisconnectedMsg target = + Privmsg target (Right + "You are currently disconnected from IRC. Use 'connect' to reconnect.") + +autoConnectHooks :: Hook s +autoConnectHooks = Hook { onConnect = return () + , events = [autoReconnect] + , onDisconnect = disconnect } + +autoReconnect :: EventHandler s +autoReconnect = EventHandler + { _description = "Auto-reconnect when ZNC is enabled" + , _matchType = EPrivmsg + , _eventFunc = handler + } + where + handler Event { _source = ZncStatusUser + , _message = ZncDisconnectedMsg _ } = send' "connect" + handler _ = return () + +disconnect :: StatefulIRC s () +disconnect = send' "disconnect" + +send' :: T.Text -> StatefulIRC s () +send' = send . Privmsg "*status" . Right diff --git a/src/Znc.hs b/src/Znc.hs deleted file mode 100644 --- a/src/Znc.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Znc (autoConnectHooks) where - -import IRC.Types - -import Control.Monad (when) -import Data.Monoid ((<>)) -import Network.SimpleIRC (Command (MPrivmsg), IrcEvent (Privmsg), - IrcMessage (..), sendCmd) - -autoConnectHooks :: Hook -autoConnectHooks = Hook { onConnect = const (return ()) - , events = [autoReconnect] - , onDisconnect = disconnect } - -autoReconnect :: IrcEvent -autoReconnect = Privmsg (\con msg -> - when (isDisconnectedMsg msg) $ - sendCmd con $ MPrivmsg "*status" "connect" ) - -disconnect :: Connection -> IO () -disconnect con = sendCmd con $ MPrivmsg "*status" "disconnect" - -isDisconnectedMsg :: IrcMessage -> Bool -isDisconnectedMsg msg@IrcMessage { mMsg } = - isStatusMsg msg - && mMsg == ( "You are currently disconnected from IRC. Use 'connect' to " - <> "reconnect." ) - -isStatusMsg :: IrcMessage -> Bool -isStatusMsg IrcMessage { mHost, mOrigin, mNick, mUser } = - mHost == Just "znc.in" && mOrigin == Just "*status" - && mNick == Just "*status" && mUser == Just "znc" diff --git a/xdcc.cabal b/xdcc.cabal --- a/xdcc.cabal +++ b/xdcc.cabal @@ -1,5 +1,5 @@ name: xdcc -version: 1.0.6 +version: 1.1.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 @@ -22,29 +22,34 @@ executable xdcc hs-source-dirs: src main-is: Main.hs - other-modules: Irc + other-modules: DCC , IRC.Types - , Dcc - , Xdcc - , Znc + , XDCC + , ZNC , Options.Applicative.Extended build-depends: base >= 4.7 && < 5 , ascii-progress >= 0.3.2.0 && < 0.4 + , async >= 2.1.0 && < 2.2 , 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-client >= 0.4.2.0 && < 0.5 + , irc-conduit >= 0.2.0.0 && < 0.3 , irc-ctcp >= 0.1.3.0 && < 0.2 - , irc-dcc >= 1.2.0 && < 1.3 + , irc-dcc >= 2.0.0 && < 2.1 , lifted-base >= 0.2.3.0 && < 0.3 , network >= 2.6.2.1 && < 2.7 , optparse-applicative >= 0.12.1.0 && < 0.14 , path >= 0.5.7 && < 0.6 , random == 1.1.* - , simpleirc >= 0.3.1 && < 0.4 + , text >= 1.2.2.1 && < 1.3 + , text-format >= 0.3.1.1 && < 0.4 , transformers >= 0.4.2.0 && < 0.6 + , safe-exceptions >= 0.1.4.0 && < 0.2 + , stm >= 2.4.4.1 && < 2.5 , unix-compat >= 0.4.1.0 && < 0.5 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N