{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
module Keter.HostManager
(
HostManager
, Reservations
, reserveHosts
, forgetReservations
, activateApp
, deactivateApp
, reactivateApp
, lookupAction
, start
) where
import Keter.Context
import Control.Applicative
import Control.Exception (assert, throwIO)
import Control.Monad.Logger
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import qualified Data.CaseInsensitive as CI
import Data.Either (partitionEithers)
import Data.IORef
import Data.Text (pack, unpack)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text.Encoding (encodeUtf8)
import Keter.Config
import Keter.LabelMap (LabelMap)
import qualified Keter.LabelMap as LabelMap
import Prelude hiding (log)
import qualified Network.TLS as TLS
import Keter.Common
import System.FilePath (FilePath)
import Data.Set (Set)
import Data.Map (Map)
data HostValue = HVActive !AppId !ProxyAction !TLS.Credentials
| HVReserved !AppId
newtype HostManager = HostManager (IORef (LabelMap HostValue))
type Reservations = Set.Set Host
start :: IO HostManager
start :: IO HostManager
start = IORef (LabelMap HostValue) -> HostManager
HostManager (IORef (LabelMap HostValue) -> HostManager)
-> IO (IORef (LabelMap HostValue)) -> IO HostManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LabelMap HostValue -> IO (IORef (LabelMap HostValue))
forall a. a -> IO (IORef a)
newIORef LabelMap HostValue
forall a. LabelMap a
LabelMap.empty
reserveHosts :: AppId
-> Set.Set Host
-> KeterM HostManager Reservations
reserveHosts :: AppId -> Set (CI Text) -> KeterM HostManager (Set (CI Text))
reserveHosts AppId
aid Set (CI Text)
hosts = do
(HostManager IORef (LabelMap HostValue)
mstate) <- KeterM HostManager HostManager
forall r (m :: * -> *). MonadReader r m => m r
ask
$Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM HostManager ()
(Text -> KeterM HostManager ())
-> (Text -> Text) -> Text -> KeterM HostManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM HostManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM HostManager ()) -> Text -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
[Char]
"Reserving hosts for app "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
aid
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList Set (CI Text)
hosts)
IO (Set (CI Text)) -> KeterM HostManager (Set (CI Text))
forall a. IO a -> KeterM HostManager a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set (CI Text)) -> KeterM HostManager (Set (CI Text)))
-> IO (Set (CI Text)) -> KeterM HostManager (Set (CI Text))
forall a b. (a -> b) -> a -> b
$ (Map (CI Text) AppId -> IO (Set (CI Text)))
-> (Set (CI Text) -> IO (Set (CI Text)))
-> Either (Map (CI Text) AppId) (Set (CI Text))
-> IO (Set (CI Text))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (KeterException -> IO (Set (CI Text))
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO (Set (CI Text)))
-> (Map (CI Text) AppId -> KeterException)
-> Map (CI Text) AppId
-> IO (Set (CI Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> Map (CI Text) AppId -> KeterException
CannotReserveHosts AppId
aid) Set (CI Text) -> IO (Set (CI Text))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
(Either (Map (CI Text) AppId) (Set (CI Text))
-> IO (Set (CI Text)))
-> IO (Either (Map (CI Text) AppId) (Set (CI Text)))
-> IO (Set (CI Text))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (LabelMap HostValue)
-> (LabelMap HostValue
-> (LabelMap HostValue,
Either (Map (CI Text) AppId) (Set (CI Text))))
-> IO (Either (Map (CI Text) AppId) (Set (CI Text)))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate (\LabelMap HostValue
entries0 ->
case [Either (CI Text, AppId) (Set (CI Text))]
-> ([(CI Text, AppId)], [Set (CI Text)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (CI Text, AppId) (Set (CI Text))]
-> ([(CI Text, AppId)], [Set (CI Text)]))
-> [Either (CI Text, AppId) (Set (CI Text))]
-> ([(CI Text, AppId)], [Set (CI Text)])
forall a b. (a -> b) -> a -> b
$ (CI Text -> Either (CI Text, AppId) (Set (CI Text)))
-> [CI Text] -> [Either (CI Text, AppId) (Set (CI Text))]
forall a b. (a -> b) -> [a] -> [b]
map (LabelMap HostValue
-> CI Text -> Either (CI Text, AppId) (Set (CI Text))
checkHost LabelMap HostValue
entries0) ([CI Text] -> [Either (CI Text, AppId) (Set (CI Text))])
-> [CI Text] -> [Either (CI Text, AppId) (Set (CI Text))]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList Set (CI Text)
hosts of
([], [Set (CI Text)] -> Set (CI Text)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set (CI Text)
toReserve) ->
((CI Text -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr CI Text -> LabelMap HostValue -> LabelMap HostValue
reserve LabelMap HostValue
entries0 Set (CI Text)
toReserve, Set (CI Text) -> Either (Map (CI Text) AppId) (Set (CI Text))
forall a b. b -> Either a b
Right Set (CI Text)
toReserve)
([(CI Text, AppId)]
conflicts, [Set (CI Text)]
_) -> (LabelMap HostValue
entries0, Map (CI Text) AppId -> Either (Map (CI Text) AppId) (Set (CI Text))
forall a b. a -> Either a b
Left (Map (CI Text) AppId
-> Either (Map (CI Text) AppId) (Set (CI Text)))
-> Map (CI Text) AppId
-> Either (Map (CI Text) AppId) (Set (CI Text))
forall a b. (a -> b) -> a -> b
$ [(CI Text, AppId)] -> Map (CI Text) AppId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CI Text, AppId)]
conflicts))
where
checkHost :: LabelMap HostValue
-> CI Text -> Either (CI Text, AppId) (Set (CI Text))
checkHost LabelMap HostValue
entries0 CI Text
host =
case ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
entries0 of
Bool
False -> Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. b -> Either a b
Right (Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text)))
-> Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. (a -> b) -> a -> b
$ CI Text -> Set (CI Text)
forall a. a -> Set a
Set.singleton CI Text
host
Bool
True ->
case ByteString -> LabelMap HostValue -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS LabelMap HostValue
entries0 of
Maybe HostValue
Nothing -> Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. b -> Either a b
Right (Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text)))
-> Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. (a -> b) -> a -> b
$ CI Text -> Set (CI Text)
forall a. a -> Set a
Set.singleton CI Text
host
Just (HVReserved AppId
aid') -> Bool
-> Either (CI Text, AppId) (Set (CI Text))
-> Either (CI Text, AppId) (Set (CI Text))
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (AppId
aid AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
/= AppId
aid')
(Either (CI Text, AppId) (Set (CI Text))
-> Either (CI Text, AppId) (Set (CI Text)))
-> Either (CI Text, AppId) (Set (CI Text))
-> Either (CI Text, AppId) (Set (CI Text))
forall a b. (a -> b) -> a -> b
$ (CI Text, AppId) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. a -> Either a b
Left (CI Text
host, AppId
aid')
Just (HVActive AppId
aid' ProxyAction
_ Credentials
_)
| AppId
aid AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
aid' -> Set (CI Text) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. b -> Either a b
Right Set (CI Text)
forall a. Set a
Set.empty
| Bool
otherwise -> (CI Text, AppId) -> Either (CI Text, AppId) (Set (CI Text))
forall a b. a -> Either a b
Left (CI Text
host, AppId
aid')
where hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
hvres :: HostValue
hvres = AppId -> HostValue
HVReserved AppId
aid
reserve :: CI Text -> LabelMap HostValue -> LabelMap HostValue
reserve CI Text
host LabelMap HostValue
es =
Bool -> LabelMap HostValue -> LabelMap HostValue
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
es) (LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> LabelMap HostValue
forall a b. (a -> b) -> a -> b
$ ByteString -> HostValue -> LabelMap HostValue -> LabelMap HostValue
forall a. ByteString -> a -> LabelMap a -> LabelMap a
LabelMap.insert ByteString
hostBS HostValue
hvres LabelMap HostValue
es
where
hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
forgetReservations :: AppId
-> Reservations
-> KeterM HostManager ()
forgetReservations :: AppId -> Set (CI Text) -> KeterM HostManager ()
forgetReservations AppId
app Set (CI Text)
hosts = do
(HostManager IORef (LabelMap HostValue)
mstate) <- KeterM HostManager HostManager
forall r (m :: * -> *). MonadReader r m => m r
ask
$Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM HostManager ()
(Text -> KeterM HostManager ())
-> (Text -> Text) -> Text -> KeterM HostManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM HostManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM HostManager ()) -> Text -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
[Char]
"Forgetting host reservations for app "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
app
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList Set (CI Text)
hosts)
IO () -> KeterM HostManager ()
forall a. IO a -> KeterM HostManager a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM HostManager ()) -> IO () -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ IORef (LabelMap HostValue)
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate ((LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ())
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LabelMap HostValue
state0 ->
((CI Text -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr CI Text -> LabelMap HostValue -> LabelMap HostValue
forget LabelMap HostValue
state0 Set (CI Text)
hosts, ())
where
forget :: CI Text -> LabelMap HostValue -> LabelMap HostValue
forget CI Text
host LabelMap HostValue
state =
Bool -> LabelMap HostValue -> LabelMap HostValue
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isReservedByMe (LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> LabelMap HostValue
forall a b. (a -> b) -> a -> b
$ ByteString -> LabelMap HostValue -> LabelMap HostValue
forall a. ByteString -> LabelMap a -> LabelMap a
LabelMap.delete ByteString
hostBS LabelMap HostValue
state
where
hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
isReservedByMe :: Bool
isReservedByMe = ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
state Bool -> Bool -> Bool
&&
case ByteString -> LabelMap HostValue -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS LabelMap HostValue
state of
Maybe HostValue
Nothing -> Bool
False
Just (HVReserved AppId
app') -> AppId
app AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
app'
Just HVActive{} -> Bool
False
activateApp :: AppId
-> Map.Map Host (ProxyAction, TLS.Credentials)
-> KeterM HostManager ()
activateApp :: AppId
-> Map (CI Text) (ProxyAction, Credentials)
-> KeterM HostManager ()
activateApp AppId
app Map (CI Text) (ProxyAction, Credentials)
actions = do
(HostManager IORef (LabelMap HostValue)
mstate) <- KeterM HostManager HostManager
forall r (m :: * -> *). MonadReader r m => m r
ask
$Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM HostManager ()
(Text -> KeterM HostManager ())
-> (Text -> Text) -> Text -> KeterM HostManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM HostManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM HostManager ()) -> Text -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Activating app "
, AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
app
, [Char]
" with hosts: "
, [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList (Map (CI Text) (ProxyAction, Credentials) -> Set (CI Text)
forall k a. Map k a -> Set k
Map.keysSet Map (CI Text) (ProxyAction, Credentials)
actions))
]
IO () -> KeterM HostManager ()
forall a. IO a -> KeterM HostManager a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM HostManager ()) -> IO () -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ IORef (LabelMap HostValue)
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate ((LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ())
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LabelMap HostValue
state0 ->
(AppId
-> LabelMap HostValue
-> Map (CI Text) (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app LabelMap HostValue
state0 Map (CI Text) (ProxyAction, Credentials)
actions, ())
activateHelper :: AppId -> LabelMap HostValue -> Map Host (ProxyAction, TLS.Credentials) -> LabelMap HostValue
activateHelper :: AppId
-> LabelMap HostValue
-> Map (CI Text) (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app =
(CI Text
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue)
-> LabelMap HostValue
-> Map (CI Text) (ProxyAction, Credentials)
-> LabelMap HostValue
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey CI Text
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue
activate
where
activate :: CI Text
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue
activate CI Text
host (ProxyAction
action, Credentials
cr) LabelMap HostValue
state =
Bool -> LabelMap HostValue -> LabelMap HostValue
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isOwnedByMe (LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> LabelMap HostValue
forall a b. (a -> b) -> a -> b
$ ByteString -> HostValue -> LabelMap HostValue -> LabelMap HostValue
forall a. ByteString -> a -> LabelMap a -> LabelMap a
LabelMap.insert ByteString
hostBS (AppId -> ProxyAction -> Credentials -> HostValue
HVActive AppId
app ProxyAction
action Credentials
cr) LabelMap HostValue
state
where
hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
isOwnedByMe :: Bool
isOwnedByMe = ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
state Bool -> Bool -> Bool
&&
case ByteString -> LabelMap HostValue -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS LabelMap HostValue
state of
Maybe HostValue
Nothing -> Bool
False
Just (HVReserved AppId
app') -> AppId
app AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
app'
Just (HVActive AppId
app' ProxyAction
_ Credentials
_) -> AppId
app AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
app'
deactivateApp :: AppId
-> Set Host
-> KeterM HostManager ()
deactivateApp :: AppId -> Set (CI Text) -> KeterM HostManager ()
deactivateApp AppId
app Set (CI Text)
hosts = do
$Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM HostManager ()
(Text -> KeterM HostManager ())
-> (Text -> Text) -> Text -> KeterM HostManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM HostManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM HostManager ()) -> Text -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Deactivating app " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
app [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with hosts: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList Set (CI Text)
hosts)
(HostManager IORef (LabelMap HostValue)
mstate) <- KeterM HostManager HostManager
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> KeterM HostManager ()
forall a. IO a -> KeterM HostManager a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM HostManager ()) -> IO () -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ IORef (LabelMap HostValue)
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate ((LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ())
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LabelMap HostValue
state0 ->
(AppId -> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
deactivateHelper AppId
app LabelMap HostValue
state0 Set (CI Text)
hosts, ())
deactivateHelper :: AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue
deactivateHelper :: AppId -> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
deactivateHelper AppId
app =
(CI Text -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr CI Text -> LabelMap HostValue -> LabelMap HostValue
deactivate
where
deactivate :: CI Text -> LabelMap HostValue -> LabelMap HostValue
deactivate CI Text
host LabelMap HostValue
state =
Bool -> LabelMap HostValue -> LabelMap HostValue
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isOwnedByMe (LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> LabelMap HostValue
forall a b. (a -> b) -> a -> b
$ ByteString -> LabelMap HostValue -> LabelMap HostValue
forall a. ByteString -> LabelMap a -> LabelMap a
LabelMap.delete ByteString
hostBS LabelMap HostValue
state
where
hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
isOwnedByMe :: Bool
isOwnedByMe = ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
state Bool -> Bool -> Bool
&&
case ByteString -> LabelMap HostValue -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS LabelMap HostValue
state of
Maybe HostValue
Nothing -> Bool
False
Just (HVActive AppId
app' ProxyAction
_ Credentials
_) -> AppId
app AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
app'
Just HVReserved {} -> Bool
False
reactivateApp :: AppId
-> Map Host (ProxyAction, TLS.Credentials)
-> Set Host
-> KeterM HostManager ()
reactivateApp :: AppId
-> Map (CI Text) (ProxyAction, Credentials)
-> Set (CI Text)
-> KeterM HostManager ()
reactivateApp AppId
app Map (CI Text) (ProxyAction, Credentials)
actions Set (CI Text)
hosts = do
(HostManager IORef (LabelMap HostValue)
mstate) <- KeterM HostManager HostManager
forall r (m :: * -> *). MonadReader r m => m r
ask
$Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM HostManager ()
(Text -> KeterM HostManager ())
-> (Text -> Text) -> Text -> KeterM HostManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM HostManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM HostManager ()) -> Text -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Reactivating app "
, AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
app
, [Char]
". Old hosts: "
, [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList Set (CI Text)
hosts)
, [Char]
". New hosts: "
, [[Char]] -> [Char]
unwords ((CI Text -> [Char]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
unpack (Text -> [Char]) -> (CI Text -> Text) -> CI Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original) ([CI Text] -> [[Char]]) -> [CI Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set (CI Text) -> [CI Text]
forall a. Set a -> [a]
Set.toList (Map (CI Text) (ProxyAction, Credentials) -> Set (CI Text)
forall k a. Map k a -> Set k
Map.keysSet Map (CI Text) (ProxyAction, Credentials)
actions))
, [Char]
"."
]
IO () -> KeterM HostManager ()
forall a. IO a -> KeterM HostManager a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM HostManager ()) -> IO () -> KeterM HostManager ()
forall a b. (a -> b) -> a -> b
$ IORef (LabelMap HostValue)
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate ((LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ())
-> (LabelMap HostValue -> (LabelMap HostValue, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LabelMap HostValue
state0 ->
(AppId
-> LabelMap HostValue
-> Map (CI Text) (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app (AppId -> LabelMap HostValue -> Set (CI Text) -> LabelMap HostValue
deactivateHelper AppId
app LabelMap HostValue
state0 Set (CI Text)
hosts) Map (CI Text) (ProxyAction, Credentials)
actions, ())
lookupAction :: HostManager
-> HostBS
-> IO (Maybe (ProxyAction, TLS.Credentials))
lookupAction :: HostManager -> HostBS -> IO (Maybe (ProxyAction, Credentials))
lookupAction (HostManager IORef (LabelMap HostValue)
mstate) HostBS
host = do
LabelMap HostValue
state <- IORef (LabelMap HostValue) -> IO (LabelMap HostValue)
forall a. IORef a -> IO a
readIORef IORef (LabelMap HostValue)
mstate
Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials)))
-> Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall a b. (a -> b) -> a -> b
$ case ByteString -> LabelMap HostValue -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup (HostBS -> ByteString
forall s. CI s -> s
CI.original HostBS
host) LabelMap HostValue
state of
Maybe HostValue
Nothing -> Maybe (ProxyAction, Credentials)
forall a. Maybe a
Nothing
Just (HVActive AppId
_ ProxyAction
action Credentials
cert) -> (ProxyAction, Credentials) -> Maybe (ProxyAction, Credentials)
forall a. a -> Maybe a
Just (ProxyAction
action, Credentials
cert)
Just (HVReserved AppId
_) -> Maybe (ProxyAction, Credentials)
forall a. Maybe a
Nothing