{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Keter.Plugin.Postgres
    ( -- * Settings
      Settings
    , setupDBInfo
      -- * Functions
    , load
    ) where

import           Control.Applicative       ((<$>), (<*>), pure)
import           Data.Aeson.KeyHelper      as AK (lookup)
import           Control.Concurrent        (forkIO)
import           Control.Concurrent.Chan
import           Control.Concurrent.MVar
import           Control.Exception         (throwIO, try)
import           Control.Monad             (forever, mzero, replicateM, void)
import           Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as S
import qualified Data.Char                 as C
import           Data.Default
import qualified Data.Map                  as Map
import           Data.Maybe                (fromMaybe)
import           Data.Monoid               ((<>))
import qualified Data.Text                 as T
import qualified Data.Text.Lazy            as TL
import           Data.Text.Lazy.Builder    (fromText, toLazyText)
import qualified Data.Vector               as V
import           Data.Yaml
import           Keter.Types
import           Prelude                   hiding (FilePath)
import           System.Directory          (createDirectoryIfMissing,
                                            doesFileExist, renameFile)
import           System.FilePath           (takeDirectory, (<.>))
import           System.Process            (readProcess)
import qualified System.Random             as R

data Settings = Settings
    { Settings -> DBInfo -> IO ()
setupDBInfo :: DBInfo -> IO ()
      -- ^ How to create the given user/database. Default: uses the @psql@
      -- command line tool and @sudo -u postgres@.
    }

instance Default Settings where
    def :: Settings
def = Settings :: (DBInfo -> IO ()) -> Settings
Settings
        { setupDBInfo :: DBInfo -> IO ()
setupDBInfo = \DBInfo{Text
DBServerInfo
dbiServer :: DBInfo -> DBServerInfo
dbiPass :: DBInfo -> Text
dbiUser :: DBInfo -> Text
dbiName :: DBInfo -> Text
dbiServer :: DBServerInfo
dbiPass :: Text
dbiUser :: Text
dbiName :: Text
..} -> do
            let sql :: Text
sql = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
                    Builder
"CREATE USER "         Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
dbiUser Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                    Builder
" PASSWORD '"          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
dbiPass Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                    Builder
"';\nCREATE DATABASE " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
dbiName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                    Builder
" OWNER "              Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
dbiUser Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                    Builder
";"
                (FilePath
cmd, [FilePath]
args) 
                    | (  DBServerInfo -> Text
dbServer DBServerInfo
dbiServer Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"localhost" 
                      Bool -> Bool -> Bool
|| DBServerInfo -> Text
dbServer DBServerInfo
dbiServer Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"127.0.0.1") = 
                        (FilePath
"sudo", [FilePath
"-u", FilePath
"postgres", FilePath
"psql"])
                    | Bool
otherwise = 
                        (FilePath
"psql",
                        [ FilePath
"-h", (Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ DBServerInfo -> Text
dbServer DBServerInfo
dbiServer)
                        , FilePath
"-p", (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ DBServerInfo -> Int
dbPort DBServerInfo
dbiServer)
                        , FilePath
"-U", FilePath
"postgres"])
            FilePath
_ <- FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
cmd [FilePath]
args (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
TL.unpack Text
sql
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }

-- | Information on an individual PostgreSQL database.
data DBInfo = DBInfo
    { DBInfo -> Text
dbiName   :: Text
    , DBInfo -> Text
dbiUser   :: Text
    , DBInfo -> Text
dbiPass   :: Text
    , DBInfo -> DBServerInfo
dbiServer :: DBServerInfo
    }
    deriving Int -> DBInfo -> ShowS
[DBInfo] -> ShowS
DBInfo -> FilePath
(Int -> DBInfo -> ShowS)
-> (DBInfo -> FilePath) -> ([DBInfo] -> ShowS) -> Show DBInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DBInfo] -> ShowS
$cshowList :: [DBInfo] -> ShowS
show :: DBInfo -> FilePath
$cshow :: DBInfo -> FilePath
showsPrec :: Int -> DBInfo -> ShowS
$cshowsPrec :: Int -> DBInfo -> ShowS
Show

data DBServerInfo = DBServerInfo
    { DBServerInfo -> Text
dbServer :: Text
    , DBServerInfo -> Int
dbPort   :: Int
    }
    deriving Int -> DBServerInfo -> ShowS
[DBServerInfo] -> ShowS
DBServerInfo -> FilePath
(Int -> DBServerInfo -> ShowS)
-> (DBServerInfo -> FilePath)
-> ([DBServerInfo] -> ShowS)
-> Show DBServerInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DBServerInfo] -> ShowS
$cshowList :: [DBServerInfo] -> ShowS
show :: DBServerInfo -> FilePath
$cshow :: DBServerInfo -> FilePath
showsPrec :: Int -> DBServerInfo -> ShowS
$cshowsPrec :: Int -> DBServerInfo -> ShowS
Show

randomDBI :: DBServerInfo -> R.StdGen -> (DBInfo, R.StdGen)
randomDBI :: DBServerInfo -> StdGen -> (DBInfo, StdGen)
randomDBI DBServerInfo
dbsi =
    State StdGen DBInfo -> StdGen -> (DBInfo, StdGen)
forall s a. State s a -> s -> (a, s)
S.runState (Text -> Text -> Text -> DBServerInfo -> DBInfo
DBInfo (Text -> Text -> Text -> DBServerInfo -> DBInfo)
-> StateT StdGen Identity Text
-> StateT StdGen Identity (Text -> Text -> DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT StdGen Identity Text
rt StateT StdGen Identity (Text -> Text -> DBServerInfo -> DBInfo)
-> StateT StdGen Identity Text
-> StateT StdGen Identity (Text -> DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT StdGen Identity Text
rt StateT StdGen Identity (Text -> DBServerInfo -> DBInfo)
-> StateT StdGen Identity Text
-> StateT StdGen Identity (DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT StdGen Identity Text
rt StateT StdGen Identity (DBServerInfo -> DBInfo)
-> StateT StdGen Identity DBServerInfo -> State StdGen DBInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DBServerInfo -> StateT StdGen Identity DBServerInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure DBServerInfo
dbsi)) 
  where
    rt :: StateT StdGen Identity Text
rt = FilePath -> Text
T.pack (FilePath -> Text)
-> StateT StdGen Identity FilePath -> StateT StdGen Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> StateT StdGen Identity Char -> StateT StdGen Identity FilePath
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
10 ((StdGen -> (Char, StdGen)) -> StateT StdGen Identity Char
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
S.state ((StdGen -> (Char, StdGen)) -> StateT StdGen Identity Char)
-> (StdGen -> (Char, StdGen)) -> StateT StdGen Identity Char
forall a b. (a -> b) -> a -> b
$ (Char, Char) -> StdGen -> (Char, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
R.randomR (Char
'a', Char
'z'))

instance ToJSON DBInfo where
    toJSON :: DBInfo -> Value
toJSON (DBInfo Text
n Text
u Text
p (DBServerInfo Text
server Int
port)) = [Pair] -> Value
object
        [ Key
"name"   Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
n
        , Key
"user"   Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
u
        , Key
"pass"   Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
p
        , Key
"server" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
server
        , Key
"port"   Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
port
        ]

instance FromJSON DBInfo where
    parseJSON :: Value -> Parser DBInfo
parseJSON (Object Object
o) = Text -> Text -> Text -> DBServerInfo -> DBInfo
DBInfo
        (Text -> Text -> Text -> DBServerInfo -> DBInfo)
-> Parser Text -> Parser (Text -> Text -> DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
        Parser (Text -> Text -> DBServerInfo -> DBInfo)
-> Parser Text -> Parser (Text -> DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user"
        Parser (Text -> DBServerInfo -> DBInfo)
-> Parser Text -> Parser (DBServerInfo -> DBInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pass"
        Parser (DBServerInfo -> DBInfo)
-> Parser DBServerInfo -> Parser DBInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Int -> DBServerInfo
DBServerInfo
            (Text -> Int -> DBServerInfo)
-> Parser Text -> Parser (Int -> DBServerInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"server" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"localhost"
            Parser (Int -> DBServerInfo) -> Parser Int -> Parser DBServerInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port"   Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
5432)
    parseJSON Value
_ = Parser DBInfo
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance FromJSON DBServerInfo where
    parseJSON :: Value -> Parser DBServerInfo
parseJSON (Object Object
o) = Text -> Int -> DBServerInfo
DBServerInfo
        (Text -> Int -> DBServerInfo)
-> Parser Text -> Parser (Int -> DBServerInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"server"
        Parser (Int -> DBServerInfo) -> Parser Int -> Parser DBServerInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"port"
    parseJSON Value
_ = Parser DBServerInfo
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    
instance Default DBServerInfo where
    def :: DBServerInfo
def = Text -> Int -> DBServerInfo
DBServerInfo Text
"localhost" Int
5432

data Command = GetConfig Appname DBServerInfo (Either SomeException DBInfo -> IO ())

-- | Load a set of existing connections from a config file. If the file does
-- not exist, it will be created. Any newly created databases will
-- automatically be saved to this file.
load :: Settings -> FilePath -> IO Plugin
load :: Settings -> FilePath -> IO Plugin
load Settings{DBInfo -> IO ()
setupDBInfo :: DBInfo -> IO ()
setupDBInfo :: Settings -> DBInfo -> IO ()
..} FilePath
fp = do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory FilePath
fp
    Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
fp
    Either ParseException (Map Text DBInfo)
edb <- if Bool
e
        then FilePath -> IO (Either ParseException (Map Text DBInfo))
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
fp
        else Either ParseException (Map Text DBInfo)
-> IO (Either ParseException (Map Text DBInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseException (Map Text DBInfo)
 -> IO (Either ParseException (Map Text DBInfo)))
-> Either ParseException (Map Text DBInfo)
-> IO (Either ParseException (Map Text DBInfo))
forall a b. (a -> b) -> a -> b
$ Map Text DBInfo -> Either ParseException (Map Text DBInfo)
forall a b. b -> Either a b
Right Map Text DBInfo
forall k a. Map k a
Map.empty
    case Either ParseException (Map Text DBInfo)
edb of
        Left ParseException
ex -> ParseException -> IO Plugin
forall e a. Exception e => e -> IO a
throwIO ParseException
ex
        Right Map Text DBInfo
db -> Map Text DBInfo -> IO Plugin
go Map Text DBInfo
db
  where
    go :: Map Text DBInfo -> IO Plugin
go Map Text DBInfo
db0 = do
        Chan Command
chan <- IO (Chan Command)
forall a. IO (Chan a)
newChan
        StdGen
g0 <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
R.newStdGen
        -- FIXME stop using the worker thread approach?
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (StateT (Map Text DBInfo, StdGen) IO ()
 -> (Map Text DBInfo, StdGen) -> IO ())
-> (Map Text DBInfo, StdGen)
-> StateT (Map Text DBInfo, StdGen) IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map Text DBInfo, StdGen) IO ()
-> (Map Text DBInfo, StdGen) -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
S.evalStateT (Map Text DBInfo
db0, StdGen
g0) (StateT (Map Text DBInfo, StdGen) IO () -> IO ())
-> StateT (Map Text DBInfo, StdGen) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StateT (Map Text DBInfo, StdGen) IO ()
-> StateT (Map Text DBInfo, StdGen) IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (StateT (Map Text DBInfo, StdGen) IO ()
 -> StateT (Map Text DBInfo, StdGen) IO ())
-> StateT (Map Text DBInfo, StdGen) IO ()
-> StateT (Map Text DBInfo, StdGen) IO ()
forall a b. (a -> b) -> a -> b
$ Chan Command -> StateT (Map Text DBInfo, StdGen) IO ()
loop Chan Command
chan
        Plugin -> IO Plugin
forall (m :: * -> *) a. Monad m => a -> m a
return Plugin :: (Text -> Object -> IO [(Text, Text)]) -> Plugin
Plugin
            { pluginGetEnv :: Text -> Object -> IO [(Text, Text)]
pluginGetEnv = \Text
appname Object
o ->
                case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AK.lookup Key
"postgres" Object
o of
                    Just (Array Array
v) -> do
                        let dbServer :: DBServerInfo
dbServer = DBServerInfo -> Maybe DBServerInfo -> DBServerInfo
forall a. a -> Maybe a -> a
fromMaybe DBServerInfo
forall a. Default a => a
def (Maybe DBServerInfo -> DBServerInfo)
-> (Value -> Maybe DBServerInfo) -> Value -> DBServerInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser DBServerInfo) -> Value -> Maybe DBServerInfo
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser DBServerInfo
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> DBServerInfo) -> Value -> DBServerInfo
forall a b. (a -> b) -> a -> b
$ Array -> Value
forall a. Vector a -> a
V.head Array
v
                        Chan Command -> Text -> DBServerInfo -> IO [(Text, Text)]
doenv Chan Command
chan Text
appname DBServerInfo
dbServer
                    Just (Bool Bool
True) -> do
                        Chan Command -> Text -> DBServerInfo -> IO [(Text, Text)]
doenv Chan Command
chan Text
appname DBServerInfo
forall a. Default a => a
def
                    Maybe Value
_ -> [(Text, Text)] -> IO [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            }
      where doenv :: Chan Command -> Text -> DBServerInfo -> IO [(Text, Text)]
doenv Chan Command
chan Text
appname DBServerInfo
dbs = do
            MVar (Either SomeException DBInfo)
x <- IO (MVar (Either SomeException DBInfo))
forall a. IO (MVar a)
newEmptyMVar
            Chan Command -> Command -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Command
chan (Command -> IO ()) -> Command -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
-> DBServerInfo
-> (Either SomeException DBInfo -> IO ())
-> Command
GetConfig Text
appname DBServerInfo
dbs ((Either SomeException DBInfo -> IO ()) -> Command)
-> (Either SomeException DBInfo -> IO ()) -> Command
forall a b. (a -> b) -> a -> b
$ MVar (Either SomeException DBInfo)
-> Either SomeException DBInfo -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException DBInfo)
x
            Either SomeException DBInfo
edbi <- MVar (Either SomeException DBInfo)
-> IO (Either SomeException DBInfo)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException DBInfo)
x
            Either SomeException DBInfo -> IO [(Text, Text)]
edbiToEnv Either SomeException DBInfo
edbi
                    
    tmpfp :: FilePath
tmpfp = FilePath
fp FilePath -> ShowS
<.> FilePath
"tmp"

    loop :: Chan Command -> StateT (Map Text DBInfo, StdGen) IO ()
loop Chan Command
chan = do
        GetConfig Text
appname DBServerInfo
dbServer Either SomeException DBInfo -> IO ()
f <- IO Command -> StateT (Map Text DBInfo, StdGen) IO Command
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Command -> StateT (Map Text DBInfo, StdGen) IO Command)
-> IO Command -> StateT (Map Text DBInfo, StdGen) IO Command
forall a b. (a -> b) -> a -> b
$ Chan Command -> IO Command
forall a. Chan a -> IO a
readChan Chan Command
chan
        (Map Text DBInfo
db, StdGen
g) <- StateT (Map Text DBInfo, StdGen) IO (Map Text DBInfo, StdGen)
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
        Either SomeException DBInfo
dbi <-
            case Text -> Map Text DBInfo -> Maybe DBInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
appname Map Text DBInfo
db of
                Just DBInfo
dbi -> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException DBInfo
 -> StateT
      (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo))
-> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall a b. (a -> b) -> a -> b
$ DBInfo -> Either SomeException DBInfo
forall a b. b -> Either a b
Right DBInfo
dbi
                Maybe DBInfo
Nothing -> do
                    let (DBInfo
dbi', StdGen
g') = DBServerInfo -> StdGen -> (DBInfo, StdGen)
randomDBI DBServerInfo
dbServer StdGen
g
                    let dbi :: DBInfo
dbi = DBInfo
dbi'
                            { dbiName :: Text
dbiName = Text -> Text
sanitize Text
appname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBInfo -> Text
dbiName DBInfo
dbi'
                            , dbiUser :: Text
dbiUser = Text -> Text
sanitize Text
appname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBInfo -> Text
dbiUser DBInfo
dbi'
                            }
                    Either SomeException ()
ex <- IO (Either SomeException ())
-> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either SomeException ())
 -> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ()))
-> IO (Either SomeException ())
-> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ DBInfo -> IO ()
setupDBInfo DBInfo
dbi
                    case Either SomeException ()
ex of
                        Left SomeException
e -> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException DBInfo
 -> StateT
      (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo))
-> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException DBInfo
forall a b. a -> Either a b
Left SomeException
e
                        Right () -> do
                            let db' :: Map Text DBInfo
db' = Text -> DBInfo -> Map Text DBInfo -> Map Text DBInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
appname DBInfo
dbi Map Text DBInfo
db
                            Either SomeException ()
ey <- IO (Either SomeException ())
-> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either SomeException ())
 -> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ()))
-> IO (Either SomeException ())
-> StateT (Map Text DBInfo, StdGen) IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
                                FilePath -> Map Text DBInfo -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
encodeFile FilePath
tmpfp Map Text DBInfo
db'
                                FilePath -> FilePath -> IO ()
renameFile FilePath
tmpfp FilePath
fp
                            case Either SomeException ()
ey of
                                Left SomeException
e -> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException DBInfo
 -> StateT
      (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo))
-> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException DBInfo
forall a b. a -> Either a b
Left SomeException
e
                                Right () -> do
                                    (Map Text DBInfo, StdGen) -> StateT (Map Text DBInfo, StdGen) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (Map Text DBInfo
db', StdGen
g')
                                    Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException DBInfo
 -> StateT
      (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo))
-> Either SomeException DBInfo
-> StateT
     (Map Text DBInfo, StdGen) IO (Either SomeException DBInfo)
forall a b. (a -> b) -> a -> b
$ DBInfo -> Either SomeException DBInfo
forall a b. b -> Either a b
Right DBInfo
dbi
        IO () -> StateT (Map Text DBInfo, StdGen) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (Map Text DBInfo, StdGen) IO ())
-> IO () -> StateT (Map Text DBInfo, StdGen) IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException DBInfo -> IO ()
f Either SomeException DBInfo
dbi

    sanitize :: Text -> Text
sanitize = (Char -> Char) -> Text -> Text
T.map Char -> Char
sanitize'
    sanitize' :: Char -> Char
sanitize' Char
c
        | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char -> Char
C.toLower Char
c
        | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
        | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char
c
        | Bool
otherwise = Char
'_'

edbiToEnv :: Either SomeException DBInfo
          -> IO [(Text, Text)]
edbiToEnv :: Either SomeException DBInfo -> IO [(Text, Text)]
edbiToEnv (Left SomeException
e) = SomeException -> IO [(Text, Text)]
forall e a. Exception e => e -> IO a
throwIO SomeException
e
edbiToEnv (Right DBInfo
dbi) = [(Text, Text)] -> IO [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ (Text
"PGHOST", DBServerInfo -> Text
dbServer (DBServerInfo -> Text) -> DBServerInfo -> Text
forall a b. (a -> b) -> a -> b
$ DBInfo -> DBServerInfo
dbiServer DBInfo
dbi)
    , (Text
"PGPORT", FilePath -> Text
T.pack (FilePath -> Text)
-> (DBServerInfo -> FilePath) -> DBServerInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath)
-> (DBServerInfo -> Int) -> DBServerInfo -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBServerInfo -> Int
dbPort (DBServerInfo -> Text) -> DBServerInfo -> Text
forall a b. (a -> b) -> a -> b
$ DBInfo -> DBServerInfo
dbiServer DBInfo
dbi)
    , (Text
"PGUSER", DBInfo -> Text
dbiUser DBInfo
dbi)
    , (Text
"PGPASS", DBInfo -> Text
dbiPass DBInfo
dbi)
    , (Text
"PGDATABASE", DBInfo -> Text
dbiName DBInfo
dbi)
    ]