sydtest-mongo (empty) → 0.0.0.0
raw patch · 5 files changed
+304/−0 lines, 5 filesdep +basedep +binarydep +bson
Dependencies added: base, binary, bson, bytestring, mongoDB, network, path, path-io, port-utils, process, sydtest, sydtest-mongo, sydtest-process, text, yaml
Files
- LICENSE.md +5/−0
- src/Test/Syd/MongoDB.hs +167/−0
- sydtest-mongo.cabal +74/−0
- test/Spec.hs +1/−0
- test/Test/Syd/MongoDBSpec.hs +57/−0
+ LICENSE.md view
@@ -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.
+ src/Test/Syd/MongoDB.hs view
@@ -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+ }
+ sydtest-mongo.cabal view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/MongoDBSpec.hs view
@@ -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)+ ]