{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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)
import qualified Network.TLS as TLS

type HMState = LabelMap HostValue

data HostValue = HVActive   !AppId !ProxyAction !TLS.Credentials
               | HVReserved !AppId

newtype HostManager = HostManager (IORef HMState)

type Reservations = Set.Set Host

start :: IO HostManager
start :: IO HostManager
start = IORef HMState -> HostManager
HostManager (IORef HMState -> HostManager)
-> IO (IORef HMState) -> IO HostManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HMState -> IO (IORef HMState)
forall a. a -> IO (IORef a)
newIORef HMState
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 :: (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 HMState
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 HMState
-> (HMState -> (HMState, 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 HMState
mstate (\HMState
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 (HMState -> Host -> Either (Host, AppId) (Set Host)
checkHost HMState
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 -> HMState -> HMState) -> HMState -> Set Host -> HMState
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> HMState -> HMState
reserve HMState
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]
_) -> (HMState
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 :: HMState -> Host -> Either (Host, AppId) (Set Host)
checkHost HMState
entries0 Host
host =
        case ByteString -> HMState -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS HMState
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 -> HMState -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS HMState
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 -> HMState -> HMState
reserve Host
host HMState
es =
        Bool -> HMState -> HMState
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> HMState -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS HMState
es) (HMState -> HMState) -> HMState -> HMState
forall a b. (a -> b) -> a -> b
$ ByteString -> HostValue -> HMState -> HMState
forall a. ByteString -> a -> LabelMap a -> LabelMap a
LabelMap.insert ByteString
hostBS HostValue
hvres HMState
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

-- | Forget previously made reservations.

forgetReservations :: (LogMessage -> IO ())
                   -> HostManager
                   -> AppId
                   -> Reservations
                   -> IO ()
forgetReservations :: (LogMessage -> IO ()) -> HostManager -> AppId -> Set Host -> IO ()
forgetReservations LogMessage -> IO ()
log (HostManager IORef HMState
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 HMState -> (HMState -> (HMState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef HMState
mstate ((HMState -> (HMState, ())) -> IO ())
-> (HMState -> (HMState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HMState
state0 ->
        ((Host -> HMState -> HMState) -> HMState -> Set Host -> HMState
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> HMState -> HMState
forget HMState
state0 Set Host
hosts, ())
  where
    forget :: Host -> HMState -> HMState
forget Host
host HMState
state =
        Bool -> HMState -> HMState
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isReservedByMe (HMState -> HMState) -> HMState -> HMState
forall a b. (a -> b) -> a -> b
$ ByteString -> HMState -> HMState
forall a. ByteString -> LabelMap a -> LabelMap a
LabelMap.delete ByteString
hostBS HMState
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 -> HMState -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS HMState
state Bool -> Bool -> Bool
&&
            case ByteString -> HMState -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS HMState
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 :: (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 HMState
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 HMState -> (HMState -> (HMState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef HMState
mstate ((HMState -> (HMState, ())) -> IO ())
-> (HMState -> (HMState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HMState
state0 ->
        (AppId -> HMState -> Map Host (ProxyAction, Credentials) -> HMState
activateHelper AppId
app HMState
state0 Map Host (ProxyAction, Credentials)
actions, ())

activateHelper :: AppId -> HMState -> Map Host (ProxyAction, TLS.Credentials) -> HMState
activateHelper :: AppId -> HMState -> Map Host (ProxyAction, Credentials) -> HMState
activateHelper AppId
app =
    (Host -> (ProxyAction, Credentials) -> HMState -> HMState)
-> HMState -> Map Host (ProxyAction, Credentials) -> HMState
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Host -> (ProxyAction, Credentials) -> HMState -> HMState
activate
  where
    activate :: Host -> (ProxyAction, Credentials) -> HMState -> HMState
activate Host
host (ProxyAction
action, Credentials
cr) HMState
state =
        Bool -> HMState -> HMState
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isOwnedByMe (HMState -> HMState) -> HMState -> HMState
forall a b. (a -> b) -> a -> b
$ ByteString -> HostValue -> HMState -> HMState
forall a. ByteString -> a -> LabelMap a -> LabelMap a
LabelMap.insert ByteString
hostBS (AppId -> ProxyAction -> Credentials -> HostValue
HVActive AppId
app ProxyAction
action Credentials
cr) HMState
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 -> HMState -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS HMState
state Bool -> Bool -> Bool
&&
            case ByteString -> HMState -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS HMState
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 HMState
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 HMState -> (HMState -> (HMState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef HMState
mstate ((HMState -> (HMState, ())) -> IO ())
-> (HMState -> (HMState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HMState
state0 ->
        (AppId -> HMState -> Set Host -> HMState
deactivateHelper AppId
app HMState
state0 Set Host
hosts, ())

deactivateHelper :: AppId -> HMState -> Set Host -> HMState
deactivateHelper :: AppId -> HMState -> Set Host -> HMState
deactivateHelper AppId
app =
    (Host -> HMState -> HMState) -> HMState -> Set Host -> HMState
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr Host -> HMState -> HMState
deactivate
  where
    deactivate :: Host -> HMState -> HMState
deactivate Host
host HMState
state =
        Bool -> HMState -> HMState
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
isOwnedByMe (HMState -> HMState) -> HMState -> HMState
forall a b. (a -> b) -> a -> b
$ ByteString -> HMState -> HMState
forall a. ByteString -> LabelMap a -> LabelMap a
LabelMap.delete ByteString
hostBS HMState
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 -> HMState -> Bool
forall a. ByteString -> LabelMap a -> Bool
LabelMap.labelAssigned ByteString
hostBS HMState
state Bool -> Bool -> Bool
&&
            case ByteString -> HMState -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup ByteString
hostBS HMState
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 HMState
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 HMState -> (HMState -> (HMState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef HMState
mstate ((HMState -> (HMState, ())) -> IO ())
-> (HMState -> (HMState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HMState
state0 ->
        (AppId -> HMState -> Map Host (ProxyAction, Credentials) -> HMState
activateHelper AppId
app (AppId -> HMState -> Set Host -> HMState
deactivateHelper AppId
app HMState
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 HMState
mstate) HostBS
host = do
    HMState
state <- IORef HMState -> IO HMState
forall a. IORef a -> IO a
readIORef IORef HMState
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 -> HMState -> Maybe HostValue
forall a. ByteString -> LabelMap a -> Maybe a
LabelMap.lookup (HostBS -> ByteString
forall s. CI s -> s
CI.original HostBS
host) HMState
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