Merge: update to network 3.0

This PR introduces an abstraction layer that
builds a facade for network 2.8 and 3.0.

PR# 98
This commit is contained in:
Victor Denisov 2019-06-14 20:09:04 -07:00
commit 33f2aca7b7
13 changed files with 129 additions and 47 deletions

1
.gitignore vendored
View file

@ -1,3 +1,4 @@
dist/
cabal.sandbox.config
.cabal-sandbox/
.stack-work/

View file

@ -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,
@ -39,7 +38,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, (=:))
@ -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.

View file

@ -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
@ -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
@ -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 -> Consumer S.ByteString (Action m) File

View file

@ -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

View file

@ -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.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')
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 @@ 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

View file

@ -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.

View file

@ -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)
@ -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 []}
}

View file

@ -19,6 +19,11 @@ 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 <http://hackage.haskell.org/package/network-bsd network-bsd>
manual: False
Library
GHC-options: -Wall
default-language: Haskell2010
@ -34,7 +39,6 @@ Library
, conduit-extra
, mtl >= 2
, cryptohash -any
, network -any
, parsec -any
, random -any
, random-shuffle -any
@ -54,6 +58,14 @@ 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 >= 3.0
, network-bsd >= 2.7 && < 2.9
Exposed-modules: Database.MongoDB
Database.MongoDB.Admin
Database.MongoDB.Connection
@ -61,7 +73,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
@ -105,7 +118,6 @@ Benchmark bench
, containers -any
, mtl >= 2
, cryptohash -any
, network -any
, nonce >= 1.0.5
, stm
, parsec -any
@ -116,5 +128,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

4
stack-ghc80.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-9.21
flags:
mongoDB:
_old-network: true

4
stack-ghc82.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-11.22
flags:
mongoDB:
_old-network: true

4
stack-ghc84.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-12.26
flags:
mongoDB:
_old-network: true

View file

@ -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

4
stack-ghc86.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-13.23
flags:
mongoDB:
_old-network: true