{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}

module Hyperion.HoldServer where

import           Control.Concurrent.MVar     (MVar, newEmptyMVar,
                                              readMVar, tryPutMVar)
import           Control.Concurrent.STM      (atomically)
import           Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO,
                                              readTVarIO)
import           Control.Monad               (when)
import           Control.Monad.IO.Class      (MonadIO, liftIO)
import           Data.Map                    (Map)
import qualified Data.Map                    as Map
import           Data.Maybe                  (catMaybes)
import qualified Data.Text                   as T
import qualified Hyperion.Log                as Log
import           Network.Wai                 ()
import qualified Network.Wai.Handler.Warp    as Warp
import           Servant

type HoldApi =
       "retry" :> Capture "service" T.Text :> Get '[JSON] (Maybe T.Text)
  :<|> "retry-all" :> Get '[JSON] [T.Text]
  :<|> "list" :> Get '[JSON] [T.Text]

newtype HoldMap = HoldMap (TVar (Map T.Text (MVar ())))

newHoldMap :: IO HoldMap
newHoldMap :: IO HoldMap
newHoldMap = TVar (Map Text (MVar ())) -> HoldMap
HoldMap (TVar (Map Text (MVar ())) -> HoldMap)
-> IO (TVar (Map Text (MVar ()))) -> IO HoldMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (MVar ()) -> IO (TVar (Map Text (MVar ())))
forall a. a -> IO (TVar a)
newTVarIO Map Text (MVar ())
forall k a. Map k a
Map.empty

server :: HoldMap -> Server HoldApi
server :: HoldMap -> Server HoldApi
server (HoldMap TVar (Map Text (MVar ()))
holdMap) = Text -> Handler (Maybe Text)
retry (Text -> Handler (Maybe Text))
-> (Handler [Text] :<|> Handler [Text])
-> (Text -> Handler (Maybe Text))
   :<|> (Handler [Text] :<|> Handler [Text])
forall a b. a -> b -> a :<|> b
:<|> Handler [Text]
retryAll Handler [Text]
-> Handler [Text] -> Handler [Text] :<|> Handler [Text]
forall a b. a -> b -> a :<|> b
:<|> Handler [Text]
listHolds
  where
    retry :: Text -> Handler (Maybe Text)
retry Text
service = IO (Maybe Text) -> Handler (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> Handler (Maybe Text))
-> IO (Maybe Text) -> Handler (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
      Map Text (MVar ())
serviceMap <- TVar (Map Text (MVar ())) -> IO (Map Text (MVar ()))
forall a. TVar a -> IO a
readTVarIO TVar (Map Text (MVar ()))
holdMap
      case Text -> Map Text (MVar ()) -> Maybe (MVar ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
service Map Text (MVar ())
serviceMap of
        Just MVar ()
holdVar -> do
          Bool
unblocked <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
holdVar ()
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
unblocked) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
Log.warn Text
"Service already unblocked" Text
service
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map Text (MVar ()))
-> (Map Text (MVar ()) -> Map Text (MVar ())) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map Text (MVar ()))
holdMap (Text -> Map Text (MVar ()) -> Map Text (MVar ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
service)
          Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
service)
        Maybe (MVar ())
Nothing -> Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    listHolds :: Handler [Text]
listHolds = do
      IO [Text] -> Handler [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> Handler [Text]) -> IO [Text] -> Handler [Text]
forall a b. (a -> b) -> a -> b
$ (Map Text (MVar ()) -> [Text])
-> IO (Map Text (MVar ())) -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text (MVar ()) -> [Text]
forall k a. Map k a -> [k]
Map.keys (TVar (Map Text (MVar ())) -> IO (Map Text (MVar ()))
forall a. TVar a -> IO a
readTVarIO TVar (Map Text (MVar ()))
holdMap)
    retryAll :: Handler [Text]
retryAll = do
      [Text]
services <- Handler [Text]
listHolds
      ([Maybe Text] -> [Text]) -> Handler [Maybe Text] -> Handler [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes (Handler [Maybe Text] -> Handler [Text])
-> Handler [Maybe Text] -> Handler [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Handler (Maybe Text)) -> [Text] -> Handler [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Handler (Maybe Text)
retry [Text]
services

-- | Start a hold associated to the given service. Returns an IO action
-- that blocks until the hold is released
blockUntilRetried :: MonadIO m => HoldMap -> T.Text -> m ()
blockUntilRetried :: HoldMap -> Text -> m ()
blockUntilRetried (HoldMap TVar (Map Text (MVar ()))
holdMap) Text
service = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  MVar ()
holdVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  -- This will loose the blocking MVar if service is already blocked
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map Text (MVar ()))
-> (Map Text (MVar ()) -> Map Text (MVar ())) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map Text (MVar ()))
holdMap (Text -> MVar () -> Map Text (MVar ()) -> Map Text (MVar ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
service MVar ()
holdVar)
  MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
holdVar

-- | Start the hold server on an available port and pass the port
-- number to the given action. The server is killed after the action
-- finishes.
--
withHoldServer :: HoldMap -> (Int -> IO a) -> IO a
withHoldServer :: HoldMap -> (Int -> IO a) -> IO a
withHoldServer HoldMap
holdMap = IO Application -> (Int -> IO a) -> IO a
forall a. IO Application -> (Int -> IO a) -> IO a
Warp.withApplication (Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application
app) 
  where
    app :: Application
app = Proxy HoldApi -> Server HoldApi -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy HoldApi
forall k (t :: k). Proxy t
Proxy @HoldApi) (HoldMap -> Server HoldApi
server HoldMap
holdMap)