From f57289bd525b34314265a09fefde89e20f8a0541 Mon Sep 17 00:00:00 2001 From: why-not-try-calmer Date: Wed, 8 Nov 2023 17:37:10 +0100 Subject: [PATCH 1/3] Test Matrix for CI (ghc x mongo versions) Tests for `auth` Rebased --- .github/workflows/test.yml | 64 ++++++++++++++++++++++++++++++++++++++ .gitignore | 4 ++- stack.yaml | 4 +-- stack.yaml.lock | 9 +++--- test/Main.hs | 20 ++++++------ test/QuerySpec.hs | 39 ++++++++++++++++------- test/TestImport.hs | 45 ++++++++++++++++++++++++--- 7 files changed, 149 insertions(+), 36 deletions(-) create mode 100644 .github/workflows/test.yml diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..434c72e --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,64 @@ +name: Test + +on: + pull_request: + push: + branches: + - master + +concurrency: + group: ${{ github.ref }} + cancel-in-progress: true + +jobs: + lint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell-actions/run-fourmolu@v9 + with: + version: "0.14.1.0" + pattern: Database/**/*.hs + extra-args: --indentation 2 + 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 diff --git a/.gitignore b/.gitignore index 74deb86..2aef968 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,6 @@ cabal.sandbox.config .cabal-sandbox/ .stack-work/ dist-newstyle/* -!dist-newstyle/config \ No newline at end of file +!dist-newstyle/config +*.nix +.vscode/* \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 579fc41..0f631b8 100644 --- a/stack.yaml +++ b/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.21 # for HLS support # User packages to be built. # Various formats can be used as shown in the example below. # diff --git a/stack.yaml.lock b/stack.yaml.lock index efdd0c4..433950c 100644 --- a/stack.yaml.lock +++ b/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: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186 + size: 640060 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml + original: lts-21.21 diff --git a/test/Main.hs b/test/Main.hs index 4dd8653..267f7ee 100644 --- a/test/Main.hs +++ b/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 diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 2e2284c..c0a5144 100644 --- a/test/QuerySpec.hs +++ b/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"]] - diff --git a/test/TestImport.hs b/test/TestImport.hs index 4150367..db22b3d 100644 --- a/test/TestImport.hs +++ b/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 From 0f2f5c7562f05a0cd7724f7732ac1486a70cef74 Mon Sep 17 00:00:00 2001 From: why-not-try-calmer Date: Wed, 3 Jan 2024 10:54:17 +0100 Subject: [PATCH 2/3] updated stackage snapshot --- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/stack.yaml b/stack.yaml index 0f631b8..96642a6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.21 # for HLS support +resolver: lts-21.25 # for HLS support # User packages to be built. # Various formats can be used as shown in the example below. # diff --git a/stack.yaml.lock b/stack.yaml.lock index 433950c..f823d29 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186 - size: 640060 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml - original: lts-21.21 + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 From 88720042f6de6dcf3c248ecd99af120a95faa0d2 Mon Sep 17 00:00:00 2001 From: why-not-try-calmer Date: Wed, 3 Jan 2024 10:55:52 +0100 Subject: [PATCH 3/3] removed linting step --- .github/workflows/test.yml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 434c72e..b57a7bc 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -11,15 +11,6 @@ concurrency: cancel-in-progress: true jobs: - lint: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v3 - - uses: haskell-actions/run-fourmolu@v9 - with: - version: "0.14.1.0" - pattern: Database/**/*.hs - extra-args: --indentation 2 test: runs-on: ubuntu-latest strategy: