{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Box.Control
( ControlComm(..)
, ControlBox
, ControlConfig(..)
, defaultControlConfig
, consoleControlBox
, parseControlComms
, controlBox
, runControlBox
, testBox
, timeOut
) where
import Box
import Control.Applicative
import Control.Category
import Control.Concurrent.Async
import Control.Lens hiding ((|>))
import Control.Monad
import Data.Data
import GHC.Generics
import Protolude hiding ((.), STM)
import Text.Read (readMaybe)
import qualified Data.Attoparsec.Text as A
import qualified Data.Text as Text
import qualified Streaming.Prelude as S
import Control.Monad.Conc.Class as C
data ControlComm
= Ready
| Check
| Died
| Stop
| Kill
| ShutDown
| Start
| Reset
| On Bool
| Log Text
deriving (Show, Read, Eq, Data, Typeable, Generic)
type ControlBox m = (MonadConc m) => Cont m (Box (STM m) ControlComm ControlComm)
data ControlConfig
= KeepAlive Double
| AllowDeath
deriving (Show, Eq)
defaultControlConfig :: ControlConfig
defaultControlConfig = AllowDeath
consoleControlBox :: ControlBox IO
consoleControlBox =
Box <$>
(contramap show <$>
(cStdout 1000 :: Cont IO (Committer (STM IO) Text))) <*>
(emap (pure . either (const Nothing) Just) <$>
(eParse parseControlComms <$>
eStdin 1000))
parseControlComms :: A.Parser ControlComm
parseControlComms =
A.string "q" $> Stop <|> A.string "s" $> Start <|>
A.string "x" $> Kill <|> do
res <- readMaybe . Text.unpack <$> A.takeText
case res of
Nothing -> mzero
Just a -> return a
controlBox
:: ControlConfig
-> IO a -> Box (STM IO) ControlComm ControlComm -> IO Bool
controlBox cfg app (Box c e) = do
ref' <- C.newIORef Nothing
go ref'
where
go ref = do
msg <- C.atomically $ emit e
case msg of
Nothing -> go ref
Just msg' ->
case msg' of
Check -> do
a <- C.readIORef ref
_ <-
C.atomically $ commit c $ On (bool True False (isNothing a))
go ref
Start -> do
a <- C.readIORef ref
when (isNothing a) (void $ start ref c)
go ref
Stop -> cancel' ref >> go ref
Kill -> cancel' ref >> C.atomically (commit c ShutDown)
Died ->
case cfg of
AllowDeath -> C.atomically $ commit c ShutDown
KeepAlive x -> do
sleep x
_ <- C.atomically $ commit c Start
go ref
Reset -> do
a <- C.readIORef ref
unless (isNothing a) (cancel' ref)
_ <- start ref c
go ref
_ -> go ref
start ref c' = do
a' <- async (app >> C.atomically (commit c' Died))
C.writeIORef ref (Just a')
C.atomically $ commit c' Ready
cancel' ref = do
mapM_ cancel =<< C.readIORef ref
C.writeIORef ref Nothing
runControlBox :: ControlConfig -> IO () -> IO ()
runControlBox cfg action =
etc
()
(Transducer $ \s -> s & S.takeWhile (/= ShutDown))
(boxForgetPlug (void <$> controlBox cfg action))
testBox :: IO Bool
testBox = cb
where
action =
sequence_ $
(\x -> putStrLn x >> sleep 1) . (show :: Integer -> Text) <$>
reverse [0 .. 10]
cb = with consoleControlBox (controlBox (KeepAlive 3) action)
timeOut :: Double -> ControlBox m
timeOut t =
Box <$> mempty <*> ((lift (sleep t) >> S.yield Stop) & toEmit)