From 51358d13c433a80598295a323634162e3eed08f7 Mon Sep 17 00:00:00 2001
From: Pierre Mizrahi <pierre.mizrahi@gmail.com>
Date: Mon, 29 May 2023 11:48:05 +0200
Subject: [PATCH] mongo 6: fix issue on collections with '.'

Collection names are allowed to have a '.' in their name, db
names aren't (see
https://www.mongodb.com/docs/manual/reference/limits/#naming-restrictions)

This codes changes the logic to extract the collection
name form a FullConnecton string by stripping until the first
dot, and provides a test case.
---
 Database/MongoDB/Internal/Util.hs | 3 +++
 Database/MongoDB/Query.hs         | 6 +++---
 test/QuerySpec.hs                 | 8 ++++++++
 3 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs
index a1ac303..1e0c6a1 100644
--- a/Database/MongoDB/Internal/Util.hs
+++ b/Database/MongoDB/Internal/Util.hs
@@ -92,6 +92,9 @@ bitOr = foldl (.|.) 0
 -- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@
 a <.> b = T.append a (T.cons '.' b)
 
+splitDot :: Text -> (Text, Text)
+splitDot t = let (pre, post) = T.break (== '.') t in (pre, T.drop 1 post) 
+
 true1 :: Label -> Document -> Bool
 -- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool.
 true1 k doc = case valueAt k doc of
diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs
index 86667aa..eed8740 100644
--- a/Database/MongoDB/Query.hs
+++ b/Database/MongoDB/Query.hs
@@ -133,7 +133,7 @@ import Database.MongoDB.Internal.Protocol
   )
 import Control.Monad.Trans.Except
 import qualified Database.MongoDB.Internal.Protocol as P
-import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
+import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot)
 import System.Mem.Weak (Weak)
 import Text.Read (readMaybe)
 import Prelude hiding (lookup)
@@ -1273,7 +1273,7 @@ find q@Query{selection, batchSize} = do
         let newQr =
               case fst qr of
                 Req qry ->
-                  let coll = last $ T.splitOn "." (qFullCollection qry)
+                  let (_db, coll) = splitDot (qFullCollection qry)
                   in (Req $ qry {qSelector = merge (qSelector qry) [ "find" =: coll ]}, snd qr)
                 -- queryRequestOpMsg only returns Cmd types constructed via Req
                 _ -> error "impossible"
@@ -1333,7 +1333,7 @@ findOne q = do
             let newQr =
                   case fst qr of
                     Req qry ->
-                      let coll = last $ T.splitOn "." (qFullCollection qry)
+                      let (_db, coll) = splitDot (qFullCollection qry)
                           -- We have to understand whether findOne is called as
                           -- command directly. This is necessary since findOne is used via
                           -- runCommand as a vehicle to execute any type of commands and notices.
diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs
index e7aa1fa..2e2284c 100644
--- a/test/QuerySpec.hs
+++ b/test/QuerySpec.hs
@@ -76,6 +76,14 @@ spec = around withCleanDatabase $ do
       db thisDatabase `shouldReturn` testDBName
       db (useDb anotherDBName thisDatabase) `shouldReturn` anotherDBName
 
+  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")
+
+
   describe "insert" $ do
     it "inserts a document to the collection and returns its _id" $ do
       _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]