diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +## [2.5.0.0] - 2019-06-14 + +### Fixed +Compatibility with network 3.0 package + ## [2.4.0.1] - 2019-03-03 ### Fixed diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -30,7 +30,6 @@ #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, @@ -39,7 +38,7 @@ 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, (=:)) @@ -48,6 +47,7 @@ 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 @@ -- 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/GridFS.hs b/Database/MongoDB/GridFS.hs --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -27,7 +27,7 @@ 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 @@ -121,14 +121,14 @@ -- 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 @@ -136,10 +136,10 @@ 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 @@ -- 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 @@ 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 -> Consumer S.ByteString (Action m) File diff --git a/Database/MongoDB/Internal/Network.hs b/Database/MongoDB/Internal/Network.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Internal/Network.hs @@ -0,0 +1,52 @@ +-- | Compatibility layer for network package, including newtype 'PortID' +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + +module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where + + +#if !MIN_VERSION_network(2, 9, 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 ease compatibility between older and newer network versions. +newtype PortID = PortNumber N.PortNumber deriving (Enum, Eq, Integral, Num, Ord, Read, Real, Show) + + +#if !MIN_VERSION_network(2, 9, 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 + -> 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 + ) +#endif diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs --- 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,26 +12,19 @@ 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') 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) 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 @@ -69,9 +60,12 @@ -- ^ 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 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -72,7 +72,6 @@ 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) @@ -137,9 +136,6 @@ 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 = diff --git a/Database/MongoDB/Transport/Tls.hs b/Database/MongoDB/Transport/Tls.hs --- a/Database/MongoDB/Transport/Tls.hs +++ b/Database/MongoDB/Transport/Tls.hs @@ -39,7 +39,7 @@ 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) @@ -50,7 +50,7 @@ let params = (TLS.defaultParamsClient host "") { TLS.clientSupported = def - { TLS.supportedCiphers = TLS.ciphersuite_all} + { TLS.supportedCiphers = TLS.ciphersuite_default} , TLS.clientHooks = def { TLS.onServerCertificate = \_ _ _ _ -> return []} } diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,5 +1,5 @@ Name: mongoDB -Version: 2.4.0.1 +Version: 2.5.0.0 Synopsis: Driver (client) for MongoDB, a free, scalable, fast, document DBMS Description: This package lets you connect to MongoDB servers and @@ -19,6 +19,11 @@ 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 + manual: False + Library GHC-options: -Wall default-language: Haskell2010 @@ -34,7 +39,6 @@ , conduit-extra , mtl >= 2 , cryptohash -any - , network -any , parsec -any , random -any , random-shuffle -any @@ -54,6 +58,14 @@ , 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 >= 3.0 + , network-bsd >= 2.7 && < 2.9 + Exposed-modules: Database.MongoDB Database.MongoDB.Admin Database.MongoDB.Connection @@ -61,7 +73,8 @@ 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 @@ -105,7 +118,6 @@ , containers -any , mtl >= 2 , cryptohash -any - , network -any , nonce >= 1.0.5 , stm , parsec -any @@ -116,5 +128,14 @@ , 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