env-parser-0.0.2: src/System/Environment/Parser/Database.hs
-- |
-- Module : System.Environment.Parser.Database
-- Copyright : (c) Joseph Abrahamson 2013
-- License : MIT
--
-- Maintainer : me@jspha.com
-- Stability : experimental
-- Portability : non-portable
--
-- Heroku-style database connection URL parsing.
module System.Environment.Parser.Database (
DBConnection (..), Provider (..), providerString
) where
import Control.Applicative
import qualified Data.Attoparsec.Text as At
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Types as Ht
import qualified Network.URI as URI
import System.Environment.Parser.FromEnv
----------------------------------------------------------------------------
-- Heroku-style DB urls
-- | Provider indicates what kind of database provider scheme this URL
-- refers to. This provides a small amount of convenience around URL
-- detection, but if detection fails use 'providerName' to extract the raw
-- string.
data Provider = Postgres S.ByteString
| MySQL S.ByteString
| AMQP S.ByteString
| HTTP S.ByteString
| Other S.ByteString
deriving ( Eq, Ord, Show, Read )
providerString :: Provider -> S.ByteString
providerString p = case p of
Postgres s -> s
MySQL s -> s
AMQP s -> s
HTTP s -> s
Other s -> s
-- | A type representing the information that can be parsed from
-- a URL-style database configuration. For example consider the following
-- URLs
--
-- > postgres://user3123:passkja83kd8@ec2-117-21-174-214.compute-1.amazonaws.com:6212/db982398
-- > mysql://adffdadf2341:adf4234@us-cdbr-east.cleardb.com/heroku_db?reconnect=true
-- > mysql2://adffdadf2341:adf4234@us-cdbr-east.cleardb.com/heroku_db?reconnect=true
-- > http://user:pass@instance.ip/resourceid
-- > amqp://user:pass@ec2.clustername.cloudamqp.com/vhost
--
-- We assume that all the information in these URLs is provided---if
-- a username or password is unnecessary then it must be passed as an empty
-- string and not omitted.
--
data DBConnection = DBConnection
{ provider :: Provider
, host :: S.ByteString
, username :: S.ByteString
, password :: S.ByteString
, port :: Int
, location :: S.ByteString
, params :: Map.Map S.ByteString S.ByteString
}
deriving ( Eq, Ord, Show, Read )
instance FromEnv DBConnection where
parseEnv = tryParse
tryParse :: String -> Either String DBConnection
tryParse s = do
uri <- e "invalid URI format" $ URI.parseAbsoluteURI s
auth <- e "URI authority segment missing" $ URI.uriAuthority uri
port <- parsePort (URI.uriPort auth)
(username, password) <- parseUserPw (URI.uriUserInfo auth)
return DBConnection
{ provider = guessProvider (URI.uriScheme uri)
, host = S8.pack (URI.uriRegName auth)
, username = username
, password = password
, port = port
, location = S8.pack $ drop 1 $ URI.uriPath uri
, params = makeQueryMap (URI.uriQuery uri)
}
where
guessProvider :: String -> Provider
guessProvider x = case x of
"postgres:" -> Postgres bs
"mysql:" -> MySQL bs
"mysql2:" -> MySQL bs
"http:" -> HTTP bs
"amqp:" -> AMQP bs
_ -> Other bs
where bs = S8.pack s
parsePort :: String -> Either String Int
parsePort = At.parseOnly (At.char ':' *> At.decimal) . T.pack
parseUserPw :: String -> Either String (S.ByteString, S.ByteString)
parseUserPw = At.parseOnly ( (,) <$> (TE.encodeUtf8 <$> At.takeTill (==':') <* At.char ':')
<*> (TE.encodeUtf8 <$> At.takeTill (=='@') <* At.char '@') )
. T.pack
makeQueryMap :: String -> Map.Map S.ByteString S.ByteString
makeQueryMap = Map.fromList . Ht.parseSimpleQuery . S8.pack
-- -----------------------------------------------------------------------------
-- Utilities
e :: String -> Maybe a -> Either String a
e s Nothing = Left s
e _ (Just a) = Right a