{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Keter.HostManager
(
HostManager
, Reservations
, reserveHosts
, forgetReservations
, activateApp
, deactivateApp
, reactivateApp
, lookupAction
, start
) where
import Control.Applicative
import Control.Exception (assert, throwIO)
import qualified Data.CaseInsensitive as CI
import Data.Either (partitionEithers)
import Data.IORef
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 :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Set.Set Host
-> IO Reservations
reserveHosts :: (LogMessage -> IO ())
-> HostManager -> AppId -> Set Host -> IO (Set Host)
reserveHosts LogMessage -> IO ()
log (HostManager IORef (LabelMap HostValue)
mstate) AppId
aid Set Host
hosts = do
LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> LogMessage
ReservingHosts AppId
aid Set Host
hosts
(Map Host AppId -> IO (Set Host))
-> (Set Host -> IO (Set Host))
-> Either (Map Host AppId) (Set Host)
-> IO (Set Host)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (KeterException -> IO (Set Host)
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO (Set Host))
-> (Map Host AppId -> KeterException)
-> Map Host AppId
-> IO (Set Host)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> Map Host AppId -> KeterException
CannotReserveHosts AppId
aid) Set Host -> IO (Set Host)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Map Host AppId) (Set Host) -> IO (Set Host))
-> IO (Either (Map Host AppId) (Set Host)) -> IO (Set Host)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (LabelMap HostValue)
-> (LabelMap HostValue
-> (LabelMap HostValue, Either (Map Host AppId) (Set Host)))
-> IO (Either (Map Host AppId) (Set Host))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (LabelMap HostValue)
mstate (\LabelMap HostValue
entries0 ->
case [Either (Host, AppId) (Set Host)] -> ([(Host, AppId)], [Set Host])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Host, AppId) (Set Host)]
-> ([(Host, AppId)], [Set Host]))
-> [Either (Host, AppId) (Set Host)]
-> ([(Host, AppId)], [Set Host])
forall a b. (a -> b) -> a -> b
$ (Host -> Either (Host, AppId) (Set Host))
-> [Host] -> [Either (Host, AppId) (Set Host)]
forall a b. (a -> b) -> [a] -> [b]
map (LabelMap HostValue -> Host -> Either (Host, AppId) (Set Host)
checkHost LabelMap HostValue
entries0) ([Host] -> [Either (Host, AppId) (Set Host)])
-> [Host] -> [Either (Host, AppId) (Set Host)]
forall a b. (a -> b) -> a -> b
$ Set Host -> [Host]
forall a. Set a -> [a]
Set.toList Set Host
hosts of
([], [Set Host] -> Set Host
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions -> Set Host
toReserve) ->
((Host -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set Host -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> LabelMap HostValue -> LabelMap HostValue
reserve LabelMap HostValue
entries0 Set Host
toReserve, Set Host -> Either (Map Host AppId) (Set Host)
forall a b. b -> Either a b
Right Set Host
toReserve)
([(Host, AppId)]
conflicts, [Set Host]
_) -> (LabelMap HostValue
entries0, Map Host AppId -> Either (Map Host AppId) (Set Host)
forall a b. a -> Either a b
Left (Map Host AppId -> Either (Map Host AppId) (Set Host))
-> Map Host AppId -> Either (Map Host AppId) (Set Host)
forall a b. (a -> b) -> a -> b
$ [(Host, AppId)] -> Map Host AppId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Host, AppId)]
conflicts))
where
checkHost :: LabelMap HostValue -> Host -> Either (Host, AppId) (Set Host)
checkHost LabelMap HostValue
entries0 Host
host =
case ByteString -> LabelMap HostValue -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS LabelMap HostValue
entries0 of
Bool
False -> Set Host -> Either (Host, AppId) (Set Host)
forall a b. b -> Either a b
Right (Set Host -> Either (Host, AppId) (Set Host))
-> Set Host -> Either (Host, AppId) (Set Host)
forall a b. (a -> b) -> a -> b
$ Host -> Set Host
forall a. a -> Set a
Set.singleton Host
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 Host -> Either (Host, AppId) (Set Host)
forall a b. b -> Either a b
Right (Set Host -> Either (Host, AppId) (Set Host))
-> Set Host -> Either (Host, AppId) (Set Host)
forall a b. (a -> b) -> a -> b
$ Host -> Set Host
forall a. a -> Set a
Set.singleton Host
host
Just (HVReserved AppId
aid') -> Bool
-> Either (Host, AppId) (Set Host)
-> Either (Host, AppId) (Set Host)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (AppId
aid AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
/= AppId
aid')
(Either (Host, AppId) (Set Host)
-> Either (Host, AppId) (Set Host))
-> Either (Host, AppId) (Set Host)
-> Either (Host, AppId) (Set Host)
forall a b. (a -> b) -> a -> b
$ (Host, AppId) -> Either (Host, AppId) (Set Host)
forall a b. a -> Either a b
Left (Host
host, AppId
aid')
Just (HVActive AppId
aid' ProxyAction
_ Credentials
_)
| AppId
aid AppId -> AppId -> Bool
forall a. Eq a => a -> a -> Bool
== AppId
aid' -> Set Host -> Either (Host, AppId) (Set Host)
forall a b. b -> Either a b
Right Set Host
forall a. Set a
Set.empty
| Bool
otherwise -> (Host, AppId) -> Either (Host, AppId) (Set Host)
forall a b. a -> Either a b
Left (Host
host, AppId
aid')
where hostBS :: ByteString
hostBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Host -> Text
forall s. CI s -> s
CI.original Host
host
hvres :: HostValue
hvres = AppId -> HostValue
HVReserved AppId
aid
reserve :: Host -> LabelMap HostValue -> LabelMap HostValue
reserve Host
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
$ Host -> Text
forall s. CI s -> s
CI.original Host
host
forgetReservations :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Reservations
-> IO ()
forgetReservations :: (LogMessage -> IO ()) -> HostManager -> AppId -> Set Host -> IO ()
forgetReservations LogMessage -> IO ()
log (HostManager IORef (LabelMap HostValue)
mstate) AppId
app Set Host
hosts = do
LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> LogMessage
ForgetingReservations AppId
app Set Host
hosts
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 ->
((Host -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set Host -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> LabelMap HostValue -> LabelMap HostValue
forget LabelMap HostValue
state0 Set Host
hosts, ())
where
forget :: Host -> LabelMap HostValue -> LabelMap HostValue
forget Host
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
$ Host -> Text
forall s. CI s -> s
CI.original Host
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 :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map.Map Host (ProxyAction, TLS.Credentials)
-> IO ()
activateApp :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host (ProxyAction, Credentials)
-> IO ()
activateApp LogMessage -> IO ()
log (HostManager IORef (LabelMap HostValue)
mstate) AppId
app Map Host (ProxyAction, Credentials)
actions = do
LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> LogMessage
ActivatingApp AppId
app (Set Host -> LogMessage) -> Set Host -> LogMessage
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions
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 Host (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app LabelMap HostValue
state0 Map Host (ProxyAction, Credentials)
actions, ())
activateHelper :: AppId -> LabelMap HostValue -> Map Host (ProxyAction, TLS.Credentials) -> LabelMap HostValue
activateHelper :: AppId
-> LabelMap HostValue
-> Map Host (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app =
(Host
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue)
-> LabelMap HostValue
-> Map Host (ProxyAction, Credentials)
-> LabelMap HostValue
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Host
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue
activate
where
activate :: Host
-> (ProxyAction, Credentials)
-> LabelMap HostValue
-> LabelMap HostValue
activate Host
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
$ Host -> Text
forall s. CI s -> s
CI.original Host
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 :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Set Host
-> IO ()
deactivateApp :: (LogMessage -> IO ()) -> HostManager -> AppId -> Set Host -> IO ()
deactivateApp LogMessage -> IO ()
log (HostManager IORef (LabelMap HostValue)
mstate) AppId
app Set Host
hosts = do
LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> LogMessage
DeactivatingApp AppId
app Set Host
hosts
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 Host -> LabelMap HostValue
deactivateHelper AppId
app LabelMap HostValue
state0 Set Host
hosts, ())
deactivateHelper :: AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue
deactivateHelper :: AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue
deactivateHelper AppId
app =
(Host -> LabelMap HostValue -> LabelMap HostValue)
-> LabelMap HostValue -> Set Host -> LabelMap HostValue
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> LabelMap HostValue -> LabelMap HostValue
deactivate
where
deactivate :: Host -> LabelMap HostValue -> LabelMap HostValue
deactivate Host
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
$ Host -> Text
forall s. CI s -> s
CI.original Host
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 :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host (ProxyAction, TLS.Credentials)
-> Set Host
-> IO ()
reactivateApp :: (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host (ProxyAction, Credentials)
-> Set Host
-> IO ()
reactivateApp LogMessage -> IO ()
log (HostManager IORef (LabelMap HostValue)
mstate) AppId
app Map Host (ProxyAction, Credentials)
actions Set Host
hosts = do
LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> Set Host -> LogMessage
ReactivatingApp AppId
app Set Host
hosts (Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
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 Host (ProxyAction, Credentials)
-> LabelMap HostValue
activateHelper AppId
app (AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue
deactivateHelper AppId
app LabelMap HostValue
state0 Set Host
hosts) Map Host (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 (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