{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Keter.HostManager
    ( -- * Types
      HostManager
    , Reservations
      -- * Actions
    , reserveHosts
    , forgetReservations
    , activateApp
    , deactivateApp
    , reactivateApp
    , lookupAction
      -- * Initialize
    , start
    ) where

import Control.Applicative
import Control.Exception (assert, throwIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (ask)
import Data.CaseInsensitive qualified as CI
import Data.Either (partitionEithers)
import Data.IORef
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Keter.Common
import Keter.Config
import Keter.Context
import Keter.LabelMap (LabelMap)
import Keter.LabelMap qualified as LabelMap
import Network.TLS qualified as TLS
import Prelude hiding (log)

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

-- | Reserve the given hosts so that no other application may use them. Does
-- not yet enable any action. The semantics are:
--
-- 1. If a requested host is currently actively used or by an app of the same name, it is
--    considered reserved.
--
-- 2. If a requested host is currently reserved by an app of the same name, it
--    is considered an error in calling this API. Only one app reservation can
--    happen at a time.
--
-- 3. If any requested host is currently used or reserved by an app with a
--    different name, then those values are returned as @Left@.
--
-- 4. Otherwise, the hosts which were reserved are returned as @Right@. This
--    does /not/ include previously active hosts.
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 =
        if ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
entries0
        then
          (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'))
        else 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
      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

-- | Forget previously made reservations.
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

-- | Activate a new app. Note that you /must/ first reserve the hostnames you'll be using.
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