Hello community,
here is the log from the commit of package ghc-irc-dcc for openSUSE:Factory
checked in at 2017-04-17 10:25:32
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-irc-dcc (Old)
and /work/SRC/openSUSE:Factory/.ghc-irc-dcc.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-irc-dcc"
Mon Apr 17 10:25:32 2017 rev:2 rq:485137 version:2.0.1
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-irc-dcc/ghc-irc-dcc.changes 2017-03-08
00:58:43.652135636 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-irc-dcc.new/ghc-irc-dcc.changes
2017-04-17 10:25:45.162960246 +0200
@@ -1,0 +2,10 @@
+Mon Mar 27 12:41:56 UTC 2017 - psim...@suse.com
+
+- Update to version 2.0.1 with cabal2obs.
+
+-------------------------------------------------------------------
+Thu Sep 15 06:44:50 UTC 2016 - psim...@suse.com
+
+- Update to version 2.0.0 revision 0 with cabal2obs.
+
+-------------------------------------------------------------------
Old:
----
1.cabal
irc-dcc-1.2.1.tar.gz
New:
----
irc-dcc-2.0.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-irc-dcc.spec ++++++
--- /var/tmp/diff_new_pack.N4BkGQ/_old 2017-04-17 10:25:48.006557540 +0200
+++ /var/tmp/diff_new_pack.N4BkGQ/_new 2017-04-17 10:25:48.010556973 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-irc-dcc
#
-# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,26 +19,25 @@
%global pkg_name irc-dcc
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.2.1
+Version: 2.0.1
Release: 0
Summary: A DCC message parsing and helper library for IRC clients
License: MIT
-Group: System/Libraries
+Group: Development/Languages/Other
Url: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal
BuildRequires: ghc-Cabal-devel
-# Begin cabal-rpm deps:
BuildRequires: ghc-attoparsec-devel
BuildRequires: ghc-binary-devel
BuildRequires: ghc-bytestring-devel
-BuildRequires: ghc-errors-devel
BuildRequires: ghc-io-streams-devel
BuildRequires: ghc-iproute-devel
BuildRequires: ghc-irc-ctcp-devel
+BuildRequires: ghc-mtl-devel
BuildRequires: ghc-network-devel
BuildRequires: ghc-path-devel
BuildRequires: ghc-rpm-macros
+BuildRequires: ghc-safe-exceptions-devel
BuildRequires: ghc-transformers-devel
BuildRequires: ghc-utf8-string-devel
BuildRoot: %{_tmppath}/%{name}-%{version}-build
@@ -46,8 +45,8 @@
BuildRequires: ghc-hspec-attoparsec-devel
BuildRequires: ghc-tasty-devel
BuildRequires: ghc-tasty-hspec-devel
+BuildRequires: ghc-tasty-quickcheck-devel
%endif
-# End cabal-rpm deps
%description
DCC (Direct Client-to-Client) is an IRC sub-protocol for establishing and
@@ -68,22 +67,15 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
-
%build
%ghc_lib_build
-
%install
%ghc_lib_install
-
%check
-%if %{with tests}
-%{cabal} test
-%endif
-
+%cabal_test
%post devel
%ghc_pkg_recache
@@ -97,5 +89,6 @@
%files devel -f %{name}-devel.files
%defattr(-,root,root,-)
+%doc CHANGELOG.md
%changelog
++++++ irc-dcc-1.2.1.tar.gz -> irc-dcc-2.0.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/CHANGELOG.md
new/irc-dcc-2.0.1/CHANGELOG.md
--- old/irc-dcc-1.2.1/CHANGELOG.md 1970-01-01 01:00:00.000000000 +0100
+++ new/irc-dcc-2.0.1/CHANGELOG.md 2017-03-19 06:29:39.000000000 +0100
@@ -0,0 +1,3 @@
+# 2.0.1
+* Remove unused `errors` package from dependencies
+* Relax upper bounds for package `binary`
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/irc-dcc.cabal
new/irc-dcc-2.0.1/irc-dcc.cabal
--- old/irc-dcc-1.2.1/irc-dcc.cabal 2016-05-27 19:43:11.000000000 +0200
+++ new/irc-dcc-2.0.1/irc-dcc.cabal 2017-03-19 06:27:38.000000000 +0100
@@ -1,65 +1,67 @@
-name: irc-dcc
-version: 1.2.1
-synopsis: A DCC message parsing and helper library for IRC clients
-description: DCC (Direct Client-to-Client) is an IRC sub-protocol for
- establishing and maintaining direct connections to
- exchange messages and files.
- .
- See <http://www.irchelp.org/irchelp/rfc/ctcpspec.html>
for
- more details.
-license: MIT
-license-file: LICENSE
-homepage: https://github.com/JanGe/irc-dcc
-bug-reports: https://github.com/JanGe/irc-dcc/issues
-author: Jan Gerlinger
-maintainer: g...@jangerlinger.de
-category: Network
--- copyright:
-build-type: Simple
-cabal-version: >= 1.10
+name: irc-dcc
+version: 2.0.1
+synopsis: A DCC message parsing and helper library for IRC clients
+description: DCC (Direct Client-to-Client) is an IRC sub-protocol for
+ establishing and maintaining direct connections to
+ exchange messages and files.
+ .
+ See <http://www.irchelp.org/irchelp/rfc/ctcpspec.html> for
+ more details.
+license: MIT
+license-file: LICENSE
+extra-source-files: CHANGELOG.md
+homepage: https://github.com/JanGe/irc-dcc
+bug-reports: https://github.com/JanGe/irc-dcc/issues
+author: Jan Gerlinger
+maintainer: g...@jangerlinger.de
+category: Network
+copyright: 2016 Jan Gerlinger
+build-type: Simple
+cabal-version: >= 1.10
library
- hs-source-dirs: src
- exposed-modules: Network.IRC.DCC
- , Network.IRC.DCC.FileTransfer
- other-modules: Network.IRC.DCC.Internal
- , Network.Socket.ByteString.Extended
+ hs-source-dirs: src
+ exposed-modules: Network.IRC.DCC
+ , Network.IRC.DCC.Internal
+ , Network.IRC.DCC.Client.FileTransfer
+ other-modules: Network.Socket.ByteString.Extended
+ , System.IO.Streams.Lifted
-- other-extensions:
- build-depends: base >= 4.7 && < 5
- , attoparsec >= 0.13.0.1 && < 0.14
- , binary >= 0.7.5.0
- , bytestring >= 0.10.6.0 && < 0.11
- , errors >= 2.1.2 && < 2.2
- , io-streams >= 1.3.5.0 && < 1.4
- , iproute >= 1.7.0 && < 1.8
- , irc-ctcp >= 0.1.3.0 && < 0.2
- , network >= 2.6.2.1 && < 2.7
- , path >= 0.5.7 && < 0.6
- , transformers >= 0.4.2.0
- , utf8-string >= 1.0.1.1 && < 1.1
- default-language: Haskell2010
- ghc-options: -Wall -fno-warn-unused-do-bind
+ build-depends: base >= 4.8 && < 5
+ , attoparsec >= 0.13.0.1 && < 0.14
+ , binary >= 0.7.5.0 && < 0.10
+ , bytestring >= 0.10.6.0 && < 0.11
+ , io-streams >= 1.3.5.0 && < 1.4
+ , iproute >= 1.7.0 && < 1.8
+ , irc-ctcp >= 0.1.3.0 && < 0.2
+ , mtl >= 2.2.1 && < 2.3
+ , network >= 2.6.2.1 && < 2.7
+ , path >= 0.5.7 && < 0.6
+ , safe-exceptions >= 0.1.2.0 && < 0.2
+ , transformers >= 0.4.2.0 && < 0.6
+ , utf8-string >= 1.0.1.1 && < 1.1
+ default-language: Haskell2010
+ ghc-options: -Wall -fno-warn-unused-do-bind
-test-suite tests
- hs-source-dirs: tests
- , src
- main-is: Main.hs
- other-modules: Network.IRC.DCCTest
- , Network.IRC.DCC.Internal
- type: exitcode-stdio-1.0
- build-depends: base >= 4.7 && < 5
- , tasty >= 0.11.0.2 && < 0.12
- , tasty-hspec >= 1.1.2 && < 1.2
- , hspec-attoparsec >= 0.1.0.2 && < 0.2
- , attoparsec >= 0.13.0.1 && < 0.14
- , binary >= 0.7.5.0
- , bytestring >= 0.10.6.0 && < 0.11
- , iproute >= 1.7.0 && < 1.8
- , irc-ctcp >= 0.1.3.0 && < 0.2
- , network >= 2.6.2.1 && < 2.7
- , path >= 0.5.7 && < 0.6
- , utf8-string >= 1.0.1.1 && < 1.1
- default-language: Haskell2010
+test-suite irc-dcc-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Spec.hs
+ other-modules: Network.IRC.DCCTest
+ build-depends: base >= 4.8 && < 5
+ , bytestring >= 0.10.6.0 && < 0.11
+ , hspec-attoparsec >= 0.1.0.2 && < 0.2
+ , iproute >= 1.7.0 && < 1.8
+ , irc-dcc
+ , network >= 2.6.2.1 && < 2.7
+ , path >= 0.5.7 && < 0.6
+ , utf8-string >= 1.0.1.1 && < 1.1
+ , tasty >= 0.11.0.2 && < 0.12
+ , tasty-hspec >= 1.1.2 && < 1.2
+ , tasty-quickcheck >= 0.8.4 && < 0.9
+ ghc-options: -Wall -fno-warn-orphans
+ -threaded -rtsopts -with-rtsopts=-N
+ default-language: Haskell2010
source-repository head
type: git
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/irc-dcc-1.2.1/src/Network/IRC/DCC/Client/FileTransfer.hs
new/irc-dcc-2.0.1/src/Network/IRC/DCC/Client/FileTransfer.hs
--- old/irc-dcc-1.2.1/src/Network/IRC/DCC/Client/FileTransfer.hs
1970-01-01 01:00:00.000000000 +0100
+++ new/irc-dcc-2.0.1/src/Network/IRC/DCC/Client/FileTransfer.hs
2017-03-19 06:24:03.000000000 +0100
@@ -0,0 +1,136 @@
+{-# LANGUAGE RecordWildCards #-}
+
+{-| Functions for receiving files.
+
+ Each chunk is acknowledged by sending the total sum of bytes received for a
+ file. See the
+ <http://www.irchelp.org/irchelp/rfc/ctcpspec.html CTCP specification>.
+-}
+module Network.IRC.DCC.Client.FileTransfer (
+ -- * Start/resume DCC file transfer
+ acceptFile
+ , resumeFile
+ -- * Custom DCC file transfer
+ , FileTransfer(..)
+ , ConnectionType(..)
+ , TransferType(..)
+ , transfer
+ ) where
+
+import Network.IRC.DCC
+
+import Control.Exception.Safe
+import Control.Monad (unless)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ReaderT, ask)
+import Data.ByteString.Char8 (ByteString, length, null)
+import Network.Socket.ByteString.Extended (ConnectionType (..),
+ PortNumber, Socket, close,
+ connect, recv, sendAll,
+ toNetworkByteOrder)
+import qualified Path as P (File, Path, Rel,
+ fromRelFile)
+import Prelude hiding (length, null)
+import System.IO (BufferMode (NoBuffering),
IOMode (AppendMode, WriteMode))
+import System.IO.Streams (OutputStream, write)
+import System.IO.Streams.Lifted (withFileAsOutputExt)
+
+data TransferType = FromStart
+ | ResumeFrom !FileOffset
+
+-- | A description of a file transfer.
+-- You can specify a callback that will be called with the number of bytes
+-- transfered for each chunk.
+data FileTransfer m = Download { _fileName :: !(P.Path P.Rel P.File)
+ , _connectionType :: !(ConnectionType m)
+ , _transferType :: !TransferType
+ , _onChunk :: FileOffset -> m ()
+ }
+
+-- | Accept a DCC file offer
+acceptFile :: DccSend
+ -> (PortNumber -> IO ())
+ -- ^ Callback when socket is ready
+ -> (FileOffset -> IO ())
+ -- ^ Callback when a chunk of data was transfered
+ -> ReaderT (Maybe PortNumber) IO ()
+acceptFile = download FromStart
+
+-- | Accept a DCC file offer for a partially downloaded file
+resumeFile :: DccSend
+ -> DccAccept
+ -> (PortNumber -> IO ())
+ -- ^ Callback when socket is ready
+ -> (FileOffset -> IO ())
+ -- ^ Callback when a chunk of data was transferred
+ -> ReaderT (Maybe PortNumber) IO ()
+resumeFile offer accept
+ | accept `matchesSend` offer =
+ download (ResumeFrom pos) offer
+ | otherwise = fail "You mixed the DCC and Reverse DCC workflow when
calling 'resumeFile'."
+ where
+ pos = acceptedPosition accept
+
+download :: TransferType
+ -> DccSend
+ -> (PortNumber -> IO ())
+ -> (FileOffset -> IO ())
+ -> ReaderT (Maybe PortNumber) IO ()
+download tt (Send path ip port _) onListen onChunk =
+ lift $ transfer Download { _fileName = fromPath path
+ , _connectionType = Active ip port (onListen port)
+ , _transferType = tt
+ , _onChunk = onChunk
+ }
+download tt (SendReverseServer path ip _ _) onListen onChunk = do
+ port <- ask
+ lift $ transfer Download { _fileName = fromPath path
+ , _connectionType = Passive ip port onListen
+ , _transferType = tt
+ , _onChunk = onChunk
+ }
+
+transfer :: (MonadMask m, MonadIO m) => FileTransfer m -> m ()
+transfer Download {..} =
+ bracket (connect _connectionType)
+ (liftIO . close)
+ (streamToFile _fileName _transferType _onChunk)
+
+streamToFile :: (MonadMask m, MonadIO m)
+ => P.Path P.Rel P.File
+ -> TransferType
+ -> (FileOffset -> m ())
+ -- ^ Callback when a chunk of data was transfered
+ -> Socket
+ -> m ()
+streamToFile name tt onChunk =
+ withFileAsOutputExt (P.fromRelFile name) (mode tt) NoBuffering .
+ stream (pos tt) onChunk
+ where
+ mode FromStart = WriteMode
+ mode (ResumeFrom _) = AppendMode
+ pos FromStart = 0
+ pos (ResumeFrom p) = p
+
+stream :: (MonadMask m, MonadIO m)
+ => FileOffset
+ -> (FileOffset -> m ())
+ -> Socket
+ -> OutputStream ByteString
+ -> m ()
+stream pos onChunk sock h = do
+ buf <- liftIO $ recv sock (4096 * 1024)
+ unless (null buf) $ do
+ let len = fromIntegral $ length buf
+ onChunk len
+ let pos' = pos + len
+ sendPosition sock pos'
+ liftIO $ Just buf `write` h
+ stream pos' onChunk sock h
+
+sendPosition :: (MonadMask m, MonadIO m)
+ => Socket
+ -> FileOffset
+ -> m ()
+sendPosition sock = liftIO . sendAll sock . toNetworkByteOrder
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/src/Network/IRC/DCC/FileTransfer.hs
new/irc-dcc-2.0.1/src/Network/IRC/DCC/FileTransfer.hs
--- old/irc-dcc-1.2.1/src/Network/IRC/DCC/FileTransfer.hs 2016-04-13
20:54:00.000000000 +0200
+++ new/irc-dcc-2.0.1/src/Network/IRC/DCC/FileTransfer.hs 1970-01-01
01:00:00.000000000 +0100
@@ -1,85 +0,0 @@
-{-| Functions for receiving files.
-
- Each chunk is acknowledged by sending the total sum of bytes received for a
- file. See the
- <http://www.irchelp.org/irchelp/rfc/ctcpspec.html CTCP specification>.
--}
-module Network.IRC.DCC.FileTransfer
- ( acceptFile
- , resumeFile
- ) where
-
-import Network.IRC.DCC.Internal
-
-import Control.Error
-import Control.Monad (unless)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, ask)
-import Data.ByteString.Char8 (ByteString, length, null)
-import Network.Socket.ByteString.Extended
-import Path (File, Path, Rel,
- fromRelFile)
-import Prelude hiding (length, null)
-import System.IO (BufferMode (NoBuffering),
IOMode (AppendMode, WriteMode))
-import System.IO.Streams (OutputStream,
- withFileAsOutputExt,
write)
-
--- | Accept a DCC file offer
-acceptFile :: Integral a
- => OfferFile
- -> (PortNumber -> ExceptT String IO ())
- -- ^ Callback when socket is ready
- -> (a -> IO ())
- -- ^ Callback when a chunk of data was transfered
- -> ReaderT (Maybe PortNumber) (ExceptT String IO) ()
-acceptFile (OfferFile tt f) =
- download (fileName f) WriteMode 0 tt
-
--- | Accept a DCC file offer for a partially downloaded file
-resumeFile :: Integral a
- => AcceptResumeFile
- -> (PortNumber -> ExceptT String IO ())
- -- ^ Callback when socket is ready
- -> (a -> IO ())
- -- ^ Callback when a chunk of data was transfered
- -> ReaderT (Maybe PortNumber) (ExceptT String IO) ()
-resumeFile (AcceptResumeFile tt f pos) =
- download (fileName f) AppendMode (fromIntegral pos) tt
-
-download :: Integral a
- => Path Rel File
- -> IOMode
- -> a
- -> TransferType
- -> (PortNumber -> ExceptT String IO ())
- -- ^ Callback when socket is ready
- -> (a -> IO ())
- -- ^ Callback when a chunk of data was transfered
- -> ReaderT (Maybe PortNumber) (ExceptT String IO) ()
-download fn mode pos tt onListen onChunk = do
- localPort <- ask
- lift $
- withSocket tt localPort onListen $
- withFileAsOutputExt (fromRelFile fn) mode NoBuffering .
- stream pos onChunk
- where withSocket (Active i p) _ = withActiveSocket (Sink i p)
- withSocket (Passive i _) p = withPassiveSocket (Source i p)
-
-stream :: Integral a
- => a
- -> (a -> IO ())
- -> Socket
- -> OutputStream ByteString
- -> IO ()
-stream pos onChunk sock h =
- do buf <- recv sock (4096 * 1024)
- unless (null buf) $
- do let l = fromIntegral (length buf)
- onChunk l
- let pos' = pos + l
- sendPosition sock pos'
- Just buf `write` h
- stream pos' onChunk sock h
-
-sendPosition :: Integral a => Socket -> a -> IO ()
-sendPosition sock = sendAll sock . toNetworkByteOrder
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/src/Network/IRC/DCC/Internal.hs
new/irc-dcc-2.0.1/src/Network/IRC/DCC/Internal.hs
--- old/irc-dcc-1.2.1/src/Network/IRC/DCC/Internal.hs 2016-04-01
14:24:22.000000000 +0200
+++ new/irc-dcc-2.0.1/src/Network/IRC/DCC/Internal.hs 2016-08-21
18:21:49.000000000 +0200
@@ -3,115 +3,265 @@
module Network.IRC.DCC.Internal where
-import Control.Applicative
-import Control.Monad (when)
-import Data.Attoparsec.ByteString.Char8
-import Data.Binary (byteSwap32)
-import Data.ByteString.Char8 (ByteString, pack)
-import qualified Data.ByteString.UTF8 as UTF8 (toString)
-import Data.IP (IPv4, fromHostAddress,
- toHostAddress)
-import Data.Monoid ((<>))
-import Data.Word (Word64)
-import Network.IRC.CTCP (CTCPByteString, decodeCTCP,
- encodeCTCP)
-import Network.Socket (PortNumber)
-import Path (File, Path, Rel, filename,
- fromRelFile, parseAbsFile,
- parseRelFile)
-
--- | Type of DCC service offered
-data Service
- -- | Offer chat session
- = Messaging OpenChat
- -- | Offer file transfer
- | FileTransfer OfferFile
- deriving (Eq, Show)
+import Control.Applicative ((<|>))
+import Control.Monad (when)
+import Data.Attoparsec.ByteString.Char8 (Parser, choice, decimal,
+ endOfInput, parseOnly,
+ space, takeByteString,
+ takeWhile1)
+import Data.Binary (byteSwap32)
+import Data.ByteString.Char8 (ByteString, pack, unwords)
+import qualified Data.ByteString.UTF8 as UTF8 (fromString,
+ toString)
+import Data.IP (IPv4, fromHostAddress,
+ toHostAddress)
+import Data.Monoid ((<>))
+import Data.Word (Word64)
+import Network.IRC.CTCP (CTCPByteString,
decodeCTCP,
+ encodeCTCP)
+import Network.Socket.ByteString.Extended (PortNumber)
+import qualified Path as P (Abs, File, Path, Rel,
+ filename,
fromAbsFile,
+ fromRelFile,
+ parseAbsFile,
+ parseRelFile)
+import Prelude hiding (abs, unwords)
+
+-- | CTCP commands that can be parsed and encoded
+class CtcpCommand a where
+ toCtcp :: a -> CTCPByteString
+ fromCtcp :: CTCPByteString -> Either String a
+
+parseCtcp :: Parser a -> CTCPByteString -> Either String a
+parseCtcp p = parseOnly (p <* endOfInput) . decodeCTCP
--- | Type of DCC chat to open
-data OpenChat
+-- | Offer DCC chat session
+data DccChat
{-| Text messages exchange
> DCC CHAT chat <ip> <port>
-}
- = Chat IPv4 PortNumber
+ = Chat !IPv4 !PortNumber
{-| Drawing commands exchange
> DCC CHAT wboard <ip> <port>
-}
- | Whiteboard IPv4 PortNumber
+ | ChatWhiteboard !IPv4 !PortNumber
deriving (Eq, Show)
+instance CtcpCommand DccChat where
+ toCtcp (Chat ip port) = encodeCTCP $ unwords
+ [ "DCC CHAT chat"
+ , socketToBS (ip, port)
+ ]
+ toCtcp (ChatWhiteboard ip port) = encodeCTCP $ unwords
+ [ "DCC CHAT wboard"
+ , socketToBS (ip, port)
+ ]
+
+ fromCtcp = parseCtcp $
+ Chat
+ <$> ("DCC CHAT chat" *> spaced ipBigEndian)
+ <*> spaced tcpPort
+ <|> ChatWhiteboard
+ <$> ("DCC CHAT wboard" *> spaced ipBigEndian)
+ <*> spaced tcpPort
+
-- | Signal intent to close DCC chat connection
-data CloseChat
+data DccClose
-- | > DCC CLOSE
- = CloseChat
+ = Close
deriving (Eq, Show)
--- | DCC file transfer instructions
-data OfferFile
- {-| DCC:
-
- > DCC SEND <fileName> <ip> <port> (<fileSize>)
+instance CtcpCommand DccClose where
+ toCtcp Close = encodeCTCP "DCC CLOSE"
+ fromCtcp = parseCtcp $ Close <$ "DCC CLOSE"
+
+-- | Offer DCC file transfer
+data DccSend
+ {-| As part of the standard DCC protocol, sent by the server
- Reverse DCC:
+ > DCC SEND <path> <ip> <port> (<fileSize>)
+ -}
+ = Send !Path !IPv4 !PortNumber !(Maybe FileOffset)
+ {-| As part of the Reverse DCC protocol, sent by the server
- > DCC SEND <fileName> <ip> 0 <fileSize> <token>
+ > DCC SEND <path> <ip> 0 <fileSize> <token>
-}
- = OfferFile TransferType FileMetadata
+ | SendReverseServer !Path !IPv4 !FileOffset !Token
deriving (Eq, Show)
--- | Signal intent to resume DCC file transfer at specific position
-data TryResumeFile
- {-| DCC:
+instance CtcpCommand DccSend where
+ toCtcp (Send name ip port size) = encodeCTCP $ unwords
+ [ "DCC SEND"
+ , pathToBS name
+ , ipToBigEndianBS ip
+ , tcpPortToBS port ]
+ <> maybe "" ((" " <>) . fileOffsetToBS) size
+ toCtcp (SendReverseServer name ip size t) = encodeCTCP $ unwords
+ [ "DCC SEND"
+ , pathToBS name
+ , ipToBigEndianBS ip
+ , "0"
+ , fileOffsetToBS size
+ , tokenToBS t
+ ]
+
+ fromCtcp = parseCtcp $
+ Send
+ <$> ("DCC SEND" *> spaced path)
+ <*> spaced ipBigEndian
+ <*> spaced tcpPort
+ <*> (Just <$> spaced fileOffset
+ <|> return Nothing)
+ <|> SendReverseServer
+ <$> ("DCC SEND" *> spaced path)
+ <*> spaced ipBigEndian
+ <*> (spaced "0" *> spaced fileOffset)
+ <*> spaced token
- > DCC RESUME <fileName> <port> <position>
+-- | Signal intent to resume DCC file transfer at specific position
+data DccResume
+ {-| As part of the standard DCC protocol, sent by the client
- Reverse DCC:
+ > DCC RESUME <path> <port> <position>
+ -}
+ = Resume !Path !PortNumber !FileOffset
+ {-| As part of the Reverse DCC protocol, sent by the client
- > DCC RESUME <fileName> 0 <position> <token>
- -}
- = TryResumeFile TransferType FileMetadata FileOffset
+ > DCC RESUME <path> 0 <position> <token>
+ -}
+ | ResumeReverse !Path !FileOffset !Token
deriving (Eq, Show)
--- | Signal acceptance to resume DCC file transfer at specific position
-data AcceptResumeFile
- {-| DCC:
+instance CtcpCommand DccResume where
+ toCtcp (Resume name port pos) = encodeCTCP $ unwords
+ [ "DCC RESUME"
+ , pathToBS name
+ , tcpPortToBS port
+ , fileOffsetToBS pos
+ ]
+ toCtcp (ResumeReverse name pos t) = encodeCTCP $ unwords
+ [ "DCC RESUME"
+ , pathToBS name
+ , "0"
+ , fileOffsetToBS pos
+ , tokenToBS t
+ ]
+
+ fromCtcp = parseCtcp $
+ Resume
+ <$> ("DCC RESUME" *> spaced path)
+ <*> spaced tcpPort
+ <*> spaced fileOffset
+ <|> ResumeReverse
+ <$> ("DCC RESUME" *> spaced path)
+ <*> (spaced "0" *> spaced fileOffset)
+ <*> spaced token
- > DCC ACCEPT <fileName> <port> <position>
+-- | Signal acceptance to resume DCC file transfer at specific position
+data DccAccept
+ {-| As part of the standard DCC protocol, sent by the server
- Reverse DCC:
+ > DCC ACCEPT <path> <port> <position>
+ -}
+ = Accept !Path !PortNumber !FileOffset
+ {-| As part of the Reverse DCC protocol, sent by the server
- > DCC ACCEPT <fileName> 0 <position> <token>
+ > DCC ACCEPT <path> 0 <position> <token>
-}
- = AcceptResumeFile TransferType FileMetadata FileOffset
+ | AcceptReverse !Path !FileOffset !Token
deriving (Eq, Show)
--- | Signal readiness to accept a connection (only Reverse DCC)
-data OfferFileSink
- {-| Reverse DCC:
+acceptedPosition :: DccAccept -> FileOffset
+acceptedPosition (Accept _ _ pos) = pos
+acceptedPosition (AcceptReverse _ pos _) = pos
+
+instance CtcpCommand DccAccept where
+ toCtcp (Accept name port pos) = encodeCTCP $ unwords
+ [ "DCC ACCEPT"
+ , pathToBS name
+ , tcpPortToBS port
+ , fileOffsetToBS pos
+ ]
+ toCtcp (AcceptReverse name pos t) = encodeCTCP $ unwords
+ [ "DCC ACCEPT"
+ , pathToBS name
+ , "0"
+ , fileOffsetToBS pos
+ , tokenToBS t
+ ]
+
+ fromCtcp = parseCtcp $
+ Accept
+ <$> ("DCC ACCEPT" *> spaced path)
+ <*> spaced tcpPort
+ <*> spaced fileOffset
+ <|> AcceptReverse
+ <$> ("DCC ACCEPT" *> spaced path)
+ <*> (spaced "0" *> spaced fileOffset)
+ <*> spaced token
+
+-- | Tell the server to start a DCC file transfer and where it should send the
data to.
+data DccSendReverseClient
+ {-| As part of the Reverse DCC protocol, sent by the client
- > DCC SEND <fileName> <ip> <port> <fileSize> <token>
+ > DCC SEND <path> <ip> <port> <fileSize> <token>
-}
- = OfferFileSink Token FileMetadata IPv4 PortNumber
+ = SendReverseClient !Path !IPv4 !PortNumber !FileOffset !Token
deriving (Eq, Show)
--- | Type of a DCC file transfer connection
-data TransferType
- -- | Connection where the owner of the file offers a socket to connect to
- = Active IPv4 PortNumber
- -- | Connection where the recipient of the file offers a socket to connect to
- | Passive IPv4 Token
+instance CtcpCommand DccSendReverseClient where
+ toCtcp (SendReverseClient name ip port size t) = encodeCTCP $ unwords
+ [ "DCC SEND"
+ , pathToBS name
+ , ipToBigEndianBS ip
+ , tcpPortToBS port
+ , fileOffsetToBS size
+ , tokenToBS t
+ ]
+
+ fromCtcp = parseCtcp $
+ SendReverseClient
+ <$> ("DCC SEND" *> spaced path)
+ <*> spaced ipBigEndian
+ <*> spaced tcpPort
+ <*> spaced fileOffset
+ <*> spaced token
+
+data PathType
+ = Simple
+ -- ^ A file path without spaces
+ | Quoted
+ -- ^ A file path that can include spaces and will be quoted when serialized
deriving (Eq, Show)
--- | Properties of a file
-data FileMetadata = FileMetadata { fileName :: Path Rel File
- , fileSize :: Maybe FileOffset }
+data Path = Rel PathType (P.Path P.Rel P.File)
+ | Abs PathType (P.Path P.Abs P.File)
deriving (Eq, Show)
--- | An identifier for knowing which negotiation a request belongs to
-newtype Token = Token ByteString
- deriving (Eq, Show)
+fromPath :: Path -> P.Path P.Rel P.File
+fromPath (Rel _ name) = name
+fromPath (Abs _ name) = P.filename name
+
+path :: Parser Path
+path = choice [ quoted >>= parseRelOrAbs Quoted
+ , simple >>= parseRelOrAbs Simple ]
+ where
+ quoted = UTF8.toString <$> ("\"" *> takeWhile1 (/= '"') <* "\"")
+ simple = UTF8.toString <$> takeWhile1 (/= ' ')
+ parseRelOrAbs ty n =
+ maybe (fail "Could not parse file name.") return
+ ( Rel ty <$> P.parseRelFile n
+ <|> Abs ty <$> P.parseAbsFile n )
+
+pathToBS :: Path -> ByteString
+pathToBS (Rel ty name) = wrap ty . UTF8.fromString . P.fromRelFile $ name
+pathToBS (Abs ty name) = wrap ty . UTF8.fromString . P.fromAbsFile $ name
+
+wrap :: PathType -> ByteString -> ByteString
+wrap Simple p = p
+wrap Quoted p = "\"" <> p <> "\""
newtype FileOffset = FileOffset { toWord :: Word64 }
deriving (Eq, Ord, Num, Integral, Enum, Real, Bounded)
@@ -119,260 +269,53 @@
instance Show FileOffset where
show = show . toWord
--- | Class for types that can be sent as CTCP commands
-class CtcpCommand a where
- encodeCtcp :: a -> CTCPByteString
+fileOffset :: Parser FileOffset
+fileOffset = FileOffset <$> decimal
-instance CtcpCommand ByteString where
- encodeCtcp = encodeCTCP
+fileOffsetToBS :: FileOffset -> ByteString
+fileOffsetToBS = pack . show . toWord
-instance CtcpCommand OpenChat where
- encodeCtcp = encodeCtcp . encodeOpenChat
+-- | An identifier for knowing which negotiation a request belongs to
+newtype Token = Token ByteString
+ deriving (Eq, Show)
-instance CtcpCommand CloseChat where
- encodeCtcp = encodeCtcp . encodeChatClose
-
-instance CtcpCommand OfferFile where
- encodeCtcp = encodeCtcp . encodeOfferFile
-
-instance CtcpCommand TryResumeFile where
- encodeCtcp = encodeCtcp . encodeTryResumeFile
-
-instance CtcpCommand AcceptResumeFile where
- encodeCtcp = encodeCtcp . encodeAcceptResume
-
-instance CtcpCommand OfferFileSink where
- encodeCtcp = encodeCtcp . encodeOfferFileSink
-
-runParser :: Parser a -> CTCPByteString -> Either String a
-runParser p = parseOnly p . decodeCTCP
-
-parseService :: Parser Service
-parseService = Messaging <$> parseOpenChat
- <|> FileTransfer <$> parseOfferFile
-
-encodeService :: Service -> ByteString
-encodeService (Messaging m) = encodeOpenChat m
-encodeService (FileTransfer o) = encodeOfferFile o
-
-parseOpenChat :: Parser OpenChat
-parseOpenChat = choice [ do "DCC CHAT chat "
- (i, p) <- parseSocket
- endOfInput
- return $ Chat i p
- , do "DCC CHAT wboard "
- (i, p) <- parseSocket
- endOfInput
- return $ Whiteboard i p
- ]
-
-encodeOpenChat :: OpenChat -> ByteString
-encodeOpenChat (Chat i p) = "DCC CHAT chat " <> encodeSocket (i, p)
-encodeOpenChat (Whiteboard i p) = "DCC CHAT wboard " <> encodeSocket (i, p)
-
-parseCloseChat :: Parser CloseChat
-parseCloseChat = do "DCC CLOSE"
- endOfInput
- return CloseChat
-
-encodeChatClose :: CloseChat -> ByteString
-encodeChatClose _ = "DCC CLOSE"
-
-parseOfferFile :: Parser OfferFile
-parseOfferFile =
- do "DCC SEND "
- fn <- parseFileName
- space
- i <- parseIpBigEndian
- space
- choice [ do p <- parseTcpPort
- fs <- Just <$> (space *> parseFileOffset)
- <|> return Nothing
- endOfInput
- return (OfferFile
- (Active i p)
- (FileMetadata fn fs))
- , do "0"
- space
- fs <- parseFileOffset
- space
- t <- parseToken
- endOfInput
- return (OfferFile
- (Passive i t)
- (FileMetadata fn (Just fs)))
- ]
-
-encodeOfferFile :: OfferFile -> ByteString
-encodeOfferFile (OfferFile (Active i p) (FileMetadata fn fs)) =
- "DCC SEND "
- <> encodeFileName fn
- <> " " <> encodeIpBigEndian i
- <> " " <> encodeTcpPort p
- <> appendSpacedIfJust (encodeFileOffset <$> fs)
-encodeOfferFile (OfferFile (Passive i t) (FileMetadata fn fs)) =
- "DCC SEND "
- <> encodeFileName fn
- <> " " <> encodeIpBigEndian i
- <> " 0"
- <> appendSpacedIfJust (encodeFileOffset <$> fs)
- <> " " <> encodeToken t
-
-parseTryResumeFile :: OfferFile -> Parser TryResumeFile
-parseTryResumeFile (OfferFile tt f) =
- do "DCC RESUME"
- space
- fn' <- parseFileName
- when (fn' /= fileName f) $
- fail "File name for resume didn't match file name in offer."
- space
- pos <- case tt of
- Active _ p -> do
- string (encodeTcpPort p)
- space
- parseFileOffset
- Passive _ t -> do
- "0"
- space
- pos <- parseFileOffset
- space
- string (encodeToken t)
- return pos
- endOfInput
- return (TryResumeFile tt f pos)
-
-
-encodeTryResumeFile :: TryResumeFile -> ByteString
-encodeTryResumeFile (TryResumeFile (Active _ p) (FileMetadata fn _) pos) =
- "DCC RESUME "
- <> encodeFileName fn
- <> " " <> encodeTcpPort p
- <> " " <> encodeFileOffset pos
-encodeTryResumeFile (TryResumeFile (Passive _ t) (FileMetadata fn _) pos) =
- "DCC RESUME "
- <> encodeFileName fn
- <> " 0 "
- <> encodeFileOffset pos
- <> " " <> encodeToken t
-
-parseAcceptResumeFile :: TryResumeFile -> Parser AcceptResumeFile
-parseAcceptResumeFile (TryResumeFile tt f _) =
- do "DCC ACCEPT "
- fn' <- parseFileName
- when (fn' /= fileName f) $
- fail "File name for accepting resume didn't match file name in offer."
- space
- ackPos <- case tt of
- Active _ p -> do
- string (encodeTcpPort p)
- space
- parseFileOffset
- Passive _ t -> do
- "0"
- space
- ackPos <- parseFileOffset
- space
- string (encodeToken t)
- return ackPos
- endOfInput
- return (AcceptResumeFile tt f ackPos)
-
-encodeAcceptResume :: AcceptResumeFile -> ByteString
-encodeAcceptResume (AcceptResumeFile (Active _ p) (FileMetadata fn _) pos) =
- "DCC ACCEPT "
- <> encodeFileName fn
- <> " " <> encodeTcpPort p
- <> " " <> encodeFileOffset pos
-encodeAcceptResume (AcceptResumeFile (Passive _ t) (FileMetadata fn _) pos) =
- "DCC ACCEPT "
- <> encodeFileName fn
- <> " 0 "
- <> encodeFileOffset pos
- <> " " <> encodeToken t
-
-parseOfferFileSink :: AcceptResumeFile -> Parser (Maybe OfferFileSink)
-parseOfferFileSink (AcceptResumeFile (Passive _ t) f _) =
- do "DCC SEND "
- fn <- parseFileName
- when (fn /= fileName f) $
- fail "File name for accepting resume didn't match file name in offer."
- space
- (i, p) <- parseSocket
- string (appendSpacedIfJust (encodeFileOffset <$> fileSize f))
- space
- string (encodeToken t)
- endOfInput
- return (Just (OfferFileSink t f i p))
-parseOfferFileSink _ = return Nothing
-
-encodeOfferFileSink :: OfferFileSink -> ByteString
-encodeOfferFileSink (OfferFileSink t (FileMetadata fn fs) i p) =
- "DCC SEND "
- <> encodeFileName fn
- <> " " <> encodeSocket (i, p)
- <> appendSpacedIfJust (encodeFileOffset <$> fs)
- <> " " <> encodeToken t
-
-parseSocket :: Parser (IPv4, PortNumber)
-parseSocket =
- do i <- parseIpBigEndian
- space
- p <- parseTcpPort
- return (i, p)
-
-encodeSocket :: (IPv4, PortNumber) -> ByteString
-encodeSocket (i, p) = encodeIpBigEndian i <> " " <> encodeTcpPort p
-
-parseFileName :: Parser (Path Rel File)
-parseFileName = do name <- "\"" *> takeWhile1 (/= '"') <* "\""
- <|> takeWhile1 (/= ' ')
- case parseRelOrAbs (UTF8.toString name) of
- Nothing -> fail "Could not parse file name."
- Just path -> return path
- where parseRelOrAbs n = parseRelFile n
- <|> filename <$> parseAbsFile n
-
-encodeFileName :: Path Rel File -> ByteString
-encodeFileName = pack . fromRelFile
-
-parseIpBigEndian :: Parser IPv4
-parseIpBigEndian = fromBigEndianIp <$> parseBoundedInteger 0 4294967295
-
-encodeIpBigEndian :: IPv4 -> ByteString
-encodeIpBigEndian = pack . show . toBigEndianIp
-
-parseTcpPort :: Parser PortNumber
-parseTcpPort = fromInteger <$> parseBoundedInteger 1 65535
-
-encodeTcpPort :: PortNumber -> ByteString
-encodeTcpPort = pack . show
-
-parseFileOffset :: Parser FileOffset
-parseFileOffset = FileOffset <$> decimal
-
-encodeFileOffset :: FileOffset -> ByteString
-encodeFileOffset = pack . show . toWord
+token :: Parser Token
+token = Token <$> takeByteString
-parseToken :: Parser Token
-parseToken = Token <$> takeByteString
+tokenToBS :: Token -> ByteString
+tokenToBS (Token t) = t
-encodeToken :: Token -> ByteString
-encodeToken (Token t) = t
+socket :: Parser (IPv4, PortNumber)
+socket = (,) <$> ipBigEndian <* space <*> tcpPort
-parseBoundedInteger :: Integer -> Integer -> Parser Integer
-parseBoundedInteger lower upper = do
- num <- decimal
- when (num < lower || num > upper) $
- fail ("Failed to parse " ++ show num ++ ", not in range [" ++
- show lower ++ ", " ++ show upper ++ "].")
- return num
+socketToBS :: (IPv4, PortNumber) -> ByteString
+socketToBS (i, p) = ipToBigEndianBS i <> " " <> tcpPortToBS p
-appendSpacedIfJust :: Maybe ByteString -> ByteString
-appendSpacedIfJust (Just x) = " " <> x
-appendSpacedIfJust Nothing = mempty
+ipBigEndian :: Parser IPv4
+ipBigEndian = fromBigEndianIp <$> decimalInRange (0, 4294967295)
+
+ipToBigEndianBS :: IPv4 -> ByteString
+ipToBigEndianBS = pack . show . toBigEndianIp
fromBigEndianIp :: Integer -> IPv4
fromBigEndianIp = fromHostAddress . byteSwap32 . fromIntegral
toBigEndianIp :: IPv4 -> Integer
toBigEndianIp = fromIntegral . byteSwap32 . toHostAddress
+
+tcpPort :: Parser PortNumber
+tcpPort = fromInteger <$> decimalInRange (1, 65535)
+
+tcpPortToBS :: PortNumber -> ByteString
+tcpPortToBS = pack . show
+
+decimalInRange :: (Integer, Integer) -> Parser Integer
+decimalInRange (lower, upper) = do
+ num <- decimal
+ when (num < lower || num > upper) $
+ fail ( "Failed to parse " ++ show num ++ ", not in range ["
+ ++ show lower ++ ", " ++ show upper ++ "]." )
+ return num
+
+spaced :: Parser a -> Parser a
+spaced = (space *>)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/src/Network/IRC/DCC.hs
new/irc-dcc-2.0.1/src/Network/IRC/DCC.hs
--- old/irc-dcc-1.2.1/src/Network/IRC/DCC.hs 2016-03-29 17:48:10.000000000
+0200
+++ new/irc-dcc-2.0.1/src/Network/IRC/DCC.hs 2016-08-21 18:21:49.000000000
+0200
@@ -1,40 +1,54 @@
{-| DCC command parsing and encoding module.
- Example of parsing an offer file command:
+ Use the 'CtcpCommand' type class to convert between 'CTCPByteString's
+ and typed values.
- > runParser parseOfferFile ctcpMessage
+ Try converting a 'CTCPByteString' to a 'DccSend' value:
- Example of encoding an offer file command:
+ > fromCtcp ctcpMessage :: Either String DccSend
- > encodeCtcp offerFile
+ Encoding a 'DccSend' value to a 'CTCPByteString':
+
+ > toCtcp (Send fileName ip port (Just fileSize))
-}
module Network.IRC.DCC (
- -- * Types
- -- ** DCC service
+ -- * DCC command parsing and encoding
CtcpCommand(..)
- , Service(..)
+ -- * DCC command types
-- ** Messaging commands (DCC CHAT)
- , OpenChat(..)
- , CloseChat(..)
+ , DccChat(..)
+ , DccClose(..)
-- ** File Transfer commands (DCC SEND)
- , OfferFile(..)
- , TryResumeFile(..)
- , AcceptResumeFile(..)
- , OfferFileSink(..)
- -- *** Helper Types
- , TransferType(..)
- , FileMetadata(..)
- , Token(..)
+ , DccSend(..)
+ , DccResume(..)
+ , DccAccept(..)
+ , acceptedPosition
+ , DccSendReverseClient(..)
+ -- *** Constructors from other commands
+ , resumeFromSend
+ -- *** Protocol variant checks
+ , matchesSend
+ -- ** Helper Types
+ , Path(..)
+ , fromPath
+ , PathType(..)
, FileOffset
- -- * DCC command parsing
- , runParser
- , parseService
- , parseOpenChat
- , parseCloseChat
- , parseOfferFile
- , parseTryResumeFile
- , parseAcceptResumeFile
- , parseOfferFileSink
+ , Token(..)
) where
-import Network.IRC.DCC.Internal
+import Network.IRC.DCC.Internal
+
+-- | Try resuming a file offer
+resumeFromSend :: DccSend -> FileOffset -> DccResume
+resumeFromSend (Send path' _ port _) pos =
+ Resume path' port pos
+resumeFromSend (SendReverseServer path' _ _ token') pos =
+ ResumeReverse path' pos token'
+
+-- | Check if a 'DccSend' and a 'DccAccept' command are part of the same
negotiation.
+matchesSend :: DccAccept -> DccSend -> Bool
+matchesSend (Accept pathA portA _) (Send pathS _ portS _) =
+ pathS == pathA && portS == portA
+matchesSend (AcceptReverse pathA _ tokenA) (SendReverseServer pathS _ _
tokenS) =
+ pathS == pathA && tokenS == tokenA
+matchesSend _ _ = False
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/irc-dcc-1.2.1/src/Network/Socket/ByteString/Extended.hs
new/irc-dcc-2.0.1/src/Network/Socket/ByteString/Extended.hs
--- old/irc-dcc-1.2.1/src/Network/Socket/ByteString/Extended.hs 2016-05-10
15:08:33.000000000 +0200
+++ new/irc-dcc-2.0.1/src/Network/Socket/ByteString/Extended.hs 2016-08-21
18:21:49.000000000 +0200
@@ -1,77 +1,85 @@
-- | Common functions simplyfing the use of "Network.Socket.ByteString"
module Network.Socket.ByteString.Extended
- ( module Network.Socket
- , module Network.Socket.ByteString
- , Sink(..)
- , Source(..)
- , withActiveSocket
- , withPassiveSocket
+ ( ConnectionType(..)
+ , Socket(..)
+ , S.PortNumber
+ , connect
+ , close
+ , recv
+ , sendAll
, toNetworkByteOrder
) where
-import Control.Error
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Binary.Put (putWord32be, runPut)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as Lazy (toStrict)
-import Data.IP (IPv4, fromHostAddress,
- toHostAddress)
-import Network.Socket hiding (recv, recvFrom, send,
- sendTo)
-import Network.Socket.ByteString
-import System.Timeout
-
-data Sink = Sink IPv4 PortNumber
-
-data Source = Source IPv4 (Maybe PortNumber)
-
--- | Run functions on socket when connected and close socket afterwards
-withActiveSocket :: Sink
- -> (PortNumber -> ExceptT String IO ())
- -- ^ Callback when socket is ready
- -> (Socket -> IO ())
- -- ^ Callback when socket is connected to server
- -> ExceptT String IO ()
-withActiveSocket (Sink i p) onListen onConnected = do
- liftIO $ return withSocketsDo
- sock <- liftIO $ socket AF_INET Stream defaultProtocol
- onListen p
- liftIO $ connect sock (SockAddrInet p (toHostAddress i))
- liftIO $ onConnected sock
- liftIO $ sClose sock
-
-{- | Run functions on passive socket when listening and when connected and
close
- socket afterwards.
--}
-withPassiveSocket :: Source
- -> (PortNumber -> ExceptT String IO ())
- -- ^ Callback when socket is open and listening
- -> (Socket -> IO ())
- -- ^ Callback when client connected to socket
- -> ExceptT String IO ()
-withPassiveSocket (Source i maybeP) onListen onConnected = do
- liftIO $ return withSocketsDo
- sock <- liftIO $ openListenSocket (fromMaybe aNY_PORT maybeP)
- p <- liftIO $ socketPort sock
- onListen p
- accepted <- liftIO $ timeout 10000000 $ accept sock
+import Data.IP (IPv4, toHostAddress)
+import Data.Maybe (fromMaybe)
+import qualified Network.Socket as S hiding (recv, recvFrom, send,
+ sendTo)
+import qualified Network.Socket.ByteString as S
+
+data ConnectionType m
+ = Active !IPv4 !S.PortNumber (m ())
+ -- ^ Connects to other party on specified port. With callback when socket is
ready.
+ | Passive !IPv4 !(Maybe S.PortNumber) (S.PortNumber -> m ())
+ -- ^ Binds to local port and waits for connection by other party. If no port
number
+ -- is provided, one will be provided by the OS. With callback when socket is
ready.
+
+data Socket
+ = ActiveSocket !S.Socket
+ | PassiveSocket !S.Socket !S.PortNumber
+
+socket :: Socket -> S.Socket
+socket (ActiveSocket sock) = sock
+socket (PassiveSocket sock _) = sock
+
+connect :: MonadIO m => ConnectionType m -> m Socket
+connect (Active ip port onListen) = do
+ sock <- liftIO $ connectTo ip port
+ onListen
+ liftIO $ waitForConnection ip sock
+connect (Passive ip maybePort onListen) = do
+ sock@(PassiveSocket _ port) <- liftIO $ listenOn maybePort
+ onListen port
+ liftIO $ waitForConnection ip sock
+
+close :: Socket -> IO ()
+close = S.close . socket
+
+recv :: Socket -> Int -> IO ByteString
+recv = S.recv . socket
+
+sendAll :: Socket -> ByteString -> IO ()
+sendAll = S.sendAll . socket
+
+connectTo :: IPv4 -> S.PortNumber -> IO Socket
+connectTo ip port = S.withSocketsDo $ do
+ sock <- S.socket S.AF_INET S.Stream S.defaultProtocol
+ S.connect sock (S.SockAddrInet port (toHostAddress ip))
+ return $ ActiveSocket sock
+
+listenOn :: Maybe S.PortNumber -> IO Socket
+listenOn port = S.withSocketsDo $ do
+ sock <- openListenSocket (fromMaybe S.aNY_PORT port)
+ port' <- S.socketPort sock
+ return $ PassiveSocket sock port'
+
+waitForConnection :: IPv4 -> Socket -> IO Socket
+waitForConnection _ sock@(ActiveSocket _) = return sock -- Already
connected
+waitForConnection ip (PassiveSocket sock port) = do
+ accepted <- S.accept sock
case accepted of
- Just (con, SockAddrInet _ client)
- | client == toHostAddress i -> liftIO $ do onConnected con
- sClose con
- | otherwise -> do liftIO $ sClose con
- throwE ( "Expected connection from host "
- ++ show (fromHostAddress client)
- ++ ", not from " ++ show i ++". Aborting…\n" )
- _ -> throwE ( "Timeout when waiting for other party to connect on port "
- ++ show p ++ "…\n")
- liftIO $ sClose sock
+ (con, S.SockAddrInet _ client)
+ | client == toHostAddress ip -> return $ PassiveSocket con port
+ _ -> fail ( "Connection did not come from " ++ show ip ++ " as
expected." )
-openListenSocket :: PortNumber -> IO Socket
+openListenSocket :: S.PortNumber -> IO S.Socket
openListenSocket p = do
- sock <- socket AF_INET Stream defaultProtocol
- bind sock (SockAddrInet p iNADDR_ANY)
- listen sock 1
+ sock <- S.socket S.AF_INET S.Stream S.defaultProtocol
+ S.bind sock (S.SockAddrInet p S.iNADDR_ANY)
+ S.listen sock 1
return sock
-- | Converts numbers to a '32bit unsigned int' in network byte order.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/src/System/IO/Streams/Lifted.hs
new/irc-dcc-2.0.1/src/System/IO/Streams/Lifted.hs
--- old/irc-dcc-1.2.1/src/System/IO/Streams/Lifted.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/irc-dcc-2.0.1/src/System/IO/Streams/Lifted.hs 2016-08-21
18:21:49.000000000 +0200
@@ -0,0 +1,32 @@
+-- | Some functions generalized from "System.IO.Streams"
+module System.IO.Streams.Lifted
+ ( withBinaryFile
+ , withFileAsOutputExt
+ ) where
+
+import Control.Exception.Safe (MonadMask, bracket)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.ByteString.Char8 (ByteString)
+import System.IO (BufferMode, Handle, IOMode, hClose,
+ hSetBuffering, openBinaryFile)
+import System.IO.Streams (OutputStream, handleToOutputStream)
+
+withBinaryFile :: (MonadMask m, MonadIO m)
+ => FilePath
+ -> IOMode
+ -> (Handle -> m a)
+ -> m a
+withBinaryFile name mode =
+ bracket (liftIO $ openBinaryFile name mode)
+ (liftIO . hClose)
+
+withFileAsOutputExt :: (MonadMask m, MonadIO m)
+ => FilePath
+ -> IOMode
+ -> BufferMode
+ -> (OutputStream ByteString -> m a)
+ -> m a
+withFileAsOutputExt name mode buffermode f =
+ withBinaryFile name mode $ \h -> do
+ liftIO $ hSetBuffering h buffermode
+ liftIO (handleToOutputStream h) >>= f
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/test/Network/IRC/DCCTest.hs
new/irc-dcc-2.0.1/test/Network/IRC/DCCTest.hs
--- old/irc-dcc-1.2.1/test/Network/IRC/DCCTest.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/irc-dcc-2.0.1/test/Network/IRC/DCCTest.hs 2016-08-21
18:21:49.000000000 +0200
@@ -0,0 +1,166 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Network.IRC.DCCTest where
+
+import Network.IRC.DCC.Internal
+
+import Control.Monad (replicateM)
+import Data.ByteString.Char8 (pack)
+import Data.IP (IPv4, toIPv4)
+import Network.Socket (PortNumber)
+import Path (mkAbsFile, mkRelFile)
+import Test.Hspec.Attoparsec
+import Test.Tasty (TestTree)
+import Test.Tasty.Hspec (describe, it, testSpec)
+import Test.Tasty.QuickCheck (Arbitrary (..), Gen, choose,
+ elements, forAll, oneof, property)
+
+instance Arbitrary Token where
+ arbitrary = Token . pack <$> arbitrary
+
+instance Arbitrary PortNumber where
+ arbitrary = fromIntegral <$> (choose (1, 65535) :: Gen Int)
+
+instance Arbitrary IPv4 where
+ arbitrary = toIPv4 <$> replicateM 4 (choose (0, 255))
+
+instance Arbitrary Path where
+ arbitrary = elements [ Rel Simple $(mkRelFile "filename")
+ , Rel Simple $(mkRelFile "filename.txt")
+ , Rel Simple $(mkRelFile "file\8195name.txt")
+ , Rel Simple $(mkRelFile "\128110\127997")
+ , Abs Simple $(mkAbsFile
"/home/user/dirname/filename.txt")
+ , Rel Quoted $(mkRelFile "filename.txt")
+ , Rel Quoted $(mkRelFile "file name.txt")
+ , Rel Quoted $(mkRelFile "file\8195 name.txt")
+ , Rel Quoted $(mkRelFile "\128110\127997")
+ , Abs Quoted $(mkAbsFile "/home/user/dir
name/filename.txt")
+ ]
+
+instance Arbitrary FileOffset where
+ arbitrary = FileOffset <$> arbitrary
+
+instance Arbitrary DccChat where
+ arbitrary = oneof [ Chat <$> arbitrary <*> arbitrary
+ , ChatWhiteboard <$> arbitrary <*> arbitrary
+ ]
+
+instance Arbitrary DccSend where
+ arbitrary = oneof [ Send <$> arbitrary <*> arbitrary <*> arbitrary <*>
arbitrary
+ , SendReverseServer <$> arbitrary <*> arbitrary <*>
arbitrary <*> arbitrary
+ ]
+
+instance Arbitrary DccResume where
+ arbitrary = oneof [ Resume <$> arbitrary <*> arbitrary <*> arbitrary
+ , ResumeReverse <$> arbitrary <*> arbitrary <*> arbitrary
+ ]
+
+instance Arbitrary DccAccept where
+ arbitrary = oneof [ Accept <$> arbitrary <*> arbitrary <*> arbitrary
+ , AcceptReverse <$> arbitrary <*> arbitrary <*> arbitrary
+ ]
+
+instance Arbitrary DccSendReverseClient where
+ arbitrary = SendReverseClient
+ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+spec :: IO TestTree
+spec = testSpec "DCC message serialization" $ do
+
+ describe "Parsing single elements" $ do
+
+ describe "Network byte order IP" $ do
+ describe "[SUCCESS]" $ do
+ it "parse . encode == id" $ property $ \ip ->
+ ipToBigEndianBS ip ~> ipBigEndian `parseSatisfies` (== ip)
+ it "At beginning of stream" $
+ pack "0abcd" ~?> ipBigEndian
+ `leavesUnconsumed` pack "abcd"
+ describe "[FAILURE]" $ do
+ it "Parse < 0.0.0.0" $
+ forAll (choose (minBound, -1 :: Int)) $ \ip ->
+ ipBigEndian `shouldFailOn` pack (show ip)
+ it "Parse > 255.255.255.255" $
+ forAll (choose (4294967296, maxBound :: Int)) $ \ip ->
+ ipBigEndian `shouldFailOn` pack (show ip)
+ it "Non-digits" $
+ ipBigEndian `shouldFailOn` pack "abcd"
+ it "When not at beginning of stream" $
+ ipBigEndian `shouldFailOn` pack " 0"
+
+ describe "File name" $ do
+ describe "[SUCCESS]" $ do
+ it "parse . encode == id" $ property $ \name ->
+ pathToBS name ~> path `parseSatisfies` (== name)
+ it "At beginning of stream" $
+ pack "filename 122350" ~?> path
+ `leavesUnconsumed` pack " 122350"
+-- TODO Not sure exactly what to do with this yet. On Unix the whole thing
+-- could be a file name, while on windows it is obviously an absolute path
+-- it "File name from absolute unix path" $
+-- ("c:\\Users\\user\\filename.txt" ~> path
+-- `shouldParse` $(mkRelFile "filename.txt")
+ describe "[FAILURE]" $ do
+ it "ASCII filename with space" $
+ pack "file name.txt" ~?> path
+ `leavesUnconsumed` pack " name.txt"
+ it "Not at beginning of stream" $
+ path `shouldFailOn` pack " filename"
+
+ describe "Token" $
+ describe "[SUCCESS]" $
+ it "parse . encode == id" $ property $ \t ->
+ tokenToBS t ~> token `parseSatisfies` (== t)
+
+ describe "TCP port" $ do
+ describe "[SUCCESS]" $
+ it "parse . encode == id" $ property $ \p ->
+ tcpPortToBS p ~> tcpPort `parseSatisfies` (== p)
+ describe "[FAILURE]" $ do
+ it "Parse <= 0" $
+ forAll (choose (minBound, 0 :: Int)) $ \p ->
+ tcpPort `shouldFailOn` pack (show p)
+ it "Parse > 65535" $
+ forAll (choose (65535, maxBound :: Int)) $ \p ->
+ tcpPort `shouldFailOn` pack (show p)
+
+ describe "File offset" $ do
+ describe "[SUCCESS]" $
+ it "parse . encode == id" $ property $ \o ->
+ fileOffsetToBS o ~> fileOffset `parseSatisfies` (== o)
+ describe "[FAILURE]" $
+ it "Parse < 0" $
+ forAll (choose (minBound, -1 :: Int)) $ \o ->
+ fileOffset `shouldFailOn` pack (show o)
+
+ describe "DCC commands" $ do
+
+ describe "DCC CHAT" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $ property $ \cmd ->
+ fromCtcp (toCtcp cmd) == Right (cmd :: DccChat)
+
+ describe "DCC CLOSE" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $
+ fromCtcp (toCtcp Close) == Right Close
+
+ describe "DCC SEND" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $ property $ \cmd ->
+ fromCtcp (toCtcp cmd) == Right (cmd :: DccSend)
+
+ describe "DCC RESUME" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $ property $ \cmd ->
+ fromCtcp (toCtcp cmd) == Right (cmd :: DccResume)
+
+ describe "DCC ACCEPT" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $ property $ \cmd ->
+ fromCtcp (toCtcp cmd) == Right (cmd :: DccAccept)
+
+ describe "DCC SEND (reverse client)" $
+ describe "[SUCCESS]" $
+ it "fromCtcp . toCtcp == id" $ property $ \cmd ->
+ fromCtcp (toCtcp cmd) == Right (cmd :: DccSendReverseClient)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/test/Spec.hs
new/irc-dcc-2.0.1/test/Spec.hs
--- old/irc-dcc-1.2.1/test/Spec.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/irc-dcc-2.0.1/test/Spec.hs 2016-08-21 18:21:49.000000000 +0200
@@ -0,0 +1,5 @@
+import qualified Network.IRC.DCCTest as DCC
+import Test.Tasty
+
+main :: IO ()
+main = DCC.spec >>= defaultMain
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/tests/Main.hs
new/irc-dcc-2.0.1/tests/Main.hs
--- old/irc-dcc-1.2.1/tests/Main.hs 2016-04-07 16:26:16.000000000 +0200
+++ new/irc-dcc-2.0.1/tests/Main.hs 1970-01-01 01:00:00.000000000 +0100
@@ -1,7 +0,0 @@
-module Main where
-
-import qualified Network.IRC.DCCTest as DCC
-import Test.Tasty
-
-main :: IO ()
-main = DCC.spec >>= defaultMain
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/irc-dcc-1.2.1/tests/Network/IRC/DCCTest.hs
new/irc-dcc-2.0.1/tests/Network/IRC/DCCTest.hs
--- old/irc-dcc-1.2.1/tests/Network/IRC/DCCTest.hs 2016-04-07
16:27:48.000000000 +0200
+++ new/irc-dcc-2.0.1/tests/Network/IRC/DCCTest.hs 1970-01-01
01:00:00.000000000 +0100
@@ -1,118 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Network.IRC.DCCTest where
-
-import Network.IRC.DCC.Internal
-
-import Data.ByteString.Char8 (pack)
-import qualified Data.ByteString.UTF8 as UTF8 (fromString)
-import Data.IP (toIPv4)
-import Path (mkRelFile)
-import Test.Hspec.Attoparsec
-import Test.Tasty (TestTree)
-import Test.Tasty.Hspec (describe, it, testSpec)
-
-spec :: IO TestTree
-spec = testSpec "DCC message serialization" $
-
- describe "Parsing single elements" $ do
-
- describe "Network byte order IP" $ do
-
- describe "[SUCCESS]" $ do
-
- it "Min IPv4" $
- pack "0" ~> parseIpBigEndian
- `shouldParse` toIPv4 [0, 0, 0, 0]
-
- it "Max IPv4" $
- pack "4294967295" ~> parseIpBigEndian
- `shouldParse` toIPv4 [255, 255, 255, 255]
-
- it "Local IPv4" $
- pack "3232235521" ~> parseIpBigEndian
- `shouldParse` toIPv4 [192, 168, 0, 1]
-
- it "Public IPv4" $
- pack "134743044" ~> parseIpBigEndian
- `shouldParse` toIPv4 [8, 8, 4, 4]
-
- it "IPv4 at beginning of stream" $
- pack "0abcd" ~?> parseIpBigEndian
- `leavesUnconsumed` pack "abcd"
-
- describe "[FAILURE]" $ do
-
- it "Negative IPv4" $
- parseIpBigEndian `shouldFailOn` pack "-1"
-
- it "Bigger than max IPv4" $
- parseIpBigEndian `shouldFailOn` pack "4294967296"
-
- it "Max IPv4 with additional digit" $
- parseIpBigEndian `shouldFailOn` pack "42949672950"
-
- it "Non-digits" $
- parseIpBigEndian `shouldFailOn` pack "abcd"
-
- it "When not at beginning of stream" $
- parseIpBigEndian `shouldFailOn` pack " 0"
-
- describe "File name" $ do
-
- describe "[SUCCESS]" $ do
-
- it "Without extension" $
- pack "filename" ~> parseFileName
- `shouldParse` $(mkRelFile "filename")
-
- it "With extension" $
- pack "filename.txt" ~> parseFileName
- `shouldParse` $(mkRelFile "filename.txt")
-
- it "Quoted with extension" $
- pack "\"filename.txt\"" ~> parseFileName
- `shouldParse` $(mkRelFile "filename.txt")
-
- it "Quoted with space" $
- pack "\"file name.txt\"" ~> parseFileName
- `shouldParse` $(mkRelFile "file name.txt")
-
- it "UTF8 with em space" $
- UTF8.fromString "file\8195name.txt" ~> parseFileName
- `shouldParse` $(mkRelFile "file\8195name.txt")
-
- it "UTF8 with skin tone modifier" $
- UTF8.fromString "\128110\127997" ~> parseFileName
- `shouldParse` $(mkRelFile "\128110\127997")
-
- it "Quoted UTF8 with space" $
- UTF8.fromString "\"file\8195 name.txt\"" ~> parseFileName
- `shouldParse` $(mkRelFile "file\8195 name.txt")
-
- it "From absolute unix path" $
- pack "/home/user/filename.txt" ~> parseFileName
- `shouldParse` $(mkRelFile "filename.txt")
-
- it "From quoted absolute unix path" $
- pack "\"/home/user/filename.txt\"" ~> parseFileName
- `shouldParse` $(mkRelFile "filename.txt")
-
- it "At beginning of stream" $
- pack "filename 122350" ~?> parseFileName
- `leavesUnconsumed` pack " 122350"
-
--- TODO Not sure exactly what to do with this yet. On Unix the whole thing
--- could be a file name, while on windows it is obviously an absolute path
--- it "File name from absoulte unix path" $
--- ("c:\\Users\\user\\filename.txt" ~> parseFileName
--- `shouldParse` $(mkRelFile "filename.txt")
-
- describe "[FAILURE]" $ do
-
- it "ASCII filename with space" $
- pack "file name.txt" ~?> parseFileName
- `leavesUnconsumed` pack " name.txt"
-
- it "Not at beginning of stream" $
- parseFileName `shouldFailOn` pack " filename"
