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

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Error.Util (note)
import Control.Monad (guard)
#if __GLASGOW_HASKELL__ < 808
import Data.Monoid ((<>))
#endif
import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo)
import qualified Database.Redis.ConnectionContext as CC
import Network.HTTP.Base
import Network.URI (parseURI, uriPath, uriScheme)
import Text.Read (readMaybe)

import qualified Data.ByteString.Char8 as C8

-- | Parse a @'ConnectInfo'@ from a URL
--
-- Username is ignored, path is used to specify the database:
--
-- >>> parseConnectInfo "redis://username:password@host:42/2"
-- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing})
--
-- >>> 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"
--
-- Beyond that, all values are optional. Omitted values are taken from
-- @'defaultConnectInfo'@:
--
-- >>> parseConnectInfo "redis://"
-- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing})
--
parseConnectInfo :: String -> Either String ConnectInfo
parseConnectInfo :: String -> Either String ConnectInfo
parseConnectInfo String
url = do
    URI
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
    String -> Maybe () -> Either String ()
forall a b. a -> Maybe b -> Either a b
note String
"Wrong scheme" (Maybe () -> Either String ()) -> Maybe () -> Either String ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"redis:"
    URIAuthority
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 :: String
h = URIAuthority -> String
host URIAuthority
uriAuth
        dbNumPart :: String
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)

    Integer
db <- if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dbNumPart
      then Integer -> Either String Integer
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
      else String -> Maybe Integer -> Either String Integer
forall a b. a -> Maybe b -> Either a b
note (String
"Invalid port: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dbNumPart) (Maybe Integer -> Either String Integer)
-> Maybe Integer -> Either String Integer
forall a b. (a -> b) -> a -> b
$ String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe String
dbNumPart

    ConnectInfo -> Either String ConnectInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ConnectInfo
defaultConnectInfo
        { connectHost :: String
connectHost = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
h
            then ConnectInfo -> String
connectHost ConnectInfo
defaultConnectInfo
            else String
h
        , connectPort :: PortID
connectPort = PortID -> (Int -> PortID) -> Maybe Int -> PortID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectInfo -> PortID
connectPort ConnectInfo
defaultConnectInfo) (PortNumber -> PortID
CC.PortNumber (PortNumber -> PortID) -> (Int -> PortNumber) -> Int -> PortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (URIAuthority -> Maybe Int
port URIAuthority
uriAuth)
        , connectAuth :: Maybe ByteString
connectAuth = String -> ByteString
C8.pack (String -> ByteString) -> Maybe String -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URIAuthority -> Maybe String
password URIAuthority
uriAuth
        , connectDatabase :: Integer
connectDatabase = Integer
db
        }