{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Database.Redis.URL
    ( parseConnectInfo
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import qualified Data.ByteString.Char8 as C8
import Control.Error.Util (note)
#if __GLASGOW_HASKELL__ < 808
import Data.Monoid ((<>))
#endif
import Data.String (fromString)
import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo)
import qualified Database.Redis.ConnectionContext as CC
import Network.HTTP.Base
import Network.URI (parseURI, uriPath, uriScheme, uriQuery, URI)
import Network.TLS (defaultParamsClient)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types (parseSimpleQuery)
import Text.Read (readMaybe)


-- | Parse a @'ConnectInfo'@ from a URL according to the Rules in Redis client
--
-- __Standalone Redis__:
--
-- @
-- redis :\/\/ [[username :] password@] host [:port][/database]
-- @
--
-- >>> parseConnectInfo "redis://username:password@host:42/2"
-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Just "username", connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})
--
-- >>> parseConnectInfo "redis://password@host:42/2"
-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})
--
-- __TLS-enabled Redis__:
--
-- @
-- rediss :\/\/ [[username :] password@] host [: port][/database]
-- @
--
-- __Unix socket Redis__:
--
-- @
-- redis-socket :// [[username :] password@]path [? [&database=database]
-- @
--
-- >>> parseConnectInfo "redis-socket://password@/tmp/redis.sock?database=2"
-- Right (ConnInfo {connectAddr = ConnectAddrUnixSocket "/tmp/redis.sock", connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})
--
-- >>> parseConnectInfo "redis://username:password@host:42/db"
-- Left "Invalid port: db"
--
-- The scheme is validated, to prevent mixing up configurations:
--
-- >>> parseConnectInfo "postgres://"
-- Left "Wrong scheme postgres:"
--
-- Beyond that, all values are optional. Omitted values are taken from
-- @'defaultConnectInfo'@:
--
-- >>> parseConnectInfo "rediss://"
-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "localhost" 6379, connectAuth = Nothing, connectUsername = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Just (ClientParams ...), connectHooks = Hooks {...}, connectPoolLabel = ""})
--
parseConnectInfo :: String -> Either String ConnectInfo
parseConnectInfo :: String -> Either String ConnectInfo
parseConnectInfo String
url = do
    uri <- String -> Maybe URI -> Either String URI
forall a b. a -> Maybe b -> Either a b
note String
"Invalid URI" (Maybe URI -> Either String URI) -> Maybe URI -> Either String URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
url
    let userScheme = URI -> String
uriScheme URI
uri
    case userScheme of
        String
"redis:" -> Bool -> URI -> Either String ConnectInfo
parseSocket Bool
False URI
uri
        String
"rediss:" -> Bool -> URI -> Either String ConnectInfo
parseSocket Bool
True URI
uri
        String
"redis-socket:" -> URI -> Either String ConnectInfo
parseUnix URI
uri
        String
x -> String -> Either String ConnectInfo
forall a b. a -> Either a b
Left (String
"Wrong scheme " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
    where
        parseSocket :: Bool -> URI -> Either String ConnectInfo
        parseSocket :: Bool -> URI -> Either String ConnectInfo
parseSocket Bool
isSecure URI
uri = do
            uriAuth <- String -> Maybe URIAuthority -> Either String URIAuthority
forall a b. a -> Maybe b -> Either a b
note String
"Missing or invalid Authority"
                (Maybe URIAuthority -> Either String URIAuthority)
-> Maybe URIAuthority -> Either String URIAuthority
forall a b. (a -> b) -> a -> b
$ String -> Maybe URIAuthority
parseURIAuthority
                (String -> Maybe URIAuthority) -> String -> Maybe URIAuthority
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToAuthorityString URI
uri

            let h = URIAuthority -> String
host URIAuthority
uriAuth
                dbNumPart = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (URI -> String
uriPath URI
uri)

            db <- if null dbNumPart
              then return $ connectDatabase defaultConnectInfo
              else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart

            let finalHost = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
h
                    then case ConnectInfo -> ConnectAddr
connectAddr ConnectInfo
defaultConnectInfo of
                      CC.ConnectAddrHostPort String
defaultHost PortNumber
_ -> String
defaultHost
                      CC.ConnectAddrUnixSocket String
_ -> String
"localhost"
                    else String
h

            let (finalUser, finalAuth) = case (T.pack <$> user uriAuth, T.pack <$> password uriAuth) of
                    (Maybe Text
p, Maybe Text
Nothing) -> (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
p)
                    (Maybe Text
p, (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip -> Just Text
"") -> (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
p)
                    (Maybe Text
u, Maybe Text
p) -> (Maybe Text
u, Maybe Text
p)

            return defaultConnectInfo
                { connectAddr =
                    CC.ConnectAddrHostPort
                      finalHost
                      (maybe defaultPort fromIntegral (port uriAuth))
                , connectAuth = T.encodeUtf8 <$> finalAuth
                , connectUsername = T.encodeUtf8 <$> finalUser
                , connectDatabase = db
                , connectTLSParams = case isSecure of
                     Bool
False -> Maybe ClientParams
forall a. Maybe a
Nothing
                     Bool
True -> ClientParams -> Maybe ClientParams
forall a. a -> Maybe a
Just (ClientParams -> Maybe ClientParams)
-> ClientParams -> Maybe ClientParams
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> ClientParams
defaultParamsClient String
finalHost ByteString
""
                }
          where
            defaultPort :: PortNumber
defaultPort = case ConnectInfo -> ConnectAddr
connectAddr ConnectInfo
defaultConnectInfo of
              CC.ConnectAddrHostPort String
_ PortNumber
portNum -> PortNumber
portNum
              CC.ConnectAddrUnixSocket String
_ -> PortNumber
6379

        parseUnix :: URI -> Either String ConnectInfo
        parseUnix :: URI -> Either String ConnectInfo
parseUnix URI
uri = do
            auth <- String -> Maybe URIAuthority -> Either String URIAuthority
forall a b. a -> Maybe b -> Either a b
note String
"Missing or invalid Authority"
                (Maybe URIAuthority -> Either String URIAuthority)
-> Maybe URIAuthority -> Either String URIAuthority
forall a b. (a -> b) -> a -> b
$ String -> Maybe URIAuthority
parseURIAuthority
                (String -> Maybe URIAuthority) -> String -> Maybe URIAuthority
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToAuthorityString URI
uri
            db <- case lookup "database" query of
                    Maybe ByteString
Nothing -> Integer -> Either String Integer
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Either String Integer)
-> Integer -> Either String Integer
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Integer
connectDatabase ConnectInfo
defaultConnectInfo
                    Just ByteString
dbNumPart ->
                        String -> Maybe Integer -> Either String Integer
forall a b. a -> Maybe b -> Either a b
note String
"Invalid database" (Maybe Integer -> Either String Integer)
-> Maybe Integer -> Either String Integer
forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> Maybe a
readMaybe @Integer (String -> Maybe Integer)
-> (Text -> String) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe Integer) -> Text -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
dbNumPart
            return defaultConnectInfo
                { connectAddr = CC.ConnectAddrUnixSocket (mkPath auth)
                , connectAuth = C8.pack <$> (user auth)
                , connectDatabase = (db :: Integer)
                }
            where
                mkPath :: URIAuthority -> String
mkPath URIAuthority
auth =
                    case URIAuthority -> String
host URIAuthority
auth String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
uriPath URI
uri of
                        (Char
'/':String
_) -> URIAuthority -> String
host URIAuthority
auth String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
uriPath URI
uri
                        String
_ -> Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: URIAuthority -> String
host URIAuthority
auth String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
uriPath URI
uri
                query :: [(ByteString, ByteString)]
query = ByteString -> [(ByteString, ByteString)]
parseSimpleQuery (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriQuery URI
uri)