mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-13 19:28:17 +03:00
183 lines
6.7 KiB
Haskell
183 lines
6.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# 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 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.Types
|
|
import Keter.LabelMap (LabelMap)
|
|
import qualified Keter.LabelMap as LabelMap
|
|
import Prelude hiding (log)
|
|
|
|
type HMState = LabelMap HostValue
|
|
|
|
data HostValue = HVActive !AppId !ProxyAction
|
|
| HVReserved !AppId
|
|
|
|
newtype HostManager = HostManager (IORef HMState)
|
|
|
|
type Reservations = Set.Set Host
|
|
|
|
start :: IO HostManager
|
|
start = HostManager <$> newIORef 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 :: (LogMessage -> IO ())
|
|
-> HostManager
|
|
-> AppId
|
|
-> Set.Set Host
|
|
-> IO Reservations
|
|
reserveHosts log (HostManager mstate) aid hosts = do
|
|
log $ ReservingHosts aid hosts
|
|
either (throwIO . CannotReserveHosts aid) return =<< atomicModifyIORef mstate (\entries0 ->
|
|
case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of
|
|
([], Set.unions -> toReserve) ->
|
|
(Set.foldr reserve entries0 toReserve, Right toReserve)
|
|
(conflicts, _) -> (entries0, Left $ Map.fromList conflicts))
|
|
where
|
|
checkHost entries0 host =
|
|
case LabelMap.labelAssigned hostBS entries0 of
|
|
False -> Right $ Set.singleton host
|
|
True ->
|
|
case LabelMap.lookup hostBS entries0 of
|
|
Nothing -> Right $ Set.singleton host
|
|
Just (HVReserved aid') -> assert (aid /= aid')
|
|
$ Left (host, aid')
|
|
Just (HVActive aid' _)
|
|
| aid == aid' -> Right Set.empty
|
|
| otherwise -> Left (host, aid')
|
|
where hostBS = encodeUtf8 $ CI.original host
|
|
|
|
hvres = HVReserved aid
|
|
reserve host es =
|
|
assert (not $ LabelMap.labelAssigned hostBS es) $ LabelMap.insert hostBS hvres es
|
|
where
|
|
hostBS = encodeUtf8 $ CI.original host
|
|
|
|
-- | Forget previously made reservations.
|
|
forgetReservations :: (LogMessage -> IO ())
|
|
-> HostManager
|
|
-> AppId
|
|
-> Reservations
|
|
-> IO ()
|
|
forgetReservations log (HostManager mstate) app hosts = do
|
|
log $ ForgetingReservations app hosts
|
|
atomicModifyIORef mstate $ \state0 ->
|
|
(Set.foldr forget state0 hosts, ())
|
|
where
|
|
forget host state =
|
|
assert isReservedByMe $ LabelMap.delete hostBS state
|
|
where
|
|
hostBS = encodeUtf8 $ CI.original host
|
|
isReservedByMe = LabelMap.labelAssigned hostBS state &&
|
|
case LabelMap.lookup hostBS state of
|
|
Nothing -> False
|
|
Just (HVReserved app') -> app == app'
|
|
Just HVActive{} -> False
|
|
|
|
-- | Activate a new app. Note that you /must/ first reserve the hostnames you'll be using.
|
|
activateApp :: (LogMessage -> IO ())
|
|
-> HostManager
|
|
-> AppId
|
|
-> Map.Map Host ProxyAction
|
|
-> IO ()
|
|
activateApp log (HostManager mstate) app actions = do
|
|
log $ ActivatingApp app $ Map.keysSet actions
|
|
atomicModifyIORef mstate $ \state0 ->
|
|
(activateHelper app state0 actions, ())
|
|
|
|
activateHelper :: AppId -> HMState -> Map Host ProxyAction -> HMState
|
|
activateHelper app =
|
|
Map.foldrWithKey activate
|
|
where
|
|
activate host action state =
|
|
assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action) state
|
|
where
|
|
hostBS = encodeUtf8 $ CI.original host
|
|
isOwnedByMe = LabelMap.labelAssigned hostBS state &&
|
|
case LabelMap.lookup hostBS state of
|
|
Nothing -> False
|
|
Just (HVReserved app') -> app == app'
|
|
Just (HVActive app' _) -> app == app'
|
|
|
|
deactivateApp :: (LogMessage -> IO ())
|
|
-> HostManager
|
|
-> AppId
|
|
-> Set Host
|
|
-> IO ()
|
|
deactivateApp log (HostManager mstate) app hosts = do
|
|
log $ DeactivatingApp app hosts
|
|
atomicModifyIORef mstate $ \state0 ->
|
|
(deactivateHelper app state0 hosts, ())
|
|
|
|
deactivateHelper :: AppId -> HMState -> Set Host -> HMState
|
|
deactivateHelper app =
|
|
Set.foldr deactivate
|
|
where
|
|
deactivate host state =
|
|
assert isOwnedByMe $ LabelMap.delete hostBS state
|
|
where
|
|
hostBS = encodeUtf8 $ CI.original host
|
|
isOwnedByMe = LabelMap.labelAssigned hostBS state &&
|
|
case LabelMap.lookup hostBS state of
|
|
Nothing -> False
|
|
Just (HVActive app' _) -> app == app'
|
|
Just HVReserved {} -> False
|
|
|
|
reactivateApp :: (LogMessage -> IO ())
|
|
-> HostManager
|
|
-> AppId
|
|
-> Map Host ProxyAction
|
|
-> Set Host
|
|
-> IO ()
|
|
reactivateApp log (HostManager mstate) app actions hosts = do
|
|
log $ ReactivatingApp app hosts (Map.keysSet actions)
|
|
atomicModifyIORef mstate $ \state0 ->
|
|
(activateHelper app (deactivateHelper app state0 hosts) actions, ())
|
|
|
|
lookupAction :: HostManager
|
|
-> HostBS
|
|
-> IO (Maybe ProxyAction)
|
|
lookupAction (HostManager mstate) host = do
|
|
state <- readIORef mstate
|
|
return $ case LabelMap.lookup (CI.original host) state of
|
|
Nothing -> Nothing
|
|
Just (HVActive _ action) -> Just action
|
|
Just (HVReserved _) -> Nothing
|