xdcc 1.1.2 → 1.1.3
raw patch · 6 files changed
+113/−71 lines, 6 filesdep +monad-controldep +signaldep +transformers-basedep −concurrent-extradep −irc-conduitdep −irc-ctcpdep ~irc-client
Dependencies added: monad-control, signal, transformers-base
Dependencies removed: concurrent-extra, irc-conduit, irc-ctcp, lifted-base, text-format
Dependency ranges changed: irc-client
Files
- src/DCC.hs +22/−12
- src/IRC/Types.hs +4/−19
- src/Main.hs +11/−8
- src/XDCC.hs +45/−12
- src/ZNC.hs +23/−13
- xdcc.cabal +8/−7
src/DCC.hs view
@@ -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
src/IRC/Types.hs view
@@ -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 }
src/Main.hs view
@@ -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'
src/XDCC.hs view
@@ -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
src/ZNC.hs view
@@ -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
xdcc.cabal view
@@ -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 <https://github.com/JanGe/xdcc/blob/master/README.md>+ for usage instructions.+ . See <https://de.wikipedia.org/wiki/XDCC> 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