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

import           Keter.Common
import           Control.Applicative       ((<$>), (<*>), pure)
import           Keter.Aeson.KeyHelper      as AK (lookup)
import           Control.Concurrent        (forkIO)
import           Control.Concurrent.Chan
import           Control.Concurrent.MVar
import           Control.Exception         (fromException, 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 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           Prelude                   hiding (FilePath)
import           System.Directory          (createDirectoryIfMissing,
                                            doesFileExist, renameFile)
import           System.FilePath           (takeDirectory, (<.>))
import           System.IO.Error           (annotateIOError,
                                            ioeGetFileName,
                                            isDoesNotExistError)
import           System.Process            (readProcess)
import qualified System.Random             as R
import           Data.Text                  (Text)
import           System.FilePath            (FilePath)
import           Control.Exception          (SomeException)

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@.
    }
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = 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

defaultDBServerInfo :: DBServerInfo
defaultDBServerInfo :: DBServerInfo
defaultDBServerInfo = 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
defaultDBServerInfo (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
defaultDBServerInfo
                    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) = case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                       Just IOError
e' -> if IOError -> Bool
isDoesNotExistError IOError
e'
                         Bool -> Bool -> Bool
&& IOError -> Maybe FilePath
ioeGetFileName IOError
e' Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"sudo"
                         then IOError -> IO [(Text, Text)]
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO [(Text, Text)]) -> IOError -> IO [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
                         IOError -> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
annotateIOError IOError
e' FilePath
"\nWe are unable to find sudo in your local path, this could be because you don't have sudo installed. Sudo is necessary for keter to connect to postgres running on the local server.\nsudo" Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
                         else SomeException -> IO [(Text, Text)]
forall e a. Exception e => e -> IO a
throwIO SomeException
e
                       Maybe IOError
Nothing -> 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)
    ]