@@ -1,4 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
23
34-------------------------------------------------------------------------------
45-- |
@@ -51,19 +52,25 @@ module Database.Bloodhound.Client
5152
5253import Control.Applicative
5354import Control.Monad
55+import Control.Monad.Catch
5456import Control.Monad.IO.Class
5557import Data.Aeson
58+import qualified Data.ByteString.Char8 as B8
5659import Data.ByteString.Lazy.Builder
5760import qualified Data.ByteString.Lazy.Char8 as L
61+import Data.Default.Class
5862import Data.List (intercalate)
5963import Data.Maybe (fromMaybe)
6064import Data.Text (Text)
6165import qualified Data.Text as T
66+import qualified Data.Text.Encoding as T
6267import qualified Data.Vector as V
6368import Network.HTTP.Client
6469import qualified Network.HTTP.Types.Method as NHTM
6570import qualified Network.HTTP.Types.Status as NHTS
6671import Prelude hiding (filter, head)
72+import URI.ByteString hiding (Query)
73+import qualified URI.ByteString as UB
6774
6875import Database.Bloodhound.Types
6976
@@ -140,7 +147,7 @@ emptyBody = L.pack ""
140147dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
141148 -> m Reply
142149dispatch dMethod url body = do
143− initReq <- liftIO $ parseUrl url
150+ initReq <- liftIO $ parseUrl' url
144151 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
145152 let req = initReq { method = dMethod
146153 , requestBody = reqBody
@@ -194,7 +201,7 @@ post = dispatch NHTM.methodPost
194201getStatus :: MonadBH m => m (Maybe Status)
195202getStatus = do
196203 url <- joinPath []
197− request <- liftIO $ parseUrl url
204+ request <- liftIO $ parseUrl' url
198205 mgr <- bhManager <$> getBHEnv
199206 response <- liftIO $ httpLbs request mgr
200207 return $ decode (responseBody response)
@@ -504,3 +511,31 @@ pageSearch :: Int -- ^ The result offset
504511 -> Search -- ^ The current seach
505512 -> Search -- ^ The paged search
506513pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
514+
515+parseUrl' :: MonadThrow m => Text -> m Request
516+parseUrl' t =
517+ case parseURI laxURIParserOptions (T.encodeUtf8 t) of
518+ Right uri -> setURI def uri
519+ Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e)
520+
521+setURI :: MonadThrow m => Request -> URI -> m Request
522+setURI req URI{..} = do
523+ Authority {..} <- maybe missingUA return uriAuthority
524+ let req' = req { secure = isSecure
525+ , host = getHost authorityHost
526+ , port = thePort
527+ , path = uriPath
528+ }
529+ thePort = maybe defPort (read . B8.unpack . getPort) authorityPort
530+ addAuth = maybe id addAuth' authorityUserInfo
531+ return $ setQueryString theQueryString $ addAuth req'
532+ where
533+ missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port"
534+ addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword
535+ defPort
536+ | isSecure = 443
537+ | otherwise = 80
538+ isSecure = case uriScheme of
539+ Scheme "https" -> True
540+ _ -> False
541+ theQueryString = [(k , Just v) | (k, v) <- getQuery uriQuery]