{-# 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 :: FilePath -> IO Document -> GoldenTest Document
goldenBSONDocumentFile FilePath
fp IO Document
produceActualDocument =
  GoldenTest :: forall a.
IO (Maybe a)
-> IO a
-> (a -> IO ())
-> (a -> a -> Maybe Assertion)
-> GoldenTest a
GoldenTest
    { goldenTestRead :: IO (Maybe Document)
goldenTestRead = do
        Path Abs File
ap <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
fp
        Bool
exists <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
ap
        if Bool
exists
          then
            Document -> Maybe Document
forall a. a -> Maybe a
Just (Document -> Maybe Document) -> IO Document -> IO (Maybe Document)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              ByteString
sb <- FilePath -> IO ByteString
SB.readFile (Path Abs File -> FilePath
fromAbsFile Path Abs File
ap)
              case Get Document
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath)
     (ByteString, ByteOffset, Document)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath) (ByteString, ByteOffset, a)
runGetOrFail Get Document
getDocument (ByteString -> ByteString
LB.fromStrict ByteString
sb) of
                Left (ByteString
_, ByteOffset
_, FilePath
err) -> FilePath -> IO Document
forall a. HasCallStack => FilePath -> IO a
expectationFailure FilePath
err
                Right (ByteString
_, ByteOffset
_, Document
d) -> Document -> IO Document
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
d
          else Maybe Document -> IO (Maybe Document)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Document
forall a. Maybe a
Nothing,
      goldenTestProduce :: IO Document
goldenTestProduce = IO Document
produceActualDocument,
      goldenTestWrite :: Document -> IO ()
goldenTestWrite = \Document
d -> do
        Path Abs File
ap <- FilePath -> IO (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
fp
        Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
ap)
        FilePath -> ByteString -> IO ()
SB.writeFile (Path Abs File -> FilePath
fromAbsFile Path Abs File
ap) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Document -> Put
putDocument Document
d,
      goldenTestCompare :: Document -> Document -> Maybe Assertion
goldenTestCompare = \Document
actual Document
expected ->
        if Document
actual Document -> Document -> Bool
forall a. Eq a => a -> a -> Bool
== Document
expected
          then Maybe Assertion
forall a. Maybe a
Nothing
          else Assertion -> Maybe Assertion
forall a. a -> Maybe a
Just (Assertion -> FilePath -> Assertion
Context (FilePath -> FilePath -> Assertion
stringsNotEqualButShouldHaveBeenEqual (Document -> FilePath
forall a. Show a => a -> FilePath
ppShow Document
actual) (Document -> FilePath
forall a. Show a => a -> FilePath
ppShow Document
expected)) (FilePath -> FilePath
goldenContext FilePath
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 :: FilePath -> Document -> GoldenTest Document
pureGoldenBSONDocumentFile FilePath
fp Document
actualDocument = FilePath -> IO Document -> GoldenTest Document
goldenBSONDocumentFile FilePath
fp (IO Document -> GoldenTest Document)
-> IO Document -> GoldenTest Document
forall a b. (a -> b) -> a -> b
$ Document -> IO Document
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
actualDocument

data MongoServerHandle = MongoServerHandle
  { MongoServerHandle -> ProcessHandle
mongoServerHandleProcessHandle :: !ProcessHandle,
    MongoServerHandle -> PortNumber
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 :: TestDefM (MongoServerHandle : outers) Pipe result
-> TestDefM outers inner result
mongoSpec = TestDefM (MongoServerHandle : outers) inner result
-> TestDefM outers inner result
forall (outers :: [*]) inner result.
TestDefM (MongoServerHandle : outers) inner result
-> TestDefM outers inner result
mongoServerSpec (TestDefM (MongoServerHandle : outers) inner result
 -> TestDefM outers inner result)
-> (TestDefM (MongoServerHandle : outers) Pipe result
    -> TestDefM (MongoServerHandle : outers) inner result)
-> TestDefM (MongoServerHandle : outers) Pipe result
-> TestDefM outers inner result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MongoServerHandle -> inner -> SetupFunc Pipe)
-> TestDefM (MongoServerHandle : outers) Pipe result
-> TestDefM (MongoServerHandle : outers) inner result
forall (outers :: [*]) outer oldInner newInner result.
HContains outers outer =>
(outer -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith' (\MongoServerHandle
serverHandle inner
_ -> MongoServerHandle -> SetupFunc Pipe
mongoConnectionSetupFunc MongoServerHandle
serverHandle)

-- | Connect to the given mongo server and clean up beforehand.
mongoConnectionSetupFunc :: MongoServerHandle -> SetupFunc Mongo.Pipe
mongoConnectionSetupFunc :: MongoServerHandle -> SetupFunc Pipe
mongoConnectionSetupFunc MongoServerHandle {ProcessHandle
PortNumber
mongoServerHandlePort :: PortNumber
mongoServerHandleProcessHandle :: ProcessHandle
mongoServerHandlePort :: MongoServerHandle -> PortNumber
mongoServerHandleProcessHandle :: MongoServerHandle -> ProcessHandle
..} = do
  let h :: Host
h = FilePath -> PortID -> Host
Host FilePath
"127.0.0.1" (PortID -> Host) -> PortID -> Host
forall a b. (a -> b) -> a -> b
$ PortNumber -> PortID
PortNumber PortNumber
mongoServerHandlePort
  Pipe
pipe <- IO Pipe -> (Pipe -> IO ()) -> SetupFunc Pipe
forall resource r.
IO resource -> (resource -> IO r) -> SetupFunc resource
bracketSetupFunc (Host -> IO Pipe
Mongo.connect Host
h) Pipe -> IO ()
Mongo.close
  IO () -> SetupFunc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SetupFunc ()) -> IO () -> SetupFunc ()
forall a b. (a -> b) -> a -> b
$
    Pipe -> AccessMode -> Database -> Action IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Database -> Action m a -> m a
Mongo.access Pipe
pipe AccessMode
master Database
"dummy" (Action IO () -> IO ()) -> Action IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Database]
databases <- Action IO [Database]
forall (m :: * -> *). MonadIO m => Action m [Database]
Mongo.allDatabases
      [Database] -> (Database -> Action IO ()) -> Action IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Database]
databases ((Database -> Action IO ()) -> Action IO ())
-> (Database -> Action IO ()) -> Action IO ()
forall a b. (a -> b) -> a -> b
$ \Database
database ->
        Database -> Action IO () -> Action IO ()
forall (m :: * -> *) a.
Monad m =>
Database -> Action m a -> Action m a
Mongo.useDb Database
database (Action IO () -> Action IO ()) -> Action IO () -> Action IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Database]
collections <- Action IO [Database]
forall (m :: * -> *). MonadIO m => Action m [Database]
allCollections
          [Database] -> (Database -> Action IO ()) -> Action IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Database]
collections ((Database -> Action IO ()) -> Action IO ())
-> (Database -> Action IO ()) -> Action IO ()
forall a b. (a -> b) -> a -> b
$ \Database
collection -> do
            ReaderT MongoContext IO WriteResult -> Action IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT MongoContext IO WriteResult -> Action IO ())
-> ReaderT MongoContext IO WriteResult -> Action IO ()
forall a b. (a -> b) -> a -> b
$ Database
-> [(Document, [DeleteOption])]
-> ReaderT MongoContext IO WriteResult
forall (m :: * -> *).
MonadIO m =>
Database -> [(Document, [DeleteOption])] -> Action m WriteResult
Mongo.deleteAll Database
collection [([], [])] -- #types, amirite
  Pipe -> SetupFunc Pipe
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pipe
pipe

-- | Run a mongo server as an external resource
mongoServerSpec :: TestDefM (MongoServerHandle ': outers) inner result -> TestDefM outers inner result
mongoServerSpec :: TestDefM (MongoServerHandle : outers) inner result
-> TestDefM outers inner result
mongoServerSpec = SetupFunc MongoServerHandle
-> TestDefM (MongoServerHandle : outers) inner result
-> TestDefM outers inner result
forall outer (outers :: [*]) inner result.
SetupFunc outer
-> TestDefM (outer : outers) inner result
-> TestDefM outers inner result
setupAroundAll SetupFunc MongoServerHandle
mongoServerSetupFunc (TestDefM (MongoServerHandle : outers) inner result
 -> TestDefM outers inner result)
-> (TestDefM (MongoServerHandle : outers) inner result
    -> TestDefM (MongoServerHandle : outers) inner result)
-> TestDefM (MongoServerHandle : outers) inner result
-> TestDefM outers inner result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestDefM (MongoServerHandle : outers) inner result
-> TestDefM (MongoServerHandle : outers) inner result
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
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 :: SetupFunc MongoServerHandle
mongoServerSetupFunc = do
  Path Abs Dir
td <- FilePath -> SetupFunc (Path Abs Dir)
tempDirSetupFunc FilePath
"sydtest-hedis"
  Path Abs Dir -> SetupFunc MongoServerHandle
mongoServerSetupFunc' Path Abs Dir
td

-- | Set up, and clean up after, a mongo server, in the given directory.
mongoServerSetupFunc' :: Path Abs Dir -> SetupFunc MongoServerHandle
mongoServerSetupFunc' :: Path Abs Dir -> SetupFunc MongoServerHandle
mongoServerSetupFunc' Path Abs Dir
td = do
  Path Abs File
pidFile <- Path Abs Dir -> FilePath -> SetupFunc (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> FilePath -> m (Path Abs File)
resolveFile Path Abs Dir
td FilePath
"mongo.pid"
  Path Abs File
logFile <- Path Abs Dir -> FilePath -> SetupFunc (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> FilePath -> m (Path Abs File)
resolveFile Path Abs Dir
td FilePath
"mongo.log"
  Path Abs Dir
dataDir <- Path Abs Dir -> FilePath -> SetupFunc (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> FilePath -> m (Path Abs Dir)
resolveDir Path Abs Dir
td FilePath
"data"
  Path Abs Dir -> SetupFunc ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dataDir
  Int
portInt <- IO Int -> SetupFunc Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> SetupFunc Int) -> IO Int -> SetupFunc Int
forall a b. (a -> b) -> a -> b
$ do
    (Int
portInt, Socket
_socket) <- IO (Int, Socket)
openFreePort
    Socket -> IO ()
Socket.close Socket
_socket
    Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
portInt
  let pn :: PortNumber
pn = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portInt -- (hopefully) safe because it came from 'getFreePort'.
  let configFileContents :: ByteString
configFileContents =
        Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
          [Pair] -> Value
object
            [ Database
"systemLog"
                Database -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= [Pair] -> Value
object
                  [ Database
"destination" Database -> Database -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= (Database
"file" :: Text),
                    Database
"path" Database -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= Path Abs File -> FilePath
fromAbsFile Path Abs File
logFile
                  ],
              Database
"net"
                Database -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= [Pair] -> Value
object
                  [ Database
"port" Database -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= Int
portInt
                  ],
              Database
"processManagement"
                Database -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= [Pair] -> Value
object
                  [Database
"fork" Database -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= Bool
False, Database
"pidFilePath" Database -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= Path Abs File -> FilePath
fromAbsFile Path Abs File
pidFile],
              -- It would be nice to use the in-memory storage engine
              -- but that's only available in mongodb enterprise >=3.2.
              Database
"storage"
                Database -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= [Pair] -> Value
object
                  [ Database
"dbPath" Database -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Database -> v -> kv
.= Path Abs Dir -> FilePath
fromAbsDir Path Abs Dir
dataDir
                  ]
            ]
  Path Abs File
configFile <- FilePath -> ByteString -> SetupFunc (Path Abs File)
tempBinaryFileWithContentsSetupFunc FilePath
"config-file" ByteString
configFileContents
  let pc :: CreateProcess
pc =
        ( FilePath -> [FilePath] -> CreateProcess
proc
            FilePath
"mongod"
            [FilePath
"--config", Path Abs File -> FilePath
fromAbsFile Path Abs File
configFile]
        )
          { cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> FilePath
fromAbsDir Path Abs Dir
td
          }
  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> SetupFunc
     (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
processSetupFunc CreateProcess
pc
  IO () -> SetupFunc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SetupFunc ()) -> IO () -> SetupFunc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> IO ()
Socket.wait FilePath
"127.0.0.1" Int
portInt
  MongoServerHandle -> SetupFunc MongoServerHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MongoServerHandle -> SetupFunc MongoServerHandle)
-> MongoServerHandle -> SetupFunc MongoServerHandle
forall a b. (a -> b) -> a -> b
$
    MongoServerHandle :: ProcessHandle -> PortNumber -> MongoServerHandle
MongoServerHandle
      { mongoServerHandleProcessHandle :: ProcessHandle
mongoServerHandleProcessHandle = ProcessHandle
ph,
        mongoServerHandlePort :: PortNumber
mongoServerHandlePort = PortNumber
pn
      }