Is connecting using MongoDB over SSL possible?

[chrissound]

This functionality seems to be supported with MongoDB using https://hackage.haskell.org/package/mongoDB-2.3.0.1/docs/Database-MongoDB-Transport-Tls.html#v:connect

I'm testing using the following:

  let mongoConfig = MongoConf "test" "cluster0-shard-00-00-gv0qj.mongodb.net" (PortNumber 27017) (Just $ MongoAuth "*" "*") UnconfirmedWrites 1 1 2000 Nothing
  withConnection mongoConfig $ \pool -> runMongoDBPool master actions pool

Which produces an error of:

*** Exception: Data.Binary.Get.runGet at position 0: not enough bytes
CallStack (from HasCallStack):
  error, called at libraries/binary/src/Data/Binary/Get.hs:351:5 in binary-0.8.5.1:Data.Binary.Get

[chrissound]

I've cloned down the repo and exported some constructors:

diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs
index 0d337492..af3e15bf 100644
--- a/persistent-mongoDB/Database/Persist/MongoDB.hs
+++ b/persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -74,8 +74,8 @@ module Database.Persist.MongoDB
     , createMongoDBPool
     , runMongoDBPool
     , runMongoDBPoolDef
-    , ConnectionPool
-    , Connection
+    , ConnectionPool(..)
+    , Connection(..)
     , MongoAuth (..)
 
     -- * Connection configuration

And it seems I've managed to connect successfully, however the writes don't seem to be going through for some reason...

{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wno-unused-local-binds #-}

import           Yesod
import Database.Persist.MongoDB
import qualified Database.MongoDB as DB
import MongoImport
import Network (PortID (PortNumber))
import Control.Monad.Reader
import qualified Data.Pool as Pool
import Database.MongoDB.Transport.Tls as DBTLS

share
    [mkPersist mongoSettings, mkMigrate "migrateAll"]
    [persistLowerCase|
User
    name String
    age Int Maybe
    deriving Show
|]

actions :: ReaderT MongoContext IO ()
actions = do
  i <- insert $ User "Chris" $ Just 123
  lift $ print i

createPipe :: HostName -> PortID -> IO DB.Pipe
createPipe hostname port = DBTLS.connect hostname port

createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection
createConnection dbname hostname port mAuth = do
    pipe <- createPipe hostname port
    testAccess pipe dbname mAuth
    return $ Connection pipe dbname

testAccess :: DB.Pipe -> Database -> Maybe MongoAuth -> IO ()
testAccess pipe dbname mAuth = do
    _ <- case mAuth of
      Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites dbname (DB.auth user pass)
      Nothing -> return undefined
    return ()

makeSslPool :: IO (ConnectionPool)
makeSslPool = Pool.createPool
                          (createConnection "test" "cluster0-shard-00-00-gv0qj.mongodb.net" (PortNumber 27017) (Just $ MongoAuth "" ""))
                          (\(Connection pipe _) -> DB.close pipe)
                          1
                          100
                          1
main :: IO ()
main = do
  makeSslPool >>= runMongoDBPool master actions

It outputs:

UserKey {unUserKey = MongoKey {unMongoKey = 5a6209a32a0e1613e7000008}}

But using the mongo console I don't see this value?

[chrissound]

Finally got this to work... The issue with my previous example is 1. It does not save any record 2. It produces no error. Potentially my code is actually doing something wrong.

I've managed to get this to work with the following:

{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wno-unused-local-binds #-}

import           Yesod
import Database.Persist.MongoDB
import qualified Database.MongoDB as DB
import MongoImport
import Network (PortID (PortNumber))
import Control.Monad.Reader
import qualified Data.Pool as Pool
import Database.MongoDB.Transport.Tls as DBTLS

share
    [mkPersist mongoSettings, mkMigrate "migrateAll"]
    [persistLowerCase|
User
    name String
    age Int Maybe
    deriving Show
|]

createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection
createConnection dbname _ _ mAuth = do
    pipe <- DBTLS.connect "cluster0-shard-00-00-gv0qj.mongodb.net" (PortNumber 27017)
    testAccess pipe mAuth
    return $ Connection pipe dbname

actions :: ReaderT MongoContext IO ()
actions = do
  i <- insert $ User "chrz" $ Just 1232
  lift $ print i

testAccess :: DB.Pipe ->  Maybe MongoAuth -> IO ()
testAccess pipe mAuth = do
    x <- case mAuth of
      Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites "admin" (DB.auth  user pass)
      Nothing -> error "no auth"
    case x of
      False -> error "second no auth"
      True -> return ()

makeSslPool :: IO (ConnectionPool)
makeSslPool = Pool.createPool
                          (createConnection "test" "cluster0-shard-00-00-gv0qj.mongodb.net" (PortNumber 27017) (Just $ MongoAuth "" ""))
                          (\(Connection pipe _) -> DB.close pipe)
                          1
                          100
                          1
main :: IO ()
main = makeSslPool >>= runMongoDBPool master actions

---

Conclusion:

The above does need the exported Constructors - but this is just for hacking / debugging purposes. I'm not 100% sure on how this can actually be fixed in the library but I think the fix is we just need to create a new Connection via so:

-- import Database.MongoDB.Transport.Tls as DBTLS

createTLSConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection
createTLSConnection dbname host port mAuth = do
    pipe <- DBTLS.connect host port
    testAccess pipe mAuth
    return $ Connection pipe dbname