xdcc 1.0.6 → 1.1.0
raw patch · 11 files changed
+504/−491 lines, 11 filesdep +asyncdep +irc-clientdep +irc-conduitdep −simpleircdep ~irc-dcc
Dependencies added: async, irc-client, irc-conduit, safe-exceptions, stm, text, text-format
Dependencies removed: simpleirc
Dependency ranges changed: irc-dcc
Files
- src/DCC.hs +208/−0
- src/Dcc.hs +0/−100
- src/IRC/Types.hs +13/−29
- src/Irc.hs +0/−169
- src/Main.hs +106/−108
- src/Options/Applicative/Extended.hs +9/−0
- src/XDCC.hs +111/−0
- src/Xdcc.hs +0/−42
- src/ZNC.hs +44/−0
- src/Znc.hs +0/−35
- xdcc.cabal +13/−8
+ src/DCC.hs view
@@ -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
− src/Dcc.hs
@@ -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
src/IRC/Types.hs view
@@ -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 ()+ }
− src/Irc.hs
@@ -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 ()
src/Main.hs view
@@ -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
src/Options/Applicative/Extended.hs view
@@ -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) )
+ src/XDCC.hs view
@@ -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 ()+ }
− src/Xdcc.hs
@@ -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 ())
+ src/ZNC.hs view
@@ -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
− src/Znc.hs
@@ -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"
xdcc.cabal view
@@ -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