Merge larger test matrix & tests for auth and MongoDB Atlas

Author: VictorDenisov

.github/workflows/test.yml

@@ -0,0 +1,55 @@
+name: Test
+
+on:
+  pull_request:
+  push:
+    branches:
+      - master
+
+concurrency:
+  group: ${{ github.ref }}
+  cancel-in-progress: true
+
+jobs:
+  test:
+    runs-on: ubuntu-latest
+    strategy:
+      fail-fast: false
+      matrix:
+        mongodb:
+          - mongo:4.0
+          - mongo:5.0
+          - mongo:6.0
+          - mongo:7.0
+          - mongo_atlas
+        ghc:
+          - "8.10.4"
+          - "9.4.7" # oldest version with HLS support
+          - latest
+    steps:
+      - uses: actions/checkout@v3
+
+      - name: Setup Haskell tooling
+        uses: haskell-actions/setup@v2
+        with:
+          enable-stack: true
+          ghc-version: ${{ matrix.ghc }}
+          stack-version: latest
+
+      - name: Setup container and run tests
+        run: |
+          # the job-level 'if' expression is evaluated before the matrix variable
+          # so it cannot be used to configure this step
+          if [[ ${{ matrix.mongodb }} = "mongo_atlas" ]]
+          then 
+            export CONNECTION_STRING=${{ secrets.CONNECTION_STRING }}
+          else
+            docker run -d \
+              -p 27017:27017 \
+              -e MONGO_INITDB_ROOT_USERNAME=testadmin \
+              -e MONGO_INITDB_ROOT_PASSWORD=123 \
+              ${{ matrix.mongodb }}
+          fi
+          # build & run tests
+          export MONGO_VERSION=${{ matrix.mongodb }}
+          stack test --fast

.gitignore

@@ -3,4 +3,6 @@ cabal.sandbox.config
 .cabal-sandbox/
 .stack-work/
 dist-newstyle/*
-!dist-newstyle/config
+!dist-newstyle/config
+*.nix
+.vscode/*

stack.yaml

@@ -17,9 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml
-
+resolver: lts-21.25 # for HLS support
 # User packages to be built.
 # Various formats can be used as shown in the example below.
 #

stack.yaml.lock

@@ -6,8 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 586110
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml
-    sha256: ce4fb8d44f3c6c6032060a02e0ebb1bd29937c9a70101c1517b92a87d9515160
-  original:
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/21.yaml
+    sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd
+    size: 640086
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml
+  original: lts-21.25

test/Main.hs

@@ -1,19 +1,17 @@
 module Main where
 
-import Database.MongoDB.Admin (serverVersion)
-import Database.MongoDB.Connection (connect, host)
-import Database.MongoDB.Query (access, slaveOk)
-import Data.Text (unpack)
+import Control.Exception (assert)
+import Control.Monad (when)
+import Data.Maybe (isJust)
+import qualified Spec
+import System.Environment (getEnv, lookupEnv)
 import Test.Hspec.Runner
-import System.Environment (getEnv)
-import System.IO.Error (catchIOError)
 import TestImport
-import qualified Spec
 
 main :: IO ()
 main = do
-  mongodbHost <- getEnv mongodbHostEnvVariable `catchIOError` (\_ -> return "localhost")
-  p <- connect $ host mongodbHost
-  version <- access p slaveOk "admin" serverVersion
-  putStrLn $ "Running tests with mongodb version: " ++ (unpack version)
+  version <- getEnv "MONGO_VERSION"
+  when (version == "mongo_atlas") $ do
+    connection_string <- lookupEnv "CONNECTION_STRING"
+    pure $ assert (isJust connection_string) ()
   hspecWith defaultConfig Spec.spec

test/QuerySpec.hs

@@ -7,7 +7,7 @@ import TestImport
 import Control.Concurrent (threadDelay)
 import Control.Exception
 import Control.Monad (forM_, when)
-import System.Environment (getEnv)
+import System.Environment (getEnv, lookupEnv)
 import System.IO.Error (catchIOError)
 import qualified Data.List as L
 
@@ -17,12 +17,26 @@ testDBName :: Database
 testDBName = "mongodb-haskell-test"
 
 db :: Action IO a -> IO a
-db action = do
+db action = bracket start end inbetween
+ where
+  start = lookupEnv "CONNECTION_STRING" >>= getPipe
+  end (_, pipe) = close pipe
+  inbetween (testuser, pipe) = do
+    logged_in <-
+      access pipe master "admin" $ do
+        auth (u_name testuser) (u_passwd testuser)
+    assert logged_in $ pure ()
+    access pipe master testDBName action
+  getPipe Nothing = do
+    let user = TestUser "testadmin" "123"
     mongodbHost <- getEnv mongodbHostEnvVariable `catchIOError` (\_ -> return "localhost")
     pipe <- connect (host mongodbHost)
-    result <- access pipe master testDBName action
-    close pipe
-    return result
+    pure (user, pipe)
+  getPipe (Just cs) = do
+    let creds = extractMongoAtlasCredentials . T.pack $ cs
+        user = TestUser "testadmin" (atlas_password creds)
+    pipe <- connectAtlas creds
+    pure (user, pipe)
 
 getWireVersion :: IO Int
 getWireVersion = db $ do
@@ -68,6 +82,8 @@ fineGrainedBigDocument = (flip map) [1..1000] $ \i -> (fromString $ "team" ++ (s
 hugeDocument :: Document
 hugeDocument = (flip map) [1..1000000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name")
 
+data TestUser = TestUser {u_name :: T.Text, u_passwd :: T.Text}
+
 spec :: Spec
 spec = around withCleanDatabase $ do
   describe "useDb" $ do
@@ -78,11 +94,13 @@ spec = around withCleanDatabase $ do
 
   describe "collectionWithDot" $ do
     it "uses a collection with dots in the name" $ do
-      let coll = "collection.with.dot"
-      _id <- db $ insert coll ["name" =: "jack", "color" =: "blue"]
-      Just doc <- db $ findOne (select ["name" =: "jack"] coll)
-      doc !? "color" `shouldBe` (Just "blue")
-
+      -- Dots in collection names are disallowed from Mongo 6 on
+      mongo_version <- getEnv "MONGO_VERSION"
+      when (mongo_version `elem` ["mongo:5.0", "mongo:4.0"]) $ do
+        let collec = "collection.with.dot"
+        _id <- db $ insert collec ["name" =: "jack", "color" =: "blue"]
+        Just doc <- db $ findOne (select ["name" =: "jack"] collec)
+        doc !? "color" `shouldBe` Just "blue"
 
   describe "insert" $ do
     it "inserts a document to the collection and returns its _id" $ do
@@ -497,4 +515,3 @@ spec = around withCleanDatabase $ do
                               , sort    = [ "_id" =: 1 ]
                               }
         result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]]
-

test/TestImport.hs

@@ -1,15 +1,18 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 
 module TestImport (
   module TestImport,
-  module Export
+  module Export,
 ) where
 
-import Test.Hspec as Export hiding (Selector)
-import Database.MongoDB as Export
-import Control.Monad.Trans as Export (MonadIO, liftIO) 
+import Control.Exception (SomeException (SomeException), try)
+import Control.Monad.Trans as Export (MonadIO, liftIO)
+import qualified Data.Text as T
 import Data.Time (ParseTime, UTCTime)
 import qualified Data.Time as Time
+import Database.MongoDB as Export
+import Test.Hspec as Export hiding (Selector)
 
 -- We support the old version of time because it's easier than trying to use
 -- only the new version and test older GHC versions.
@@ -20,7 +23,7 @@ import System.Locale (defaultTimeLocale, iso8601DateFormat)
 import Data.Maybe (fromJust)
 #endif
 
-parseTime :: ParseTime t => String -> String -> t
+parseTime :: (ParseTime t) => String -> String -> t
 #if MIN_VERSION_time(1,5,0)
 parseTime = Time.parseTimeOrError True defaultTimeLocale
 #else
@@ -35,3 +38,35 @@ parseDateTime = parseTime (iso8601DateFormat (Just "%H:%M:%S"))
 
 mongodbHostEnvVariable :: String
 mongodbHostEnvVariable = "HASKELL_MONGODB_TEST_HOST"
+
+data MongoAtlas = MongoAtlas
+  { atlas_host :: T.Text
+  , atlas_user :: T.Text
+  , atlas_password :: T.Text
+  }
+
+extractMongoAtlasCredentials :: T.Text -> MongoAtlas
+extractMongoAtlasCredentials cs =
+  let s = T.drop 14 cs
+      [u, s'] = T.splitOn ":" s
+      [p, h] = T.splitOn "@" s'
+   in MongoAtlas h u p
+
+connectAtlas :: MongoAtlas -> IO Pipe
+connectAtlas (MongoAtlas h _ _) = do
+  repset <- openReplicaSetSRV' $ T.unpack h
+  primaryOrSecondary repset >>= \case
+    Just pipe -> pure pipe
+    Nothing -> ioError $ error "Unable to acquire pipe from MongoDB Atlas' replicaset"
+ where
+  primaryOrSecondary rep =
+    try (primary rep) >>= \case
+      Left (SomeException err) -> do
+        print $
+          "Failed to acquire primary replica, reason:"
+            ++ show err
+            ++ ". Moving to second..."
+        try (secondaryOk rep) >>= \case
+          Left (SomeException _) -> pure Nothing
+          Right pipe -> pure $ Just pipe
+      Right pipe -> pure $ Just pipe