From 44770450db3e772873d5b1198a06a68aba2378be Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 16:30:24 -0700 Subject: [PATCH 01/13] Add .stack-work to .gitignore. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 327bc48..0d511c2 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ dist/ cabal.sandbox.config .cabal-sandbox/ +.stack-work/ From 13f56bbee4b3fe4996a188ec6d62a8569e188b99 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 16:52:37 -0700 Subject: [PATCH 02/13] Use ciphersuite_default instead of ciphersuite_all. Due to this warning: "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." --- Database/MongoDB/Transport/Tls.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Database/MongoDB/Transport/Tls.hs b/Database/MongoDB/Transport/Tls.hs index 69aad19..cd6565b 100644 --- a/Database/MongoDB/Transport/Tls.hs +++ b/Database/MongoDB/Transport/Tls.hs @@ -50,7 +50,7 @@ connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do let params = (TLS.defaultParamsClient host "") { TLS.clientSupported = def - { TLS.supportedCiphers = TLS.ciphersuite_all} + { TLS.supportedCiphers = TLS.ciphersuite_default} , TLS.clientHooks = def { TLS.onServerCertificate = \_ _ _ _ -> return []} } From c03e1ed746bae62d899621993f3bee2ae773c299 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 16:57:51 -0700 Subject: [PATCH 03/13] Use Control.Monad.Except instead of Control.Monad.Error. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Due to the following warning: "Module ‘Control.Monad.Error’ is deprecated: Use "Control.Monad.Except" instead" --- Database/MongoDB/Connection.hs | 2 +- Database/MongoDB/GridFS.hs | 2 +- Database/MongoDB/Internal/Util.hs | 9 ++++++--- Database/MongoDB/Query.hs | 4 ---- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 9408a5f..c53f157 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -39,7 +39,7 @@ import qualified Data.List as List import Control.Monad.Identity (runIdentity) -import Control.Monad.Error (throwError) +import Control.Monad.Except (throwError) import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar, readMVar) import Data.Bson (Document, at, (=:)) diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index e4f70e3..11d8c97 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -27,7 +27,7 @@ import Control.Applicative((<$>)) import Control.Monad(when) import Control.Monad.IO.Class -import Control.Monad.Trans(MonadTrans, lift) +import Control.Monad.Trans(lift) import Data.Conduit import Data.Digest.Pure.MD5 diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs index 2c05138..8d84695 100644 --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -21,7 +21,7 @@ import System.Random.Shuffle (shuffle') import qualified Data.ByteString as S -import Control.Monad.Error (MonadError(..), Error(..)) +import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans (MonadIO, liftIO) import Data.Bson import Data.Text (Text) @@ -69,9 +69,12 @@ loop :: Monad m => m (Maybe a) -> m [a] -- ^ Repeatedy execute action, collecting results, until it returns Nothing loop act = act >>= maybe (return []) (\a -> (a :) `liftM` loop act) -untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b +untilSuccess :: (MonadError e m) => (a -> m b) -> [a] -> m b -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty. -untilSuccess = untilSuccess' (strMsg "empty untilSuccess") +untilSuccess = untilSuccess' (error "empty untilSuccess") +-- Use 'error' copying behavior in removed 'Control.Monad.Error.Error' instance: +-- instance Error Failure where strMsg = error +-- 'fail' is treated the same as a programming 'error'. In other words, don't use it. untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index a58ec2e..d0bcc86 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -72,7 +72,6 @@ import Control.Concurrent.MVar.Lifted (MVar, addMVarFinalizer, import Control.Applicative ((<$>)) import Control.Exception (catch) import Control.Monad (when, void) -import Control.Monad.Error (Error(..)) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) import Data.Binary.Put (runPut) @@ -138,9 +137,6 @@ instance Exception Failure type ErrorCode = Int -- ^ Error code from getLastError or query failure -instance Error Failure where strMsg = error --- ^ 'fail' is treated the same as a programming 'error'. In other words, don't use it. - -- | Type of reads and writes to perform data AccessMode = ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK. From 5f04dc6a237d0191beed76a8951f437750fd1b51 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 17:01:50 -0700 Subject: [PATCH 04/13] Remove use of conduit Producer and Consumer. Due to deprecations: "Deprecated: Use ConduitT directly". --- Database/MongoDB/GridFS.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index 11d8c97..1f0a12c 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -110,7 +110,7 @@ putChunk :: (Monad m, MonadIO m) => Bucket -> ObjectId -> Int -> L.ByteString -> putChunk bucket files_id i chunk = do insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)] -sourceFile :: (Monad m, MonadIO m) => File -> Producer (Action m) S.ByteString +sourceFile :: (Monad m, MonadIO m) => File -> ConduitT i S.ByteString (Action m) () -- ^ A producer for the contents of a file sourceFile file = yieldChunk 0 where yieldChunk i = do @@ -179,7 +179,7 @@ writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc) putChunk bucket files_id i chunk writeChunks (FileWriter chunkSize bucket files_id (i+1) size' acc' md5context' md5acc') L.empty -sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> Consumer S.ByteString (Action m) File +sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> ConduitT S.ByteString o (Action m) File -- ^ A consumer that creates a file in the bucket and puts all consumed data in it sinkFile bucket filename = do files_id <- liftIO $ genObjectId From b094dff0578f8465205be5670cf1a61c53ef99cf Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 17:03:03 -0700 Subject: [PATCH 05/13] Prefix internal unused fields with underscore. Due to warning: [-Wunused-top-binds]. --- Database/MongoDB/GridFS.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index 1f0a12c..78805c1 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -121,14 +121,14 @@ sourceFile file = yieldChunk 0 where -- Used to keep data during writing data FileWriter = FileWriter - { fwChunkSize :: Int64 - , fwBucket :: Bucket - , fwFilesId :: ObjectId - , fwChunkIndex :: Int - , fwSize :: Int64 - , fwAcc :: L.ByteString - , fwMd5Context :: MD5Context - , fwMd5acc :: L.ByteString + { _fwChunkSize :: Int64 + , _fwBucket :: Bucket + , _fwFilesId :: ObjectId + , _fwChunkIndex :: Int + , _fwSize :: Int64 + , _fwAcc :: L.ByteString + , _fwMd5Context :: MD5Context + , _fwMd5acc :: L.ByteString } -- Finalize file, calculating md5 digest, saving the last chunk, and creating the file in the bucket From 74a40411c1e628465b67f1f7875deaf11536cf42 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 17:07:29 -0700 Subject: [PATCH 06/13] Update shadowing warnings. --- Database/MongoDB/GridFS.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index 78805c1..631a8ef 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -136,10 +136,10 @@ finalizeFile :: (Monad m, MonadIO m) => Text -> FileWriter -> Action m File finalizeFile filename (FileWriter chunkSize bucket files_id i size acc md5context md5acc) = do let md5digest = finalizeMD5 md5context (L.toStrict md5acc) when (L.length acc > 0) $ putChunk bucket files_id i acc - timestamp <- liftIO $ getCurrentTime + currentTimestamp <- liftIO $ getCurrentTime let doc = [ "_id" =: files_id , "length" =: size - , "uploadDate" =: timestamp + , "uploadDate" =: currentTimestamp , "md5" =: show (md5digest) , "chunkSize" =: chunkSize , "filename" =: filename @@ -149,13 +149,13 @@ finalizeFile filename (FileWriter chunkSize bucket files_id i size acc md5contex -- finalize the remainder and return the MD5Digest. finalizeMD5 :: MD5Context -> S.ByteString -> MD5Digest -finalizeMD5 ctx rest = - md5Finalize ctx2 (S.drop lu rest) -- can only handle max md5BlockSizeInBytes length +finalizeMD5 ctx remainder = + md5Finalize ctx2 (S.drop lu remainder) -- can only handle max md5BlockSizeInBytes length where - l = S.length rest + l = S.length remainder r = l `mod` md5BlockSizeInBytes lu = l - r - ctx2 = md5Update ctx (S.take lu rest) + ctx2 = md5Update ctx (S.take lu remainder) -- Write as many chunks as can be written from the file writer writeChunks :: (Monad m, MonadIO m) => FileWriter -> L.ByteString -> Action m FileWriter @@ -167,16 +167,16 @@ writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc) if (L.length md5acc_temp < md5BlockLength) then (md5context, md5acc_temp) else let numBlocks = L.length md5acc_temp `div` md5BlockLength - (current, rest) = L.splitAt (md5BlockLength * numBlocks) md5acc_temp - in (md5Update md5context (L.toStrict current), rest) + (current, remainder) = L.splitAt (md5BlockLength * numBlocks) md5acc_temp + in (md5Update md5context (L.toStrict current), remainder) -- Update chunks let size' = (size + L.length chunk) let acc_temp = (acc `L.append` chunk) if (L.length acc_temp < chunkSize) then return (FileWriter chunkSize bucket files_id i size' acc_temp md5context' md5acc') else do - let (chunk, acc') = L.splitAt chunkSize acc_temp - putChunk bucket files_id i chunk + let (newChunk, acc') = L.splitAt chunkSize acc_temp + putChunk bucket files_id i newChunk writeChunks (FileWriter chunkSize bucket files_id (i+1) size' acc' md5context' md5acc') L.empty sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> ConduitT S.ByteString o (Action m) File From 5bb77518a83a2519152a5e3929b59b71f27a185c Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 17:18:00 -0700 Subject: [PATCH 07/13] Revert "Remove use of conduit Producer and Consumer." This reverts commit 5f04dc6a237d0191beed76a8951f437750fd1b51. Leave the use of Producer and Consumer for now until we drop support for conduit-1.2.*. conduit-1.3 introduces ConduitT and deprecates the use of type synonyms. However, ConduitT is not present in conduit-1.2. --- Database/MongoDB/GridFS.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index 631a8ef..aeb6ea2 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -110,7 +110,7 @@ putChunk :: (Monad m, MonadIO m) => Bucket -> ObjectId -> Int -> L.ByteString -> putChunk bucket files_id i chunk = do insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)] -sourceFile :: (Monad m, MonadIO m) => File -> ConduitT i S.ByteString (Action m) () +sourceFile :: (Monad m, MonadIO m) => File -> Producer (Action m) S.ByteString -- ^ A producer for the contents of a file sourceFile file = yieldChunk 0 where yieldChunk i = do @@ -179,7 +179,7 @@ writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc) putChunk bucket files_id i newChunk writeChunks (FileWriter chunkSize bucket files_id (i+1) size' acc' md5context' md5acc') L.empty -sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> ConduitT S.ByteString o (Action m) File +sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> Consumer S.ByteString (Action m) File -- ^ A consumer that creates a file in the bucket and puts all consumed data in it sinkFile bucket filename = do files_id <- liftIO $ genObjectId From 21cf023854a2bb5d8c81b862fc07d8145ea2ed49 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 29 May 2019 18:02:37 -0700 Subject: [PATCH 08/13] Add module Database.MongoDB.Internal.Network. Add flag imitating bson package PR for network changes. Add stack files for compilation checking. Both ghc86 builds work. Still need to fix ghc84 and under builds with older network code. --- Database/MongoDB/Connection.hs | 6 +----- Database/MongoDB/Internal/Network.hs | 32 ++++++++++++++++++++++++++++ Database/MongoDB/Internal/Util.hs | 11 +--------- Database/MongoDB/Transport/Tls.hs | 2 +- mongoDB.cabal | 16 +++++++++++++- stack-ghc80.yaml | 4 ++++ stack-ghc82.yaml | 4 ++++ stack-ghc84.yaml | 4 ++++ stack-ghc86-network3.yaml | 6 ++++++ stack-ghc86.yaml | 4 ++++ 10 files changed, 72 insertions(+), 17 deletions(-) create mode 100644 Database/MongoDB/Internal/Network.hs create mode 100644 stack-ghc80.yaml create mode 100644 stack-ghc82.yaml create mode 100644 stack-ghc84.yaml create mode 100644 stack-ghc86-network3.yaml create mode 100644 stack-ghc86.yaml diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index c53f157..5a5e110 100644 --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -30,7 +30,6 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_) -import Network (HostName, PortID(..), connectTo) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof, @@ -48,6 +47,7 @@ import Data.Text (Text) import qualified Data.Bson as B import qualified Data.Text as T +import Database.MongoDB.Internal.Network (HostName, PortID(..), connectTo) import Database.MongoDB.Internal.Protocol (Pipe, newPipe, close, isClosed) import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, updateAssocs, shuffle, mergesortM) @@ -79,11 +79,7 @@ showHostPort :: Host -> String -- TODO: Distinguish Service and UnixSocket port showHostPort (Host hostname port) = hostname ++ ":" ++ portname where portname = case port of - Service s -> s PortNumber p -> show p -#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) - UnixSocket s -> s -#endif readHostPortM :: (Monad m) => String -> m Host -- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax. diff --git a/Database/MongoDB/Internal/Network.hs b/Database/MongoDB/Internal/Network.hs new file mode 100644 index 0000000..cd249a3 --- /dev/null +++ b/Database/MongoDB/Internal/Network.hs @@ -0,0 +1,32 @@ +-- | Compatibility layer for network package, including newtype 'PortID' +{-# LANGUAGE CPP, PackageImports #-} + +module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where + +import Control.Exception (bracketOnError) +import Network.BSD as BSD +import System.IO (Handle, IOMode(ReadWriteMode)) + +#if !MIN_VERSION_network(2, 8, 0) +import qualified Network as N +#else +import qualified Network.Socket as N +#endif + +newtype PortID = PortNumber N.PortNumber deriving (Show, Eq, Ord) + +-- Taken from network 2.8's connectTo +-- https://github.com/haskell/network/blob/e73f0b96c9da924fe83f3c73488f7e69f712755f/Network.hs#L120-L129 +connectTo :: N.HostName -- Hostname + -> PortID -- Port Identifier + -> IO Handle -- Connected Socket +connectTo hostname (PortNumber port) = do + proto <- BSD.getProtocolNumber "tcp" + bracketOnError + (N.socket N.AF_INET N.Stream proto) + (N.close) -- only done if there's an error + (\sock -> do + he <- BSD.getHostByName hostname + N.connect sock (N.SockAddrInet port (hostAddress he)) + N.socketToHandle sock ReadWriteMode + ) diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs index 8d84695..a1ac303 100644 --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -1,9 +1,7 @@ --- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID +-- | Miscellaneous general functions {-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-} {-# LANGUAGE CPP #-} --- PortID instances -{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.MongoDB.Internal.Util where @@ -14,7 +12,6 @@ import Control.Exception (handle, throwIO, Exception) import Control.Monad (liftM, liftM2) import Data.Bits (Bits, (.|.)) import Data.Word (Word8) -import Network (PortID(..)) import Numeric (showHex) import System.Random (newStdGen) import System.Random.Shuffle (shuffle') @@ -28,12 +25,6 @@ import Data.Text (Text) import qualified Data.Text as T -#if !MIN_VERSION_network(2, 4, 1) -deriving instance Show PortID -deriving instance Eq PortID -#endif -deriving instance Ord PortID - -- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] mergesortM cmp = mergesortM' cmp . map wrap diff --git a/Database/MongoDB/Transport/Tls.hs b/Database/MongoDB/Transport/Tls.hs index cd6565b..696be93 100644 --- a/Database/MongoDB/Transport/Tls.hs +++ b/Database/MongoDB/Transport/Tls.hs @@ -39,7 +39,7 @@ import Database.MongoDB.Internal.Protocol (newPipeWith) import Database.MongoDB.Transport (Transport(Transport)) import qualified Database.MongoDB.Transport as T import System.IO.Error (mkIOError, eofErrorType) -import Network (connectTo, HostName, PortID) +import Database.MongoDB.Internal.Network (connectTo, HostName, PortID) import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Database.MongoDB.Query (access, slaveOk, retrieveServerData) diff --git a/mongoDB.cabal b/mongoDB.cabal index f3c9e8c..c695701 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -19,6 +19,12 @@ Build-type: Simple Stability: alpha Extra-Source-Files: CHANGELOG.md +-- Imitated from https://github.com/mongodb-haskell/bson/pull/18 +Flag _old-network + description: Control whether to use + default: False + manual: False + Library GHC-options: -Wall default-language: Haskell2010 @@ -54,6 +60,13 @@ Library , base64-bytestring >= 1.0.0.1 , nonce >= 1.0.5 + if flag(_old-network) + -- "Network.BSD" is only available in network < 2.9 + build-depends: network < 2.9 + else + -- "Network.BSD" has been moved into its own package `network-bsd` + build-depends: network-bsd >= 2.7 && < 2.9 + Exposed-modules: Database.MongoDB Database.MongoDB.Admin Database.MongoDB.Connection @@ -61,7 +74,8 @@ Library Database.MongoDB.Query Database.MongoDB.Transport Database.MongoDB.Transport.Tls - Other-modules: Database.MongoDB.Internal.Protocol + Other-modules: Database.MongoDB.Internal.Network + Database.MongoDB.Internal.Protocol Database.MongoDB.Internal.Util Source-repository head diff --git a/stack-ghc80.yaml b/stack-ghc80.yaml new file mode 100644 index 0000000..01f751a --- /dev/null +++ b/stack-ghc80.yaml @@ -0,0 +1,4 @@ +resolver: lts-9.21 +flags: + mongoDB: + _old-network: true diff --git a/stack-ghc82.yaml b/stack-ghc82.yaml new file mode 100644 index 0000000..c04f8a0 --- /dev/null +++ b/stack-ghc82.yaml @@ -0,0 +1,4 @@ +resolver: lts-11.22 +flags: + mongoDB: + _old-network: true diff --git a/stack-ghc84.yaml b/stack-ghc84.yaml new file mode 100644 index 0000000..1906340 --- /dev/null +++ b/stack-ghc84.yaml @@ -0,0 +1,4 @@ +resolver: lts-12.26 +flags: + mongoDB: + _old-network: true diff --git a/stack-ghc86-network3.yaml b/stack-ghc86-network3.yaml new file mode 100644 index 0000000..f13f71a --- /dev/null +++ b/stack-ghc86-network3.yaml @@ -0,0 +1,6 @@ +resolver: lts-13.23 +extra-deps: +- git: git@github.com:hvr/bson.git # https://github.com/mongodb-haskell/bson/pull/18 + commit: 2fc8d04120c0758201762b8e22254aeb6d574f41 +- network-bsd-2.8.1.0 +- network-3.1.0.0 diff --git a/stack-ghc86.yaml b/stack-ghc86.yaml new file mode 100644 index 0000000..cd17fca --- /dev/null +++ b/stack-ghc86.yaml @@ -0,0 +1,4 @@ +resolver: lts-13.23 +flags: + mongoDB: + _old-network: true From 17287b5556a7b0f0d072df6aafcdc050af7ab330 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Thu, 30 May 2019 10:02:06 -0700 Subject: [PATCH 09/13] Use network's connectTo when available. --- Database/MongoDB/Internal/Network.hs | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Internal/Network.hs b/Database/MongoDB/Internal/Network.hs index cd249a3..9d6f146 100644 --- a/Database/MongoDB/Internal/Network.hs +++ b/Database/MongoDB/Internal/Network.hs @@ -3,19 +3,38 @@ module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where -import Control.Exception (bracketOnError) -import Network.BSD as BSD -import System.IO (Handle, IOMode(ReadWriteMode)) #if !MIN_VERSION_network(2, 8, 0) + import qualified Network as N +import System.IO (Handle) + #else + +import Control.Exception (bracketOnError) +import Network.BSD as BSD import qualified Network.Socket as N +import System.IO (Handle, IOMode(ReadWriteMode)) + #endif + +-- | Wraps network's 'PortNumber' +-- Used to easy compatibility between older and newer network versions. newtype PortID = PortNumber N.PortNumber deriving (Show, Eq, Ord) --- Taken from network 2.8's connectTo + +#if !MIN_VERSION_network(2, 8, 0) + +-- Unwrap our newtype and use network's PortID and connectTo +connectTo :: N.HostName -- Hostname + -> PortID -- Port Identifier + -> IO Handle -- Connected Socket +connectTo hostname (PortNumber port) = N.connectTo hostname (N.PortNumber port) + +#else + +-- Copied implementation from network 2.8's 'connectTo', but using our 'PortID' newtype. -- https://github.com/haskell/network/blob/e73f0b96c9da924fe83f3c73488f7e69f712755f/Network.hs#L120-L129 connectTo :: N.HostName -- Hostname -> PortID -- Port Identifier @@ -30,3 +49,4 @@ connectTo hostname (PortNumber port) = do N.connect sock (N.SockAddrInet port (hostAddress he)) N.socketToHandle sock ReadWriteMode ) +#endif From 996d3e196bf6049c35b6dfa955aba54f2f4d44df Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Thu, 30 May 2019 10:28:23 -0700 Subject: [PATCH 10/13] Use same version check as in cabal file; fix typo in comment. --- Database/MongoDB/Internal/Network.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Internal/Network.hs b/Database/MongoDB/Internal/Network.hs index 9d6f146..84362b7 100644 --- a/Database/MongoDB/Internal/Network.hs +++ b/Database/MongoDB/Internal/Network.hs @@ -4,7 +4,7 @@ module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where -#if !MIN_VERSION_network(2, 8, 0) +#if !MIN_VERSION_network(2, 9, 0) import qualified Network as N import System.IO (Handle) @@ -20,11 +20,11 @@ import System.IO (Handle, IOMode(ReadWriteMode)) -- | Wraps network's 'PortNumber' --- Used to easy compatibility between older and newer network versions. +-- Used to ease compatibility between older and newer network versions. newtype PortID = PortNumber N.PortNumber deriving (Show, Eq, Ord) -#if !MIN_VERSION_network(2, 8, 0) +#if !MIN_VERSION_network(2, 9, 0) -- Unwrap our newtype and use network's PortID and connectTo connectTo :: N.HostName -- Hostname From 3334d819b4eb5ad851f3cec153f52a8c148e5f1a Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Thu, 30 May 2019 10:52:25 -0700 Subject: [PATCH 11/13] Improve network versioning; add to benchmarks. --- mongoDB.cabal | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/mongoDB.cabal b/mongoDB.cabal index c695701..2009ba4 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -40,7 +40,6 @@ Library , conduit-extra , mtl >= 2 , cryptohash -any - , network -any , parsec -any , random -any , random-shuffle -any @@ -65,7 +64,8 @@ Library build-depends: network < 2.9 else -- "Network.BSD" has been moved into its own package `network-bsd` - build-depends: network-bsd >= 2.7 && < 2.9 + build-depends: network >= 3.0 + , network-bsd >= 2.7 && < 2.9 Exposed-modules: Database.MongoDB Database.MongoDB.Admin @@ -119,7 +119,6 @@ Benchmark bench , containers -any , mtl >= 2 , cryptohash -any - , network -any , nonce >= 1.0.5 , stm , parsec -any @@ -130,5 +129,14 @@ Benchmark bench , transformers-base >= 0.4.1 , hashtables >= 1.1.2.0 , criterion + + if flag(_old-network) + -- "Network.BSD" is only available in network < 2.9 + build-depends: network < 2.9 + else + -- "Network.BSD" has been moved into its own package `network-bsd` + build-depends: network >= 3.0 + , network-bsd >= 2.7 && < 2.9 + default-language: Haskell2010 default-extensions: OverloadedStrings From f84cc035179198ed63a5e247aa7c95f61ce7a295 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Thu, 30 May 2019 11:33:13 -0700 Subject: [PATCH 12/13] Add numeric instances that network's PortNumber has. In particular this allows you to use `fromIntegral` without having to add the newtype wrapper. This can help existing code move away from importing and referencing the PortID type altogether. --- Database/MongoDB/Internal/Network.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Database/MongoDB/Internal/Network.hs b/Database/MongoDB/Internal/Network.hs index 84362b7..ae94830 100644 --- a/Database/MongoDB/Internal/Network.hs +++ b/Database/MongoDB/Internal/Network.hs @@ -1,5 +1,5 @@ -- | Compatibility layer for network package, including newtype 'PortID' -{-# LANGUAGE CPP, PackageImports #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where @@ -21,7 +21,7 @@ import System.IO (Handle, IOMode(ReadWriteMode)) -- | Wraps network's 'PortNumber' -- Used to ease compatibility between older and newer network versions. -newtype PortID = PortNumber N.PortNumber deriving (Show, Eq, Ord) +newtype PortID = PortNumber N.PortNumber deriving (Enum, Eq, Integral, Num, Ord, Read, Real, Show) #if !MIN_VERSION_network(2, 9, 0) From ef1fc3875c8b1d8767e1aff439e2c70ac5bc0a95 Mon Sep 17 00:00:00 2001 From: Scott Fleischman Date: Wed, 12 Jun 2019 08:57:53 -0700 Subject: [PATCH 13/13] Remove explicit default of _old-network flag. Following https://github.com/mongodb-haskell/bson/pull/18/commits/69378a08469a830176db051aa533ab3e08132924 --- mongoDB.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/mongoDB.cabal b/mongoDB.cabal index 2009ba4..4844820 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -22,7 +22,6 @@ Extra-Source-Files: CHANGELOG.md -- Imitated from https://github.com/mongodb-haskell/bson/pull/18 Flag _old-network description: Control whether to use - default: False manual: False Library