Core.hs

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE TypeApplications #-}

module Arbor.Postgres.Core where

import Arbor.Postgres.Config     (PostgresConfig)
import Arbor.Postgres.Password
import Control.Lens
import Data.Generics.Product.Any
import Data.Monoid               ((<>))
import Data.String
import Network.URI

import qualified Arbor.Postgres.Env         as E
import qualified Data.Text                  as T
import qualified Data.Text.Encoding         as T
import qualified Database.PostgreSQL.Simple as PGS

connectPostgres :: PostgresConfig -> IO E.PostgresEnv
connectPostgres postgresConfig = do
  let host     = postgresConfig ^. the @"host"
  let dbname   = postgresConfig ^. the @"database"
  let user     = postgresConfig ^. the @"user"
  let mPassword = postgresConfig ^. the @"password"
  let kvPassword = case mPassword of
        Just (Password password) -> [("password", password)]
        Nothing                  -> []
  let kvs = [("host", host), ("dbname", dbname), ("user", user)] <> kvPassword
  let kvStrings = kvs <&> (\(k, v) -> k <> "='" <> v <> "'")
  conn <- PGS.connectPostgreSQL $ T.encodeUtf8 $ T.intercalate " " kvStrings
  return $ E.PostgresEnv conn (mkConnectionString postgresConfig)

newtype Table = Table
  { table :: T.Text }
  deriving (IsString, Show)

mkConnectionString :: PostgresConfig -> URI
mkConnectionString config = do
  let host = config ^. the @"host" & T.unpack
  let dbname = config ^. the @"database" & T.unpack
  let auth = pure $ URIAuth "" host ":5432"
  let q = ""
  let frag = ""
  URI "postgresql:" auth ("/" <> dbname) q frag

mkResourceURI :: URI -> Table -> [(T.Text, T.Text)] -> URI
mkResourceURI uri (Table tbl) kvs = do
  let q = "?" <> T.intercalate "&" (uncurry (\k v -> k <> "=" <> v) <$> (("table", tbl) : kvs)) & T.unpack
  uri { uriQuery = q }