Adjusted codebase to avoid all warnings, including deprecated Producer/Consumer from conduit. Removed a few unnecessary parentheses too.

Fixed erroneously removed CPP expressions.

Removed unused imports.

for issue mongodb-haskell#126. Allow optional TLS params

Removing superfluous brackets; simplifying a few functions.

Author: why-not-try-calmer

.gitignore

@@ -2,3 +2,5 @@ dist/
 cabal.sandbox.config
 .cabal-sandbox/
 .stack-work/
+dist-newstyle/*
+!dist-newstyle/config

Database/MongoDB/Admin.hs

@@ -33,7 +33,6 @@ import Control.Applicative ((<$>))
 #endif
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Monad (forever, unless, liftM)
-import Control.Monad.Fail(MonadFail)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (maybeToList)
 import Data.Set (Set)

Database/MongoDB/Connection.hs

@@ -17,8 +17,8 @@ module Database.MongoDB.Connection (
     Host(..), PortID(..), defaultPort, host, showHostPort, readHostPort,
     readHostPortM, globalConnectTimeout, connect, connect',
     -- * Replica Set
-    ReplicaSetName, openReplicaSet, openReplicaSet', openReplicaSetTLS, openReplicaSetTLS', 
-    openReplicaSetSRV, openReplicaSetSRV', openReplicaSetSRV'', openReplicaSetSRV''', 
+    ReplicaSetName, openReplicaSet, openReplicaSet', openReplicaSetTLS, openReplicaSetTLS',
+    openReplicaSetSRV, openReplicaSetSRV', openReplicaSetSRV'', openReplicaSetSRV''',
     ReplicaSet, primary, secondaryOk, routedHost, closeReplicaSet, replSetName
 ) where
 
@@ -32,15 +32,13 @@ import Control.Applicative ((<$>))
 #endif
 
 import Control.Monad (forM_, guard)
-import Control.Monad.Fail(MonadFail)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Timeout (timeout)
 import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof,
                                       spaces, try, (<|>))
 import qualified Data.List as List
 
 
-import Control.Monad.Identity (runIdentity)
 import Control.Monad.Except (throwError)
 import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar,
                                        readMVar)
@@ -149,28 +147,28 @@ openReplicaSet' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet
 -- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. Supplied seconds timeout is used for connect attempts to members.
 openReplicaSet' timeoutSecs (rs, hosts) = _openReplicaSet timeoutSecs (rs, hosts, Unsecure)
 
-openReplicaSetTLS :: (ReplicaSetName, [Host]) -> IO ReplicaSet 
+openReplicaSetTLS :: (ReplicaSetName, [Host]) -> IO ReplicaSet
 -- ^ Open secure connections (on demand) to servers in the replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetTLS'' instead.
 openReplicaSetTLS  rsSeed = readIORef globalConnectTimeout >>= flip openReplicaSetTLS' rsSeed
 
-openReplicaSetTLS' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet 
+openReplicaSetTLS' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet
 -- ^ Open secure connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. Supplied seconds timeout is used for connect attempts to members.
 openReplicaSetTLS' timeoutSecs (rs, hosts) = _openReplicaSet timeoutSecs (rs, hosts, Secure)
 
 _openReplicaSet :: Secs -> (ReplicaSetName, [Host], TransportSecurity) -> IO ReplicaSet
-_openReplicaSet timeoutSecs (rsName, seedList, transportSecurity) = do 
+_openReplicaSet timeoutSecs (rsName, seedList, transportSecurity) = do
     vMembers <- newMVar (map (, Nothing) seedList)
     let rs = ReplicaSet rsName vMembers timeoutSecs transportSecurity
     _ <- updateMembers rs
     return rs
 
-openReplicaSetSRV :: HostName -> IO ReplicaSet 
+openReplicaSetSRV :: HostName -> IO ReplicaSet
 -- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV''' instead.
-openReplicaSetSRV hostname = do 
+openReplicaSetSRV hostname = do
     timeoutSecs <- readIORef globalConnectTimeout
     _openReplicaSetSRV timeoutSecs Unsecure hostname
 
-openReplicaSetSRV' :: HostName -> IO ReplicaSet 
+openReplicaSetSRV' :: HostName -> IO ReplicaSet
 -- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV'''' instead.
 --
 -- The preferred connection method for cloud MongoDB providers. A typical connecting sequence is shown in the example below.
@@ -180,27 +178,27 @@ openReplicaSetSRV' :: HostName -> IO ReplicaSet
 -- >   pipe <- openReplicatSetSRV' "cluster#.xxxxx.yyyyy.zzz"
 -- >   is_auth <- access pipe master "admin" $ auth user_name password
 -- >   unless (not is_auth) (throwIO $ userError "Authentication failed!")
-openReplicaSetSRV' hostname = do 
+openReplicaSetSRV' hostname = do
     timeoutSecs <- readIORef globalConnectTimeout
     _openReplicaSetSRV timeoutSecs Secure hostname
 
-openReplicaSetSRV'' :: Secs -> HostName -> IO ReplicaSet 
+openReplicaSetSRV'' :: Secs -> HostName -> IO ReplicaSet
 -- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members.
 openReplicaSetSRV'' timeoutSecs = _openReplicaSetSRV timeoutSecs Unsecure
 
-openReplicaSetSRV''' :: Secs -> HostName -> IO ReplicaSet 
+openReplicaSetSRV''' :: Secs -> HostName -> IO ReplicaSet
 -- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members.
 openReplicaSetSRV''' timeoutSecs = _openReplicaSetSRV timeoutSecs Secure
 
-_openReplicaSetSRV :: Secs -> TransportSecurity -> HostName -> IO ReplicaSet 
-_openReplicaSetSRV timeoutSecs transportSecurity hostname = do 
-    replicaSetName <- lookupReplicaSetName hostname 
-    hosts <- lookupSeedList hostname 
-    case (replicaSetName, hosts) of 
+_openReplicaSetSRV :: Secs -> TransportSecurity -> HostName -> IO ReplicaSet
+_openReplicaSetSRV timeoutSecs transportSecurity hostname = do
+    replicaSetName <- lookupReplicaSetName hostname
+    hosts <- lookupSeedList hostname
+    case (replicaSetName, hosts) of
         (Nothing, _) -> throwError $ userError "Failed to lookup replica set name"
         (_, [])  -> throwError $ userError "Failed to lookup replica set seedlist"
-        (Just rsName, _) -> 
-            case transportSecurity of 
+        (Just rsName, _) ->
+            case transportSecurity of
                 Secure -> openReplicaSetTLS' timeoutSecs (rsName, hosts)
                 Unsecure -> openReplicaSet' timeoutSecs (rsName, hosts)
 
@@ -229,7 +227,7 @@ routedHost :: ((Host, Bool) -> (Host, Bool) -> IO Ordering) -> ReplicaSet -> IO
 routedHost f rs = do
   info <- updateMembers rs
   hosts <- shuffle (possibleHosts info)
-  let addIsPrimary h = (h, if Just h == statedPrimary info then True else False)
+  let addIsPrimary h = (h, Just h == statedPrimary info)
   hosts' <- mergesortM (\a b -> f (addIsPrimary a) (addIsPrimary b)) hosts
   untilSuccess (connection rs Nothing) hosts'
 
@@ -275,8 +273,8 @@ connection (ReplicaSet _ vMembers timeoutSecs transportSecurity) mPipe host' =
  where
     conn =  modifyMVar vMembers $ \members -> do
         let (Host h p) = host'
-        let conn' = case transportSecurity of 
-                        Secure   -> TLS.connect h p 
+        let conn' = case transportSecurity of
+                        Secure   -> TLS.connect h p
                         Unsecure -> connect' timeoutSecs host'
         let new = conn' >>= \pipe -> return (updateAssocs host' (Just pipe) members, pipe)
         case List.lookup host' members of

Database/MongoDB/GridFS.hs

@@ -1,7 +1,7 @@
 -- Author:
 -- Brent Tubbs <brent.tubbs@gmail.com>
 -- | MongoDB GridFS implementation
-{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP, RankNTypes #-}
+{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, CPP, RankNTypes #-}
 
 module Database.MongoDB.GridFS
   ( Bucket
@@ -23,10 +23,8 @@ module Database.MongoDB.GridFS
   )
   where
 
-import Control.Applicative((<$>))
 
 import Control.Monad(when)
-import Control.Monad.Fail(MonadFail)
 import Control.Monad.IO.Class
 import Control.Monad.Trans(lift)
 
@@ -64,54 +62,54 @@ openBucket :: (Monad m, MonadIO m) => Text -> Action m Bucket
 openBucket name = do
   let filesCollection = name `append` ".files"
   let chunksCollection = name `append` ".chunks"
-  ensureIndex $ (index filesCollection ["filename" =: (1::Int), "uploadDate" =: (1::Int)])
+  ensureIndex $ index filesCollection ["filename" =: (1::Int), "uploadDate" =: (1::Int)]
   ensureIndex $ (index chunksCollection ["files_id" =: (1::Int), "n" =: (1::Int)]) { iUnique = True, iDropDups = True }
   return $ Bucket filesCollection chunksCollection
 
 data File = File {bucket :: Bucket, document :: Document}
 
 getChunk :: (MonadFail m, MonadIO m) => File -> Int -> Action m (Maybe S.ByteString)
 -- ^ Get a chunk of a file
-getChunk (File bucket doc) i = do
+getChunk (File _bucket doc) i = do
   files_id <- B.look "_id" doc
-  result <- findOne $ select ["files_id" := files_id, "n" =: i] $ chunks bucket
+  result <- findOne $ select ["files_id" := files_id, "n" =: i] $ chunks _bucket
   let content = at "data" <$> result
   case content of
     Just (Binary b) -> return (Just b)
     _ -> return Nothing
 
 findFile :: MonadIO m => Bucket -> Selector -> Action m [File]
 -- ^ Find files in the bucket
-findFile bucket sel = do
-  cursor <- find $ select sel $ files bucket
+findFile _bucket sel = do
+  cursor <- find $ select sel $ files _bucket
   results <- rest cursor
-  return $ File bucket <$> results
+  return $ File _bucket <$> results
 
 findOneFile :: MonadIO m => Bucket -> Selector -> Action m (Maybe File)
 -- ^ Find one file in the bucket
-findOneFile bucket sel = do
-  mdoc <- findOne $ select sel $ files bucket
-  return $ File bucket <$> mdoc
+findOneFile _bucket sel = do
+  mdoc <- findOne $ select sel $ files _bucket
+  return $ File _bucket <$> mdoc
 
 fetchFile :: MonadIO m => Bucket -> Selector -> Action m File
 -- ^ Fetch one file in the bucket
-fetchFile bucket sel = do
-  doc <- fetch $ select sel $ files bucket
-  return $ File bucket doc
+fetchFile _bucket sel = do
+  doc <- fetch $ select sel $ files _bucket
+  return $ File _bucket doc
 
 deleteFile :: (MonadIO m, MonadFail m) => File -> Action m ()
 -- ^ Delete files in the bucket
-deleteFile (File bucket doc) = do
+deleteFile (File _bucket doc) = do
   files_id <- B.look "_id" doc
-  delete $ select ["_id" := files_id] $ files bucket
-  delete $ select ["files_id" := files_id] $ chunks bucket
+  delete $ select ["_id" := files_id] $ files _bucket
+  delete $ select ["files_id" := files_id] $ chunks _bucket
 
 putChunk :: (Monad m, MonadIO m) => Bucket -> ObjectId -> Int -> L.ByteString -> Action m ()
 -- ^ Put a chunk in the bucket
-putChunk bucket files_id i chunk = do
-  insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)]
+putChunk _bucket files_id i chunk = do
+  insert_ (chunks _bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)]
 
-sourceFile :: (MonadFail m, MonadIO m) => File -> Producer (Action m) S.ByteString
+sourceFile :: (MonadFail m, MonadIO m) => File -> ConduitT File S.ByteString (Action m) ()
 -- ^ A producer for the contents of a file
 sourceFile file = yieldChunk 0 where
   yieldChunk i = do
@@ -134,19 +132,19 @@ data FileWriter = FileWriter
 
 -- Finalize file, calculating md5 digest, saving the last chunk, and creating the file in the bucket
 finalizeFile :: (Monad m, MonadIO m) => Text -> FileWriter -> Action m File
-finalizeFile filename (FileWriter chunkSize bucket files_id i size acc md5context md5acc) = do
+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
-  currentTimestamp <- liftIO $ getCurrentTime
+  when (L.length acc > 0) $ putChunk _bucket files_id i acc
+  currentTimestamp <- liftIO getCurrentTime
   let doc = [ "_id" =: files_id
             , "length" =: size
             , "uploadDate" =: currentTimestamp
-            , "md5" =: show (md5digest)
+            , "md5" =: show md5digest
             , "chunkSize" =: chunkSize
             , "filename" =: filename
             ]
-  insert_ (files bucket) doc
-  return $ File bucket doc
+  insert_ (files _bucket) doc
+  return $ File _bucket doc
 
 -- finalize the remainder and return the MD5Digest.
 finalizeMD5 :: MD5Context -> S.ByteString -> MD5Digest
@@ -160,11 +158,11 @@ finalizeMD5 ctx remainder =
 
 -- Write as many chunks as can be written from the file writer
 writeChunks :: (Monad m, MonadIO m) => FileWriter -> L.ByteString -> Action m FileWriter
-writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc) chunk = do
+writeChunks (FileWriter chunkSize _bucket files_id i size acc md5context md5acc) chunk = do
   -- Update md5 context
   let md5BlockLength = fromIntegral $ untag (blockLength :: Tagged MD5Digest Int)
   let md5acc_temp = (md5acc `L.append` chunk)
-  let (md5context', md5acc') = 
+  let (md5context', md5acc') =
         if (L.length md5acc_temp < md5BlockLength)
         then (md5context, md5acc_temp)
         else let numBlocks = L.length md5acc_temp `div` md5BlockLength
@@ -174,17 +172,17 @@ writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc)
   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')
+    then return (FileWriter chunkSize _bucket files_id i size' acc_temp md5context' md5acc')
     else do
       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
+      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
+sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> ConduitT 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
+sinkFile _bucket filename = do
   files_id <- liftIO $ genObjectId
-  awaitChunk $ FileWriter defaultChunkSize bucket files_id 0 0 L.empty md5InitialContext L.empty
+  awaitChunk $ FileWriter defaultChunkSize _bucket files_id 0 0 L.empty md5InitialContext L.empty
  where
   awaitChunk fw = do
     mchunk <- await

Database/MongoDB/Internal/Network.hs

@@ -1,10 +1,9 @@
 -- | Compatibility layer for network package, including newtype 'PortID'
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
 
 module Database.MongoDB.Internal.Network (Host(..), PortID(..), N.HostName, connectTo, 
                                           lookupReplicaSetName, lookupSeedList) where
 
-
 #if !MIN_VERSION_network(2, 9, 0)
 
 import qualified Network as N
@@ -20,7 +19,7 @@ import System.IO (Handle, IOMode(ReadWriteMode))
 #endif
 
 import Data.ByteString.Char8 (pack, unpack)
-import Data.List (dropWhileEnd, lookup)
+import Data.List (dropWhileEnd)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Network.DNS.Lookup (lookupSRV, lookupTXT)
@@ -60,7 +59,7 @@ 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
+        N.close  -- only done if there's an error
         (\sock -> do
           he <- BSD.getHostByName hostname
           N.connect sock (N.SockAddrInet port (hostAddress he))
@@ -71,7 +70,7 @@ connectTo hostname (PortNumber port) = do
 connectTo _ (UnixSocket path) = do
     bracketOnError
         (N.socket N.AF_UNIX N.Stream 0)
-        (N.close)
+        N.close
         (\sock -> do
           N.connect sock (N.SockAddrUnix path)
           N.socketToHandle sock ReadWriteMode
@@ -104,4 +103,4 @@ lookupSeedList hostname = do
     Left _ -> pure []
     Right srv -> pure $ map (\(_, _, por, tar) -> 
       let tar' = dropWhileEnd (=='.') (unpack tar) 
-      in Host tar' (PortNumber . fromIntegral $ por)) srv
+      in Host tar' (PortNumber . fromIntegral $ por)) srv

Database/MongoDB/Internal/Protocol.hs

@@ -4,8 +4,8 @@
 -- This module is not intended for direct use. Use the high-level interface at
 -- "Database.MongoDB.Query" and "Database.MongoDB.Connection" instead.
 
-{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings #-}
-{-# LANGUAGE CPP, FlexibleContexts, TupleSections, TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
+{-# LANGUAGE CPP, FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
 {-# LANGUAGE BangPatterns #-}
 
@@ -35,7 +35,7 @@ module Database.MongoDB.Internal.Protocol (
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative ((<$>))
 #endif
-import Control.Monad (forM, replicateM, unless)
+import Control.Monad ( forM, replicateM, unless, forever )
 import Data.Binary.Get (Get, runGet)
 import Data.Binary.Put (Put, runPut)
 import Data.Bits (bit, testBit)
@@ -46,7 +46,6 @@ import System.IO.Error (doesNotExistErrorType, mkIOError)
 import System.IO.Unsafe (unsafePerformIO)
 import Data.Maybe (maybeToList)
 import GHC.Conc (ThreadStatus(..), threadStatus)
-import Control.Monad (forever)
 import Control.Monad.STM (atomically)
 import Control.Concurrent (ThreadId, killThread, forkIOWithUnmask)
 import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan, isEmptyTChan)
@@ -70,6 +69,7 @@ import Database.MongoDB.Internal.Util (bitOr, byteStringHex)
 import Database.MongoDB.Transport (Transport)
 import qualified Database.MongoDB.Transport as Tr
 
+
 #if MIN_VERSION_base(4,6,0)
 import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar,
                                        putMVar, readMVar, mkWeakMVar, isEmptyMVar)
@@ -83,6 +83,7 @@ mkWeakMVar :: MVar a -> IO () -> IO ()
 mkWeakMVar = addMVarFinalizer
 #endif
 
+
 -- * Pipeline
 
 -- | Thread-safe and pipelined connection
@@ -270,6 +271,7 @@ type ResponseTo = RequestId
 
 genRequestId :: (MonadIO m) => m RequestId
 -- ^ Generate fresh request id
+{-# NOINLINE genRequestId #-}
 genRequestId = liftIO $ atomicModifyIORef counter $ \n -> (n + 1, n) where
     counter :: IORef RequestId
     counter = unsafePerformIO (newIORef 0)