diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,5 @@ +# Sydtest License + +Copyright (c) 2021 Tom Sydney Kerckhove + +See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text. diff --git a/src/Test/Syd/MongoDB.hs b/src/Test/Syd/MongoDB.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/MongoDB.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Syd.MongoDB + ( -- * Golden tests + goldenBSONDocumentFile, + pureGoldenBSONDocumentFile, + + -- * Integration tests + mongoSpec, + mongoConnectionSetupFunc, + MongoServerHandle (..), + mongoServerSpec, + mongoServerSetupFunc, + mongoServerSetupFunc', + ) +where + +import Control.Monad (forM_, void) +import Data.Binary.Get +import Data.Binary.Put +import Data.Bson as Bson +import Data.Bson.Binary +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Text (Text) +import Data.Yaml as Yaml +import Database.MongoDB as Mongo +import Network.Socket as Socket +import Network.Socket.Free +import qualified Network.Socket.Wait as Socket +import Path +import Path.IO +import System.Process +import Test.Syd +import Test.Syd.Path +import Test.Syd.Process + +-- | Test that the produced 'Bson.Document' is the same as what we find in the given golden file. +goldenBSONDocumentFile :: FilePath -> IO Bson.Document -> GoldenTest Bson.Document +goldenBSONDocumentFile fp produceActualDocument = + GoldenTest + { goldenTestRead = do + ap <- resolveFile' fp + exists <- doesFileExist ap + if exists + then + Just <$> do + sb <- SB.readFile (fromAbsFile ap) + case runGetOrFail getDocument (LB.fromStrict sb) of + Left (_, _, err) -> expectationFailure err + Right (_, _, d) -> pure d + else pure Nothing, + goldenTestProduce = produceActualDocument, + goldenTestWrite = \d -> do + ap <- resolveFile' fp + ensureDir (parent ap) + SB.writeFile (fromAbsFile ap) $ LB.toStrict $ runPut $ putDocument d, + goldenTestCompare = \actual expected -> + if actual == expected + then Nothing + else Just (Context (stringsNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)) (goldenContext fp)) + } + +-- | Test that the given 'Bson.Document' is the same as what we find in the given golden file. +pureGoldenBSONDocumentFile :: FilePath -> Bson.Document -> GoldenTest Bson.Document +pureGoldenBSONDocumentFile fp actualDocument = goldenBSONDocumentFile fp $ pure actualDocument + +data MongoServerHandle = MongoServerHandle + { mongoServerHandleProcessHandle :: !ProcessHandle, + mongoServerHandlePort :: !PortNumber + } + +-- | Provide access to a real 'Mongo.Pipe' for each test. +-- +-- Example usage: +-- +-- > mongoSpec $ do +-- > it "can write and read an example value" $ \pipe -> do +-- > Mongo.access pipe master "example-database" $ do +-- > let collection = "example-collection" +-- > exampleVal = ["hello" =: ("world" :: Text)] +-- > i <- insert collection exampleVal +-- > r <- findOne (select ["_id" =: i] collection) +-- > liftIO $ r `shouldBe` Just (("_id" =: i) : exampleVal) +-- > pure () :: IO () +-- +-- This function uses 'mongoServerSpec' as well as 'mongoConnectionSetupFunc' to run a mongo server, provide access to it and clean up before the test. +mongoSpec :: TestDefM (MongoServerHandle ': outers) Mongo.Pipe result -> TestDefM outers inner result +mongoSpec = mongoServerSpec . setupAroundWith' (\serverHandle _ -> mongoConnectionSetupFunc serverHandle) + +-- | Connect to the given mongo server and clean up beforehand. +mongoConnectionSetupFunc :: MongoServerHandle -> SetupFunc Mongo.Pipe +mongoConnectionSetupFunc MongoServerHandle {..} = do + let h = Host "127.0.0.1" $ PortNumber mongoServerHandlePort + pipe <- bracketSetupFunc (Mongo.connect h) Mongo.close + liftIO $ + Mongo.access pipe master "dummy" $ do + databases <- Mongo.allDatabases + forM_ databases $ \database -> + Mongo.useDb database $ do + collections <- allCollections + forM_ collections $ \collection -> do + void $ Mongo.deleteAll collection [([], [])] -- #types, amirite + pure pipe + +-- | Run a mongo server as an external resource +mongoServerSpec :: TestDefM (MongoServerHandle ': outers) inner result -> TestDefM outers inner result +mongoServerSpec = setupAroundAll mongoServerSetupFunc . sequential -- Must run sequentially because state is shared. + +-- | Set up, and clean up after, a mongo server in a temporary directory. +mongoServerSetupFunc :: SetupFunc MongoServerHandle +mongoServerSetupFunc = do + td <- tempDirSetupFunc "sydtest-hedis" + mongoServerSetupFunc' td + +-- | Set up, and clean up after, a mongo server, in the given directory. +mongoServerSetupFunc' :: Path Abs Dir -> SetupFunc MongoServerHandle +mongoServerSetupFunc' td = do + pidFile <- resolveFile td "mongo.pid" + logFile <- resolveFile td "mongo.log" + dataDir <- resolveDir td "data" + ensureDir dataDir + portInt <- liftIO $ do + (portInt, _socket) <- openFreePort + Socket.close _socket + pure portInt + let pn = fromIntegral portInt -- (hopefully) safe because it came from 'getFreePort'. + let configFileContents = + Yaml.encode $ + object + [ "systemLog" + .= object + [ "destination" .= ("file" :: Text), + "path" .= fromAbsFile logFile + ], + "net" + .= object + [ "port" .= portInt + ], + "processManagement" + .= object + ["fork" .= False, "pidFilePath" .= fromAbsFile pidFile], + -- It would be nice to use the in-memory storage engine + -- but that's only available in mongodb enterprise >=3.2. + "storage" + .= object + [ "dbPath" .= fromAbsDir dataDir + ] + ] + configFile <- tempBinaryFileWithContentsSetupFunc "config-file" configFileContents + let pc = + ( proc + "mongod" + ["--config", fromAbsFile configFile] + ) + { cwd = Just $ fromAbsDir td + } + (_, _, _, ph) <- processSetupFunc pc + liftIO $ Socket.wait "127.0.0.1" portInt + pure $ + MongoServerHandle + { mongoServerHandleProcessHandle = ph, + mongoServerHandlePort = pn + } diff --git a/sydtest-mongo.cabal b/sydtest-mongo.cabal new file mode 100644 --- /dev/null +++ b/sydtest-mongo.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: sydtest-mongo +version: 0.0.0.0 +synopsis: An mongoDB companion library for sydtest +category: Testing +homepage: https://github.com/NorfairKing/sydtest#readme +bug-reports: https://github.com/NorfairKing/sydtest/issues +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2021 Tom Sydney Kerckhove +license: OtherLicense +license-file: LICENSE.md +build-type: Simple + +source-repository head + type: git + location: https://github.com/NorfairKing/sydtest + +flag sydtest_integration_tests + description: Whether to allow building integration tests + manual: False + default: True + +library + exposed-modules: + Test.Syd.MongoDB + other-modules: + Paths_sydtest_mongo + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , binary + , bson + , bytestring + , mongoDB + , network + , path + , path-io + , port-utils + , process + , sydtest + , sydtest-process + , text + , yaml + default-language: Haskell2010 + +test-suite sydtest-mongo-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.MongoDBSpec + Paths_sydtest_mongo + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + base >=4.7 && <5 + , mongoDB + , sydtest + , sydtest-mongo + , text + if flag(sydtest_integration_tests) + buildable: True + else + buildable: False + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/MongoDBSpec.hs b/test/Test/Syd/MongoDBSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/MongoDBSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Syd.MongoDBSpec (spec) where + +import Data.Text (Text) +import Database.MongoDB as Mongo +import Test.Syd +import Test.Syd.MongoDB + +spec :: Spec +spec = do + describe "mongoServerSpec" $ + mongoServerSpec $ + it "sets up and tears down the mongo server nicely" $ do + pure () :: IO () + describe "mongoSpec" $ + mongoSpec $ do + it "can write and read an example value" $ \pipe -> do + Mongo.access pipe master "example-database" $ do + let collection = "example-collection" + exampleVal = ["hello" =: ("world" :: Text)] + i <- insert collection exampleVal + r <- findOne (select ["_id" =: i] collection) + liftIO $ r `shouldBe` Just (("_id" =: i) : exampleVal) + pure () :: IO () + doNotRandomiseExecutionOrder $ + describe "shared state" $ do + it "can write an example value" $ \pipe -> do + Mongo.access pipe master "example-database" $ do + let collection = "example-collection" + exampleVal = ["hello" =: ("world" :: Text)] + insert_ collection exampleVal + pure () :: IO () + it "cannot read a value that has not been written yet" $ \pipe -> do + Mongo.access pipe master "example-database" $ do + let collection = "example-collection" + r <- find (select [] collection) >>= rest + liftIO $ r `shouldBe` [] + pure () :: IO () + + describe "pureGoldenBSONDocumentFile" $ + it "outputs this example the same as before" $ + pureGoldenBSONDocumentFile + "test_resources/pure-example.bson" + [ "hello" =: ("world" :: Text), + "foo" =: (5 :: Int), + "bar" =: (0.5 :: Double) + ] + describe "goldenBSONDocumentFile" $ + it "outputs this example the same as before" $ + goldenBSONDocumentFile + "test_resources/example.bson" + $ pure + [ "hello" =: ("world" :: Text), + "baz" =: 'a', + "quux" =: (0.0 :: Double) + ]