diff --git a/src/Dcc.hs b/src/Dcc.hs --- a/src/Dcc.hs +++ b/src/Dcc.hs @@ -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 () diff --git a/src/IRC/Types.hs b/src/IRC/Types.hs new file mode 100644 --- /dev/null +++ b/src/IRC/Types.hs @@ -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 () } diff --git a/src/Irc.hs b/src/Irc.hs --- a/src/Irc.hs +++ b/src/Irc.hs @@ -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 () diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Options/Applicative/Extended.hs b/src/Options/Applicative/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Options/Applicative/Extended.hs @@ -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) ) diff --git a/src/Znc.hs b/src/Znc.hs new file mode 100644 --- /dev/null +++ b/src/Znc.hs @@ -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" diff --git a/xdcc.cabal b/xdcc.cabal --- a/xdcc.cabal +++ b/xdcc.cabal @@ -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