{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
-- | Used for management of applications.
module Keter.AppManager
    ( -- * Types
      AppManager
    , Action (..)
      -- * Actions
    , perform
    , reloadAppList
    , addApp
    , terminateApp
      -- * Initialize
    , initialize
      -- * Show
    , renderApps
    ) where

import Keter.Common
import           Data.Set                   (Set)
import           Data.Text                  (Text)
import           System.FilePath            (FilePath)
import           Data.Map                   (Map)
import           Control.Exception          (SomeException)
import           Control.Applicative
import           Control.Concurrent         (forkIO)
import           Control.Concurrent.MVar    (MVar, newMVar, withMVar)
import           Control.Concurrent.STM
import qualified Control.Exception          as E
import           Control.Monad              (void)
import           Data.Foldable              (fold)
import qualified Data.Map                   as Map
import           Data.Maybe                 (catMaybes, mapMaybe)
import qualified Data.Set                   as Set
import           Data.Text                  (pack, unpack)
import qualified Data.Text.Lazy             as LT
import qualified Data.Text.Lazy.Builder     as Builder
import           Data.Traversable.WithIndex (itraverse)
import           Keter.App                  (App, AppStartConfig, showApp)
import qualified Keter.App                  as App
import           Keter.Config
import           Prelude                    hiding (FilePath, log)
import           System.Posix.Files         (getFileStatus, modificationTime)
import           System.Posix.Types         (EpochTime)
import           Text.Printf                (printf)

data AppManager = AppManager
    { AppManager -> TVar (Map AppId (TVar AppState))
apps           :: !(TVar (Map AppId (TVar AppState)))
    , AppManager -> AppStartConfig
appStartConfig :: !AppStartConfig
    , AppManager -> MVar ()
mutex          :: !(MVar ())
    , AppManager -> LogMessage -> IO ()
log            :: !(LogMessage -> IO ())
    }

data AppState = ASRunning App
              | ASStarting
                    !(Maybe App)
                    !(TVar (Maybe EpochTime))
                    !(TVar (Maybe Action)) -- ^ the next one to try
              | ASTerminated

showAppState :: AppState -> STM Text
showAppState :: AppState -> STM Text
showAppState (ASRunning App
x) = (\Text
x -> Text
"running(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") (Text -> Text) -> STM Text -> STM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App -> STM Text
showApp App
x
showAppState (ASStarting Maybe App
mapp TVar (Maybe EpochTime)
tmtime TVar (Maybe Action)
tmaction) = do
  Maybe EpochTime
mtime   <- TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
tmtime
  Maybe Action
maction <- TVar (Maybe Action) -> STM (Maybe Action)
forall a. TVar a -> STM a
readTVar TVar (Maybe Action)
tmaction
  Maybe Text
mtext <- (App -> STM Text) -> Maybe App -> STM (Maybe Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse App -> STM Text
showApp Maybe App
mapp
  Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"starting app %s, time %s, action %s \n" (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
mtext) (Maybe EpochTime -> String
forall a. Show a => a -> String
show Maybe EpochTime
mtime) (Maybe Action -> String
forall a. Show a => a -> String
show Maybe Action
maction)
showAppState AppState
ASTerminated = Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"terminated"

renderApps :: AppManager -> STM Text
renderApps :: AppManager -> STM Text
renderApps AppManager
mngr = do
  Map AppId (TVar AppState)
appMap <- TVar (Map AppId (TVar AppState)) -> STM (Map AppId (TVar AppState))
forall a. TVar a -> STM a
readTVar (TVar (Map AppId (TVar AppState))
 -> STM (Map AppId (TVar AppState)))
-> TVar (Map AppId (TVar AppState))
-> STM (Map AppId (TVar AppState))
forall a b. (a -> b) -> a -> b
$ AppManager -> TVar (Map AppId (TVar AppState))
apps AppManager
mngr
  Map AppId Builder
x <- (AppId -> TVar AppState -> STM Builder)
-> Map AppId (TVar AppState) -> STM (Map AppId Builder)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (\AppId
appId TVar AppState
tappState -> do
                AppState
state <- TVar AppState -> STM AppState
forall a. TVar a -> STM a
readTVar TVar AppState
tappState
                Text
res <- AppState -> STM Text
showAppState AppState
state
                Builder -> STM Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> STM Builder) -> Builder -> STM Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \n"
               ) Map AppId (TVar AppState)
appMap
  Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
Builder.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Map AppId Builder -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map AppId Builder
x

data Action = Reload AppInput | Terminate
 deriving Int -> Action -> String -> String
[Action] -> String -> String
Action -> String
(Int -> Action -> String -> String)
-> (Action -> String)
-> ([Action] -> String -> String)
-> Show Action
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Action] -> String -> String
$cshowList :: [Action] -> String -> String
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> String -> String
$cshowsPrec :: Int -> Action -> String -> String
Show

initialize :: (LogMessage -> IO ())
           -> AppStartConfig
           -> IO AppManager
initialize :: (LogMessage -> IO ()) -> AppStartConfig -> IO AppManager
initialize LogMessage -> IO ()
log' AppStartConfig
asc = TVar (Map AppId (TVar AppState))
-> AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager
AppManager
    (TVar (Map AppId (TVar AppState))
 -> AppStartConfig
 -> MVar ()
 -> (LogMessage -> IO ())
 -> AppManager)
-> IO (TVar (Map AppId (TVar AppState)))
-> IO
     (AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map AppId (TVar AppState) -> IO (TVar (Map AppId (TVar AppState)))
forall a. a -> IO (TVar a)
newTVarIO Map AppId (TVar AppState)
forall k a. Map k a
Map.empty
    IO
  (AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager)
-> IO AppStartConfig
-> IO (MVar () -> (LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppStartConfig -> IO AppStartConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
    IO (MVar () -> (LogMessage -> IO ()) -> AppManager)
-> IO (MVar ()) -> IO ((LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    IO ((LogMessage -> IO ()) -> AppManager)
-> IO (LogMessage -> IO ()) -> IO AppManager
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LogMessage -> IO ()) -> IO (LogMessage -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return LogMessage -> IO ()
log'

-- | Reset which apps are running.
--
-- * Any app not listed here that is currently running will be terminated.
--
-- * Any app listed here that is currently running will be reloaded.
--
-- * Any app listed here that is not currently running will be started.
reloadAppList :: AppManager
              -> Map Appname (FilePath, EpochTime)
              -> IO ()
reloadAppList :: AppManager -> Map Text (String, EpochTime) -> IO ()
reloadAppList am :: AppManager
am@AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} Map Text (String, EpochTime)
newApps = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mutex ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [IO ()]
actions <- STM [IO ()] -> IO [IO ()]
forall a. STM a -> IO a
atomically (STM [IO ()] -> IO [IO ()]) -> STM [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ do
        Map AppId (TVar AppState)
m <- TVar (Map AppId (TVar AppState)) -> STM (Map AppId (TVar AppState))
forall a. TVar a -> STM a
readTVar TVar (Map AppId (TVar AppState))
apps
        let currentApps :: Set Text
currentApps = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (AppId -> Maybe Text) -> [AppId] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AppId -> Maybe Text
toAppName ([AppId] -> [Text]) -> [AppId] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map AppId (TVar AppState) -> [AppId]
forall k a. Map k a -> [k]
Map.keys Map AppId (TVar AppState)
m
            allApps :: [Text]
allApps = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text (String, EpochTime) -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text (String, EpochTime)
newApps Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Text
currentApps
        ([Maybe (IO ())] -> [IO ()]) -> STM [Maybe (IO ())] -> STM [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (IO ())] -> [IO ()]
forall a. [Maybe a] -> [a]
catMaybes (STM [Maybe (IO ())] -> STM [IO ()])
-> STM [Maybe (IO ())] -> STM [IO ()]
forall a b. (a -> b) -> a -> b
$ (Text -> STM (Maybe (IO ()))) -> [Text] -> STM [Maybe (IO ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map AppId (TVar AppState) -> Text -> STM (Maybe (IO ()))
getAction Map AppId (TVar AppState)
m) [Text]
allApps
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
actions
  where
    toAppName :: AppId -> Maybe Text
toAppName AppId
AIBuiltin   = Maybe Text
forall a. Maybe a
Nothing
    toAppName (AINamed Text
x) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x

    getAction :: Map AppId (TVar AppState) -> Text -> STM (Maybe (IO ()))
getAction Map AppId (TVar AppState)
currentApps Text
appname = do
        case AppId -> Map AppId (TVar AppState) -> Maybe (TVar AppState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> AppId
AINamed Text
appname) Map AppId (TVar AppState)
currentApps of
            Maybe (TVar AppState)
Nothing -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
freshLaunch
            Just TVar AppState
tstate -> do
                AppState
state <- TVar AppState -> STM AppState
forall a. TVar a -> STM a
readTVar TVar AppState
tstate
                case AppState
state of
                    AppState
ASTerminated -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
freshLaunch
                    ASRunning App
app ->
                        case Text -> Map Text (String, EpochTime) -> Maybe (String, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
appname Map Text (String, EpochTime)
newApps of
                            Maybe (String, EpochTime)
Nothing -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
terminate
                            Just (String
fp, EpochTime
newTimestamp) -> do
                                Maybe EpochTime
moldTimestamp <- App -> STM (Maybe EpochTime)
App.getTimestamp App
app
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ()) -> STM (Maybe (IO ())))
-> Maybe (IO ()) -> STM (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ if Maybe EpochTime
moldTimestamp Maybe EpochTime -> Maybe EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
== EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
newTimestamp
                                    then Maybe (IO ())
forall a. Maybe a
Nothing
                                    else String -> EpochTime -> Maybe (IO ())
reload String
fp EpochTime
newTimestamp
                    ASStarting Maybe App
_ TVar (Maybe EpochTime)
tmoldTimestamp TVar (Maybe Action)
tmaction ->
                        case Text -> Map Text (String, EpochTime) -> Maybe (String, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
appname Map Text (String, EpochTime)
newApps of
                            Maybe (String, EpochTime)
Nothing -> do
                                TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmaction (Maybe Action -> STM ()) -> Maybe Action -> STM ()
forall a b. (a -> b) -> a -> b
$ Action -> Maybe Action
forall a. a -> Maybe a
Just Action
Terminate
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
forall a. Maybe a
Nothing
                            Just (String
fp, EpochTime
newTimestamp) -> do
                                Maybe EpochTime
moldTimestamp <- TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
tmoldTimestamp
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ()) -> STM (Maybe (IO ())))
-> Maybe (IO ()) -> STM (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ if Maybe EpochTime
moldTimestamp Maybe EpochTime -> Maybe EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
== EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
newTimestamp
                                    then Maybe (IO ())
forall a. Maybe a
Nothing
                                    else String -> EpochTime -> Maybe (IO ())
reload String
fp EpochTime
newTimestamp
      where
        freshLaunch :: Maybe (IO ())
freshLaunch =
            case Text -> Map Text (String, EpochTime) -> Maybe (String, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
appname Map Text (String, EpochTime)
newApps of
                Maybe (String, EpochTime)
Nothing              -> Bool -> Maybe (IO ()) -> Maybe (IO ())
forall a. (?callStack::CallStack) => Bool -> a -> a
E.assert Bool
False Maybe (IO ())
forall a. Maybe a
Nothing
                Just (String
fp, EpochTime
timestamp) -> String -> EpochTime -> Maybe (IO ())
reload String
fp EpochTime
timestamp
        terminate :: Maybe (IO ())
terminate = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am (Text -> AppId
AINamed Text
appname) Action
Terminate
        reload :: String -> EpochTime -> Maybe (IO ())
reload String
fp EpochTime
timestamp = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am (Text -> AppId
AINamed Text
appname) (AppInput -> Action
Reload (AppInput -> Action) -> AppInput -> Action
forall a b. (a -> b) -> a -> b
$ String -> EpochTime -> AppInput
AIBundle String
fp EpochTime
timestamp)
        {-
        case (Map.lookup appname currentApps, Map.lookup appname newApps) of
            (Nothing, Nothing) -> E.assert False Nothing
            (Just _, Nothing) -> Just $ perform am (AINamed appname) Terminate
            (Nothing, Just _) -> Just $ perform am (AINamed appname) (Reload AIBundle)
            -}

    {- FIXME
        actions <- do

            current <- getAllApps appMan
            let apps = Set.toList $ Set.fromList (Map.keys newMap) `Set.union` current
            fmap catMaybes $ forM apps $ \appname -> return $
                case (Set.member appname current, Map.lookup appname newMap) of
                    (False, Nothing) -> Nothing -- should never happen
                    (True, Nothing) -> Just $ terminateApp appname
                    (False, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle
                    (Just (_, oldTime), Just (bundle, newTime))
                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle
                        | otherwise -> Nothing
        P.sequence_ actions

getAllApps :: AppManager -> IO (Set Appname)
getAllApps AppManager {..} = atomically $ do
    m <- readTVar apps
    return $ Set.fromList $ mapMaybe toAppName $ Map.keys m
    -}

perform :: AppManager -> AppId -> Action -> IO ()
perform :: AppManager -> AppId -> Action -> IO ()
perform AppManager
am AppId
appid Action
action = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (AppManager -> MVar ()
mutex AppManager
am) ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am AppId
appid Action
action

performNoLock :: AppManager -> AppId -> Action -> IO ()
performNoLock :: AppManager -> AppId -> Action -> IO ()
performNoLock am :: AppManager
am@AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} AppId
aid Action
action = IO () -> IO ()
forall a. IO a -> IO a
E.mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO ()
launchWorker' <- STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
        Map AppId (TVar AppState)
m <- TVar (Map AppId (TVar AppState)) -> STM (Map AppId (TVar AppState))
forall a. TVar a -> STM a
readTVar TVar (Map AppId (TVar AppState))
apps
        case AppId -> Map AppId (TVar AppState) -> Maybe (TVar AppState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AppId
aid Map AppId (TVar AppState)
m of
            Just TVar AppState
tstate -> do
                AppState
state <- TVar AppState -> STM AppState
forall a. TVar a -> STM a
readTVar TVar AppState
tstate
                case AppState
state of
                    ASStarting Maybe App
_mcurrent TVar (Maybe EpochTime)
_tmtimestamp TVar (Maybe Action)
tmnext -> do
                        TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmnext (Maybe Action -> STM ()) -> Maybe Action -> STM ()
forall a b. (a -> b) -> a -> b
$ Action -> Maybe Action
forall a. a -> Maybe a
Just Action
action
                        -- use the previous worker, so nothing to do
                        IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
noWorker
                    ASRunning App
runningApp -> do
                        TVar (Maybe Action)
tmnext <- Maybe Action -> STM (TVar (Maybe Action))
forall a. a -> STM (TVar a)
newTVar Maybe Action
forall a. Maybe a
Nothing
                        TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                            case Action
action of
                                Reload (AIBundle String
_fp EpochTime
timestamp) -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                                Reload (AIData BundleConfig
_) -> Maybe EpochTime
forall a. Maybe a
Nothing
                                Action
Terminate -> Maybe EpochTime
forall a. Maybe a
Nothing
                        TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting (App -> Maybe App
forall a. a -> Maybe a
Just App
runningApp) TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
                        IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager
am AppId
aid TVar AppState
tstate TVar (Maybe Action)
tmnext (App -> Maybe App
forall a. a -> Maybe a
Just App
runningApp) Action
action
                    AppState
ASTerminated -> STM (IO ())
onNotRunning
            Maybe (TVar AppState)
Nothing -> STM (IO ())
onNotRunning
    IO ()
launchWorker'
  where
    noWorker :: IO ()
noWorker = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    onNotRunning :: STM (IO ())
onNotRunning =
        case Action
action of
            Reload AppInput
input -> do
                TVar (Maybe Action)
tmnext <- Maybe Action -> STM (TVar (Maybe Action))
forall a. a -> STM (TVar a)
newTVar Maybe Action
forall a. Maybe a
Nothing
                TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                    case AppInput
input of
                        AIBundle String
_fp EpochTime
timestamp -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                        AIData BundleConfig
_               -> Maybe EpochTime
forall a. Maybe a
Nothing
                TVar AppState
tstate <- AppState -> STM (TVar AppState)
forall a. a -> STM (TVar a)
newTVar (AppState -> STM (TVar AppState))
-> AppState -> STM (TVar AppState)
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting Maybe App
forall a. Maybe a
Nothing TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
                TVar (Map AppId (TVar AppState))
-> (Map AppId (TVar AppState) -> Map AppId (TVar AppState))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map AppId (TVar AppState))
apps ((Map AppId (TVar AppState) -> Map AppId (TVar AppState))
 -> STM ())
-> (Map AppId (TVar AppState) -> Map AppId (TVar AppState))
-> STM ()
forall a b. (a -> b) -> a -> b
$ AppId
-> TVar AppState
-> Map AppId (TVar AppState)
-> Map AppId (TVar AppState)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AppId
aid TVar AppState
tstate
                IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager
am AppId
aid TVar AppState
tstate TVar (Maybe Action)
tmnext Maybe App
forall a. Maybe a
Nothing Action
action
            Action
Terminate -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
noWorker

launchWorker :: AppManager
             -> AppId
             -> TVar AppState
             -> TVar (Maybe Action)
             -> Maybe App
             -> Action
             -> IO ()
launchWorker :: AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} AppId
appid TVar AppState
tstate TVar (Maybe Action)
tmnext Maybe App
mcurrentApp0 Action
action0 = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Maybe App -> Action -> IO ()
loop Maybe App
mcurrentApp0 Action
action0
  where
    loop :: Maybe App -> Action -> IO ()
loop Maybe App
mcurrentApp Action
action = do
        Maybe App
mRunningApp <- Maybe App -> Action -> IO (Maybe App)
processAction Maybe App
mcurrentApp Action
action
        Maybe Action
mnext <- STM (Maybe Action) -> IO (Maybe Action)
forall a. STM a -> IO a
atomically (STM (Maybe Action) -> IO (Maybe Action))
-> STM (Maybe Action) -> IO (Maybe Action)
forall a b. (a -> b) -> a -> b
$ do
            Maybe Action
mnext <- TVar (Maybe Action) -> STM (Maybe Action)
forall a. TVar a -> STM a
readTVar TVar (Maybe Action)
tmnext
            TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmnext Maybe Action
forall a. Maybe a
Nothing
            case Maybe Action
mnext of
                Maybe Action
Nothing ->
                    case Maybe App
mRunningApp of
                        Maybe App
Nothing -> TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate AppState
ASTerminated
                        Just App
runningApp -> TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ App -> AppState
ASRunning App
runningApp
                Just Action
_next -> do
                    TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                        case Action
action of
                            Reload (AIBundle String
_fp EpochTime
timestamp) -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                            Reload (AIData BundleConfig
_)               -> Maybe EpochTime
forall a. Maybe a
Nothing
                            Action
Terminate                       -> Maybe EpochTime
forall a. Maybe a
Nothing
                    TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting Maybe App
mRunningApp TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
            Maybe Action -> STM (Maybe Action)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Action
mnext
        case Maybe Action
mnext of
            Maybe Action
Nothing   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Action
next -> Maybe App -> Action -> IO ()
loop Maybe App
mRunningApp Action
next

    processAction :: Maybe App -> Action -> IO (Maybe App)
processAction Maybe App
Nothing Action
Terminate = Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
    processAction (Just App
app) Action
Terminate = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LogMessage
Terminating (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ App -> String
forall a. Show a => a -> String
show App
app
        App -> IO ()
App.terminate App
app
        Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
    processAction Maybe App
Nothing (Reload AppInput
input) = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> LogMessage
ReloadFrom Maybe String
forall a. Maybe a
Nothing (String -> LogMessage) -> String -> LogMessage
forall a b. (a -> b) -> a -> b
$ AppInput -> String
forall a. Show a => a -> String
show AppInput
input
        Either SomeException App
eres <- IO App -> IO (Either SomeException App)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO App -> IO (Either SomeException App))
-> IO App -> IO (Either SomeException App)
forall a b. (a -> b) -> a -> b
$ AppStartConfig -> AppId -> AppInput -> IO App
App.start AppStartConfig
appStartConfig AppId
appid AppInput
input
        case Either SomeException App
eres of
            Left SomeException
e -> do
                LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SomeException -> LogMessage
ErrorStartingBundle Text
name SomeException
e
                Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
            Right App
app -> Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe App -> IO (Maybe App)) -> Maybe App -> IO (Maybe App)
forall a b. (a -> b) -> a -> b
$ App -> Maybe App
forall a. a -> Maybe a
Just App
app
    processAction (Just App
app) (Reload AppInput
input) = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> LogMessage
ReloadFrom (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ App -> String
forall a. Show a => a -> String
show App
app) (AppInput -> String
forall a. Show a => a -> String
show AppInput
input)
        Either SomeException ()
eres <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ App -> AppInput -> IO ()
App.reload App
app AppInput
input
        case Either SomeException ()
eres of
            Left SomeException
e -> do
                LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SomeException -> LogMessage
ErrorStartingBundle Text
name SomeException
e
                -- reloading will /always/ result in a valid app, either the old one
                -- will continue running or the new one will replace it.
                Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (App -> Maybe App
forall a. a -> Maybe a
Just App
app)
            Right () -> Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe App -> IO (Maybe App)) -> Maybe App -> IO (Maybe App)
forall a b. (a -> b) -> a -> b
$ App -> Maybe App
forall a. a -> Maybe a
Just App
app

    name :: Text
name =
        case AppId
appid of
            AppId
AIBuiltin -> Text
"<builtin>"
            AINamed Text
x -> Text
x

addApp :: AppManager -> FilePath -> IO ()
addApp :: AppManager -> String -> IO ()
addApp AppManager
appMan String
bundle = do
    (AppId
input, Action
action) <- String -> IO (AppId, Action)
getInputForBundle String
bundle
    AppManager -> AppId -> Action -> IO ()
perform AppManager
appMan AppId
input Action
action

getInputForBundle :: FilePath -> IO (AppId, Action)
getInputForBundle :: String -> IO (AppId, Action)
getInputForBundle String
bundle = do
    EpochTime
time <- FileStatus -> EpochTime
modificationTime (FileStatus -> EpochTime) -> IO FileStatus -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
bundle
    (AppId, Action) -> IO (AppId, Action)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> AppId
AINamed (Text -> AppId) -> Text -> AppId
forall a b. (a -> b) -> a -> b
$ String -> Text
getAppname String
bundle, AppInput -> Action
Reload (AppInput -> Action) -> AppInput -> Action
forall a b. (a -> b) -> a -> b
$ String -> EpochTime -> AppInput
AIBundle String
bundle EpochTime
time)

terminateApp :: AppManager -> Appname -> IO ()
terminateApp :: AppManager -> Text -> IO ()
terminateApp AppManager
appMan Text
appname = AppManager -> AppId -> Action -> IO ()
perform AppManager
appMan (Text -> AppId
AINamed Text
appname) Action
Terminate