Fix for bitemyapp/bloodhound#38

Utilize `Network.URI.escapeURIString` to escape characters before parsing a string into an URI

README.md

@@ -886,6 +886,7 @@ Contributors
 * [Maximilian Tagher](https://github.com/MaxGabriel)
 * [Anna Kopp](https://github.com/annakopp)
 * [Matvey B. Aksenov](https://github.com/supki)
+* [Jan-Philip Loos](https://github.com/MaxDaten)
 
 Possible future functionality
 =============================

bloodhound.cabal

@@ -28,6 +28,7 @@ library
                        containers       >= 0.5.0.0 && <0.6,
                        aeson            >= 0.7     && <0.10,
                        http-client      >= 0.3     && <0.5,
+                       network-uri      >= 2.6     && <2.7,
                        semigroups       >= 0.15    && <0.18,
                        time             >= 1.4     && <1.6,
                        text             >= 0.11    && <1.3,
@@ -35,7 +36,6 @@ library
                        transformers     >= 0.2     && <0.5,
                        http-types       >= 0.8     && <0.9,
                        vector           >= 0.10.9  && <0.12,
-                       uri-bytestring   >= 0.1     && <0.2,
                        exceptions,
                        data-default-class,
                        blaze-builder,

src/Database/Bloodhound/Client.hs

@@ -66,7 +66,6 @@ import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.ByteString.Lazy.Builder
 import qualified Data.ByteString.Lazy.Char8   as L
-import           Data.Default.Class
 import           Data.Ix
 import qualified Data.List                    as LS (filter)
 import           Data.Maybe                   (fromMaybe, isJust)
@@ -79,8 +78,8 @@ import           Network.HTTP.Client
 import qualified Network.HTTP.Types.Method    as NHTM
 import qualified Network.HTTP.Types.Status    as NHTS
 import qualified Network.HTTP.Types.URI       as NHTU
+import qualified Network.URI                  as URI
 import           Prelude                      hiding (filter, head)
-import           URI.ByteString               hiding (Query)
 
 import           Database.Bloodhound.Types
 
@@ -631,32 +630,7 @@ pageSearch :: From     -- ^ The result offset
 pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
 
 parseUrl' :: MonadThrow m => Text -> m Request
-parseUrl' t =
-  case parseURI laxURIParserOptions (T.encodeUtf8 t) of
-    Right uri -> setURI def uri
-    Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e)
-
-setURI :: MonadThrow m => Request -> URI -> m Request
-setURI req URI{..} = do
-  Authority {..} <- maybe missingUA return uriAuthority
-  let req' = req { secure = isSecure
-                 , host   = hostBS authorityHost
-                 , port   = thePort
-                 , path   = uriPath
-                 }
-      thePort = maybe defPort portNumber authorityPort
-      addAuth = maybe id addAuth' authorityUserInfo
-  return $ setQueryString theQueryString $ addAuth req'
-  where
-    missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port"
-    addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword
-    defPort
-      | isSecure  = 443
-      | otherwise = 80
-    isSecure = case uriScheme of
-      Scheme "https" -> True
-      _              -> False
-    theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]
+parseUrl' t = parseUrl (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
 
 -- | Was there an optimistic concurrency control conflict when
 -- indexing a document?

stack-7.10.yaml

@@ -5,5 +5,4 @@ extra-deps:
 - doctest-0.10.1
 - doctest-prop-0.2.0.1
 - quickcheck-properties-0.1
-- uri-bytestring-0.1.2
 resolver: lts-3.1

stack.yaml

@@ -5,5 +5,4 @@ extra-deps:
 - doctest-0.10.1
 - doctest-prop-0.2.0.1
 - quickcheck-properties-0.1
-- uri-bytestring-0.1.2
 resolver: lts-2.18

tests/tests.hs

@@ -187,9 +187,9 @@ insertOther = do
   _ <- refreshIndex testIndex
   return ()
 
-insertOtherWithSpaceInId :: BH IO ()
-insertOtherWithSpaceInId = do
-  _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "Hello World")
+insertWithSpaceInId :: BH IO ()
+insertWithSpaceInId = do
+  _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
   _ <- refreshIndex testIndex
   return ()
 
@@ -336,7 +336,7 @@ main = hspec $ do
       liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
 
     it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
-      _ <- insertOtherWithSpaceInId
+      _ <- insertWithSpaceInId
       docInserted <- getDocument testIndex testMapping (DocId "Hello World")
       let newTweet = eitherDecode
                      (responseBody docInserted) :: Either String (EsResult Tweet)