xdcc 1.0.2 → 1.0.3
raw patch · 7 files changed
+303/−150 lines, 7 filesdep +lifted-basedep +unix-compatdep −unixdep ~transformers
Dependencies added: lifted-base, unix-compat
Dependencies removed: unix
Dependency ranges changed: transformers
Files
- src/Dcc.hs +37/−37
- src/IRC/Types.hs +38/−0
- src/Irc.hs +77/−50
- src/Main.hs +78/−45
- src/Options/Applicative/Extended.hs +16/−0
- src/Znc.hs +35/−0
- xdcc.cabal +22/−18
src/Dcc.hs view
@@ -25,9 +25,9 @@ import Path (fromRelFile) import Prelude hiding (length, null) import System.Console.Concurrent (outputConcurrent)-import System.Posix.Files (fileExist, getFileStatus,+import System.PosixCompat.Files (fileExist, getFileStatus, isRegularFile)-import qualified System.Posix.Files as Files (fileSize)+import qualified System.PosixCompat.Files as Files (fileSize) type DccIO = ReaderT DccEnv IrcIO @@ -37,14 +37,14 @@ , localPort :: Maybe PortNumber } 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"+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@@ -55,32 +55,32 @@ 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+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+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 =@@ -88,11 +88,11 @@ Just i -> lift $ send (connection env) (remoteNick env) (asByteString (OfferFileSink t f i p))- Nothing -> throwE ( "Passive connections are only supported, if you "+ Nothing -> throwE ( "Passive connections are only supported if you " ++ "provide your external IP address on the command "- ++ "line using the '--publicIp' option. You could "+ ++ "line using the '--public-ip' option. You could " ++ "also try something like: "- ++ "'--publicIP `curl -s https://4.ifcfg.me`'." )+ ++ "'--public-ip `curl -s https://4.ifcfg.me`'." ) -- Only passive connections can offer a sink to connect to offerSink _ _ _ = lift $ return ()
+ src/IRC/Types.hs view
@@ -0,0 +1,38 @@+module IRC.Types+ ( IrcIO+ , IrcParams(..)+ , 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++data IrcParams = IrcParams { host :: Network+ , port :: PortNumber+ , secure :: Bool+ , username :: Nickname+ , password :: Maybe Password+ , nickname :: Nickname+ , channels :: [Channel]+ , hooks :: [Hook] }++data Hook = Hook { onConnect :: Connection -> IO ()+ , events :: [IrcEvent]+ , onDisconnect :: Connection -> IO () }
src/Irc.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Irc ( IrcIO+ , IrcParams (..) , Connection , Network , Nickname+ , Password , Channel , Pack , EventFunc@@ -20,12 +23,15 @@ , 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 hiding (length, map, zip)+import Data.ByteString.Char8 (ByteString, isPrefixOf, pack,+ unpack) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Monoid ((<>))@@ -33,42 +39,59 @@ import Prelude hiding (and) import System.Console.Concurrent (outputConcurrent) import System.IO.Error (ioeGetErrorString)+import Control.Exception.Lifted 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 ()+connectTo :: IrcParams+ -> Bool+ -> IO ()+ -> (Channel -> 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+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."- where config' bcs = config network nick (chans `zip` bcs) +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)+connect' conf withDebug = do+ con <- lift $ hoistEither <$> connect conf True withDebug+ catchE con (throwE . ioeGetErrorString) -waitForAll :: [Broadcast ()] -> IO [Maybe ()]+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@@ -77,31 +100,29 @@ -> (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+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")+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+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 } =@@ -140,3 +161,9 @@ 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
@@ -4,16 +4,18 @@ import Irc import Xdcc+import qualified Znc import Control.Error+import Control.Exception.Lifted (bracket) 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 qualified Data.CaseInsensitive as CI (mk, original) import Data.IP (IPv4) import Network.Socket (PortNumber)-import Options.Applicative+import Options.Applicative.Extended import Path (fromRelFile) import System.Console.AsciiProgress hiding (Options) import System.Console.Concurrent (outputConcurrent,@@ -23,11 +25,16 @@ data Options = Options { network :: Network , mainChannel :: Channel , rNick :: Nickname- , pack :: Pack+ , 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 } deriving (Show) @@ -50,60 +57,94 @@ <*> argument auto ( metavar "#PACK" <> help "Pack number of the file to download" )+ <*> option tcpPort+ ( long "port"+ <> short 'P'+ <> metavar "PORT"+ <> value 6667+ <> help "Port the IRC network is available on (default is 6667)" )+ <*> switch+ ( long "secure"+ <> short 's'+ <> help "Use a secure transport (TLS) for the IRC connection" ) <*> strOption+ ( long "username"+ <> short 'u'+ <> metavar "USERNAME"+ <> value defaultNick+ <> help "Username used to authenticate on IRC network" )+ <*> optional ( strOption+ ( long "password"+ <> short 'p'+ <> metavar "PASSWORD"+ <> help "Username used to authenticate on IRC network" ))+ <*> strOption ( long "nickname" <> short 'n'- <> metavar "NAME"+ <> metavar "NICKNAME" <> value defaultNick <> help "Nickname to use for the IRC connection" ) <*> many ( CI.mk <$> strOption ( long "join" <> short 'j'- <> metavar "CHANNEL" ))+ <> metavar "CHANNEL"+ <> help "Join additional channels" )) <*> optional ( option auto- ( long "publicIp"+ ( long "public-ip" <> short 'i' <> metavar "IP"- <> help ( "IPv4 address where you are reachable (only needed for "- ++ "Reverse DCC support)." )))- <*> optional ( fromIntegral <$> option auto- ( long "localPort"- <> short 'p'- <> metavar "LOCAL_PORT"- <> help ( "Local port to bind to, by default the port is selected "- ++ "by the operating system (only needed for Reverse DCC "- ++ "support)." )))+ <> help ( "IPv4 address where you are reachable from the outside "+ ++ "(only needed for Reverse DCC support)" )))+ <*> optional ( option tcpPort+ ( long "bind-port"+ <> short 'b'+ <> metavar "PORT"+ <> help ( "Local port to bind to (default is an arbitrary port "+ ++ "selected by the operating system; only needed for "+ ++ "Reverse DCC support)" ))) <*> switch+ ( long "znc-auto-connect"+ <> short 'z'+ <> help ( "Tell ZNC IRC bouncer to connect to IRC network if "+ ++ "disconnected" ))+ <*> 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 ()+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+ runReaderT $ do o <- request (packno 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+ 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] } withDccEnv :: Options -> (DccEnv -> a) -> Connection -> a withDccEnv Options {..} f con = f DccEnv { connection = con@@ -111,14 +152,14 @@ , remoteNick = rNick , localPort = lPort } -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+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")- (outputConcurrent $ "Joined " ++ show chans ++ ".\n")+ (\ chan -> outputConcurrent ("Joined " ++ CI.original chan ++ ".\n")) download :: OfferFile -> DccIO () download o@(OfferFile _ f) = do@@ -161,11 +202,3 @@ = 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/Options/Applicative/Extended.hs view
@@ -0,0 +1,16 @@+module Options.Applicative.Extended+ ( module Options.Applicative+ , tcpPort+ ) where++import Data.Word (Word16)+import Network.Socket (PortNumber)+import Options.Applicative+import Text.Read (readMaybe)++tcpPort :: ReadM PortNumber+tcpPort =+ eitherReader (\ arg ->+ case readMaybe arg :: Maybe Word16 of+ Just n | n > 0 -> Right (fromIntegral n)+ _ -> Left ("Cannot parse TCP port number: " ++ arg) )
+ src/Znc.hs view
@@ -0,0 +1,35 @@+{-# 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.2+version: 1.0.3 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@@ -23,24 +23,28 @@ hs-source-dirs: src main-is: Main.hs other-modules: Irc+ , IRC.Types , 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.2.0 && < 1.3- , network >= 2.6.2.1 && < 2.7+ , Znc+ , Options.Applicative.Extended+ 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.2.0 && < 1.3+ , lifted-base >= 0.2.3.0 && < 0.3+ , 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+ , path >= 0.5.7 && < 0.6+ , random == 1.1.*+ , simpleirc >= 0.3.1 && < 0.4+ , transformers >= 0.4.2.0+ , unix-compat >= 0.4.1.0 && < 0.4.2 default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N