diff --git a/src/DCC.hs b/src/DCC.hs --- a/src/DCC.hs +++ b/src/DCC.hs @@ -48,16 +48,21 @@ send' <- asks sendFn lift $ send' msg -putDccState :: Status -> DccIO s () +putDccState :: Status -> DccIO s () putDccState s = DccIO $ do - putState' <- asks putDccStateFn - lift $ putState' s + putState <- asks putDccStateFn + lift $ putState s -disconnect :: DccIO s () -disconnect = DccIO $ do - disconnect' <- asks disconnectFn - lift disconnect' +onDone :: DccIO s () +onDone = DccIO $ do + onDone' <- asks onDoneFn + lift onDone' +onAbort :: DccIO s () +onAbort = DccIO $ do + onAbort' <- asks onAbortFn + lift onAbort' + getEnv :: DccIO s (Env s) getEnv = DccIO ask @@ -82,7 +87,8 @@ , progress :: ProgressBar -> FileOffset -> IO () , sendFn :: IRC.UnicodeMessage -> IRC.StatefulIRC s () , putDccStateFn :: Status -> IRC.StatefulIRC s () - , disconnectFn :: IRC.StatefulIRC s () } + , onDoneFn :: IRC.StatefulIRC s () + , onAbortFn :: IRC.StatefulIRC s () } data Status = Requesting | Downloading !DccSend @@ -139,7 +145,7 @@ putDccState (dlStatus transferType) downloadWithProgress (fileName offer) (size offer) conType transferType putDccState Done - disconnect + onDone Left err -> abort err where msg FromStart = "No resumable file found, starting from zero...\n" @@ -180,12 +186,16 @@ abort :: T.Text -> DccIO s () abort err = do - liftIO $ outputConcurrent err + liftIO $ outputConcurrent (err <> "\n") putDccState Aborting - disconnect + onAbort sendCtcp :: CtcpCommand a => Nickname -> a -> DccIO s () -sendCtcp nick = send . IRC.Privmsg nick . Left . toCtcp +sendCtcp nick cmd = do + liftIO $ outputConcurrent (show msg <> "\n") + send msg + where + msg = IRC.Privmsg nick (Left $ toCtcp cmd) isResumable :: Path Rel File -> Maybe FileOffset -> IO (Either T.Text (Maybe FileOffset)) isResumable file totalSize = do diff --git a/src/IRC/Types.hs b/src/IRC/Types.hs --- a/src/IRC/Types.hs +++ b/src/IRC/Types.hs @@ -4,17 +4,12 @@ , Nickname , Password , Hook(..) - , addHandler' ) where -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar (readTVar, writeTVar) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Char8 (ByteString) -import Data.CaseInsensitive (CI) -import qualified Data.Text as T (Text) -import Network.IRC.Client (EventHandler, InstanceConfig (..), - StatefulIRC, instanceConfigTVar) +import Data.ByteString.Char8 (ByteString) +import Data.CaseInsensitive (CI) +import qualified Data.Text as T (Text) +import Network.IRC.Client (EventHandler, StatefulIRC) type Network = ByteString type Channel = CI T.Text @@ -25,13 +20,3 @@ , events :: [EventHandler s] , onDisconnect :: StatefulIRC s () } - --- TODO Remove when https://github.com/barrucadu/irc-client/pull/19 is merged. --- | Add an event handler -addHandler' :: EventHandler s -> StatefulIRC s () -addHandler' handler = do - tvarI <- instanceConfigTVar - - liftIO . atomically $ do - iconf <- readTVar tvarI - writeTVar tvarI iconf { _eventHandlers = handler : _eventHandlers iconf } diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -131,13 +131,15 @@ -- TODO ZNC hooks mainWith :: Options -> IO (Either SomeException ()) mainWith Options {..} = do + hooks <- initHooks + outputConcurrent ( "Connecting to " ++ B.unpack network ++ " on port " ++ show remotePort ++ " as " ++ T.unpack nickname ++ "…\n" ) conn <- connectWith logger network (fromIntegral remotePort) 1 -- 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 + eventLoop <- async $ IRC.startStateful (connConfig conn hooks) (ircConfig hooks) initState waitCatch eventLoop -- TODO Handle errors @@ -154,25 +156,26 @@ , progress = progressFn , sendFn = IRC.send , putDccStateFn = XDCC.putDccState - , disconnectFn = IRC.disconnect + , onDoneFn = IRC.disconnect + , onAbortFn = XDCC.onAbort remoteNick } } - connConfig conn' = conn' - { IRC._onconnect = IRC.defaultOnConnect >> mapM_ onConnect hooks - , IRC._ondisconnect = IRC.defaultOnDisconnect >> mapM_ onDisconnect hooks + connConfig conn' hooks' = conn' + { IRC._onconnect = IRC.defaultOnConnect >> mapM_ onConnect hooks' + , IRC._ondisconnect = IRC.defaultOnDisconnect >> mapM_ onDisconnect hooks' } - ircConfig = (IRC.defaultIRCConf nickname) + ircConfig hooks' = (IRC.defaultIRCConf nickname) { IRC._username = username , IRC._password = password , IRC._channels = CI.original <$> mainChannel : additionalChannels , IRC._eventHandlers = dispatcher xdccConfig - : mconcat (events <$> hooks) + : mconcat (events <$> hooks') <> IRC.defaultEventHandlers } - hooks = [ZNC.autoConnectHooks | zncAutoConnect] + initHooks = sequence [ZNC.autoConnectHooks | zncAutoConnect] connectWith | useSecure = IRC.connectWithTLS' diff --git a/src/XDCC.hs b/src/XDCC.hs --- a/src/XDCC.hs +++ b/src/XDCC.hs @@ -1,25 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module XDCC ( Env(..) , Pack(..) , initialState , putDccState + , onAbort , 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) +import Control.Concurrent.STM (atomically, modifyTVar) +import Control.Monad.Base (MonadBase) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl(..), liftBaseOp) +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) +import System.Signal (Signal, installHandler, sigINT) class XdccCommand a where toText :: a -> T.Text @@ -30,6 +37,12 @@ instance XdccCommand XdccSend where toText (Send p) = "XDCC SEND #" <> packToText p +data XdccCancel + = Cancel + +instance XdccCommand XdccCancel where + toText Cancel = "XDCC CANCEL" + newtype Pack = Pack { unpack :: Int } deriving (Eq, Show) @@ -37,18 +50,27 @@ packToText = T.pack . show . unpack newtype XdccIO a = XdccIO { runXdccIO :: IRC.StatefulIRC Stati a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO) +instance MonadBaseControl IO XdccIO where + type StM XdccIO a = a + liftBaseWith f = XdccIO $ liftBaseWith $ \q -> f (q . runXdccIO) + restoreM = XdccIO . restoreM + 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 . addHandler' +addHandler :: IRC.EventHandler Stati -> XdccIO () +addHandler = XdccIO . IRC.addHandler sendXdcc :: XdccCommand a => Nickname -> a -> XdccIO () -sendXdcc nick = XdccIO . IRC.send . IRC.Privmsg nick . Right . toText +sendXdcc nick cmd = XdccIO $ do + liftIO $ outputConcurrent (show msg <> "\n") + IRC.send msg + where + msg = IRC.Privmsg nick (Right $ toText cmd) data Stati = Stati { xdccStatus :: Status , dccStatus :: DCC.Status @@ -87,11 +109,22 @@ liftIO $ outputConcurrent ( "Requesting pack #" <> packToText packNumber <> " from " <> rNick <> ", awaiting file offer…\n" ) - addDccHandler (dispatcherDcc dccEnv) + addHandler (dispatcherDcc dccEnv) + onInterruptSignal $ const $ sendXdcc rNick Cancel sendXdcc rNick (Send packNumber) where rNick = DCC.remoteNick dccEnv joinedHandler _ _ _ = return () + +onAbort :: Nickname -> IRC.StatefulIRC Stati () +onAbort rNick = runXdccIO $ sendXdcc rNick Cancel + +onInterruptSignal :: (Signal -> XdccIO ()) -> XdccIO () +onInterruptSignal f = installHandler' sigINT $ \s -> do + f s + XdccIO IRC.disconnect + where + installHandler' = liftBaseOp . installHandler putDccState :: DCC.Status -> IRC.StatefulIRC Stati () putDccState newS = do diff --git a/src/ZNC.hs b/src/ZNC.hs --- a/src/ZNC.hs +++ b/src/ZNC.hs @@ -6,10 +6,14 @@ import IRC.Types -import qualified Data.Text as T (Text) -import Network.IRC.Client (Event (..), EventHandler (..), - EventType (EPrivmsg), Message (..), - Source (..), StatefulIRC, send) +import Control.Concurrent.STM (TVar, atomically, newTVar, + readTVar, writeTVar) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +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" @@ -23,24 +27,30 @@ Privmsg target (Right "You are currently disconnected from IRC. Use 'connect' to reconnect.") -autoConnectHooks :: Hook s -autoConnectHooks = Hook { onConnect = return () - , events = [autoReconnect] - , onDisconnect = disconnect } +autoConnectHooks :: IO (Hook s) +autoConnectHooks = do + wasConnected <- atomically $ newTVar True + return Hook { onConnect = return () + , events = [autoReconnect wasConnected] + , onDisconnect = disconnect wasConnected } -autoReconnect :: EventHandler s -autoReconnect = EventHandler +autoReconnect :: TVar Bool -> EventHandler s +autoReconnect wasConnected = EventHandler { _description = "Auto-reconnect when ZNC is enabled" , _matchType = EPrivmsg , _eventFunc = handler } where handler Event { _source = ZncStatusUser - , _message = ZncDisconnectedMsg _ } = send' "connect" + , _message = ZncDisconnectedMsg _ } = do + liftIO $ atomically $ writeTVar wasConnected False + send' "connect" handler _ = return () -disconnect :: StatefulIRC s () -disconnect = send' "disconnect" +disconnect :: TVar Bool -> StatefulIRC s () +disconnect wasConnected = do + wasConnected' <- liftIO $ atomically $ readTVar wasConnected + unless wasConnected' $ send' "disconnect" send' :: T.Text -> StatefulIRC s () send' = send . Privmsg "*status" . Right diff --git a/xdcc.cabal b/xdcc.cabal --- a/xdcc.cabal +++ b/xdcc.cabal @@ -1,11 +1,14 @@ name: xdcc -version: 1.1.2 +version: 1.1.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 files available for transfer. This utility can be used to retrieve such files. . + See + for usage instructions. + . See for more details. license: MIT @@ -32,23 +35,21 @@ , 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-client >= 0.4.3.0 && < 0.5 , irc-dcc >= 2.0.0 && < 2.1 - , lifted-base >= 0.2.3.0 && < 0.3 + , monad-control >= 1.0.1.0 && < 1.1 , network >= 2.6.2.1 && < 2.7 , optparse-applicative >= 0.12.1.0 && < 0.14 , path >= 0.5.7 && < 0.6 , random == 1.1.* , text >= 1.2.2.1 && < 1.3 - , text-format >= 0.3.1.1 && < 0.4 , transformers >= 0.4.2.0 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 , safe-exceptions >= 0.1.4.0 && < 0.2 + , signal >= 0.1.0.3 && < 0.2 , stm >= 2.4.4.1 && < 2.5 , unix-compat >= 0.4.1.0 && < 0.5 default-language: Haskell2010