{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Box.Control
( ControlRequest (..),
ControlResponse (..),
Toggle (..),
ControlBox,
ControlBox_,
ControlConfig (..),
defaultControlConfig,
consoleControlBox,
consoleControlBox_,
parseControlRequest,
controlBox,
controlBoxProcess,
controlConsole,
testBoxManual,
testBoxAuto,
beep,
timeOut,
timedRequests,
testCatControl,
)
where
import Box
import Control.Applicative
import Control.Concurrent.Async
import Control.Concurrent.Classy.IORef as C
import Control.Concurrent.Classy.STM.TVar as C
import Control.Lens hiding ((|>))
import Control.Monad
import Control.Monad.Conc.Class as C
import Control.Monad.STM.Class as C
import Control.Monad.Trans.Class
import qualified Data.Attoparsec.Text as A
import Data.Bool
import Data.Data
import Data.Functor
import Data.Maybe
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.IO as Text
import GHC.Generics
import qualified Streaming.Prelude as S
import System.IO
import System.Process.Typed
import Prelude
data ControlRequest
= Check
| Start
| Stop
| Reset
| Quit
deriving (Show, Read, Eq, Data, Typeable, Generic)
parseControlRequest :: A.Parser a -> A.Parser (Either ControlRequest a)
parseControlRequest pa =
A.string "check" $> Left Check
<|> A.string "start" $> Left Start
<|> A.string "quit" $> Left Stop
<|> A.string "reset" $> Left Reset
<|> A.string "shutdown" $> Left Quit
<|> (Right <$> pa)
data Toggle = On | Off deriving (Show, Read, Eq, Generic)
data ControlResponse
= ShuttingDown
| Status (Toggle, Int)
| Info Text
deriving (Show, Read, Eq, Generic)
type ControlBox_ m = (MonadConc m) => Cont m (Box (STM m) ControlResponse ControlRequest)
type ControlBox a b m = (MonadConc m) => Cont m (Box (STM m) (Either ControlResponse a) (Either ControlRequest b))
data ControlConfig
= ControlConfig
{
starts :: Int,
autoStart :: Bool,
autoRestart :: Maybe Double,
debug :: Bool
}
deriving (Show, Eq, Ord)
defaultControlConfig :: ControlConfig
defaultControlConfig = ControlConfig 1 False Nothing False
consoleControlBox :: ControlBox Text Text IO
consoleControlBox =
Box
<$> ( contramap (Text.pack . show)
<$> (cStdout 1000 :: Cont IO (Committer (STM IO) Text))
)
<*> ( emap (pure . either (const Nothing) Just)
<$> ( eParse (parseControlRequest A.takeText)
<$> eStdin 1000
)
)
consoleControlBox_ :: ControlBox_ IO
consoleControlBox_ =
bmap (pure . Just . Left) (pure . either Just (const Nothing))
<$> consoleControlBox
data ControlBoxState a = CBS {actionThread :: Maybe (Async ()), restartsLeft :: Int}
controlBox ::
ControlConfig ->
IO a ->
Box (STM IO) ControlResponse ControlRequest ->
IO ()
controlBox (ControlConfig restarts' autostart autorestart debug') app (Box c e) = do
info "controlBox"
ref <- C.newIORef (CBS Nothing restarts')
shut <- atomically $ newTVar False
when autostart (info "autostart" >> start ref shut)
info "race_"
race_
(go ref shut)
(shutCheck shut)
cancelThread ref
info "controlBox end"
where
cancelThread r = do
info "cancelThread"
(CBS a n) <- readIORef r
maybe (info "no thread found" >> pure ()) (\x -> cancel x >> info "thread cancelled") a
writeIORef r (CBS Nothing n)
shutCheck s = do
info "shutCheck"
atomically $ check =<< readTVar s
info "shutCheck signal received"
status r = do
info "status"
s <- C.readIORef r
C.atomically
( void $
commit
c
(Status (bool Off On (isJust (actionThread s)), restartsLeft s))
)
loopApp r s app' = do
info "loopApp"
_ <- app'
info "post app'"
checkRestarts r s
info "maybe restarting"
maybe (pure ()) (\t -> sleep t >> dec r >> loopApp r s app') autorestart
dec r = do
info "dec"
cfg@(CBS _ n) <- readIORef r
writeIORef r (cfg {restartsLeft = n - 1})
start r s = do
info "start"
(CBS a _) <- readIORef r
when (isNothing a) $ do
a' <-
async
( do
dec r
loopApp r s app
cfg <- readIORef r
writeIORef r (cfg {actionThread = Nothing})
)
link a'
cfg <- readIORef r
writeIORef r (cfg {actionThread = Just a'})
stop r s = do
info "stop"
cancelThread r
checkRestarts r s
info t = bool (pure ()) (void $ commit (liftC c) $ Info t) debug'
shutdown = do
info "shutDown"
void $ commit (liftC c) ShuttingDown
checkRestarts r s = do
info "check restarts"
(CBS _ n) <- C.readIORef r
bool
( do
atomically $ writeTVar s True
shutdown
)
(pure ())
(n > 0)
go r s = do
info "go"
status r
msg <- C.atomically $ emit e
case msg of
Nothing -> go r s
Just msg' ->
case msg' of
Check ->
go r s
Start -> do
start r s
go r s
Stop -> do
stop r s
go r s
Quit -> stop r s >> shutdown
Reset -> stop r s >> start r s >> go r s
data CBP = CBP {listenThread :: Maybe (Async ()), process :: Maybe (Process Handle Handle ()), restarts :: Int}
controlBoxProcess ::
ControlConfig ->
ProcessConfig Handle Handle () ->
Box (STM IO) (Either ControlResponse Text) (Either ControlRequest Text) ->
IO ()
controlBoxProcess (ControlConfig restarts' autostart _ debug') pc (Box c e) = do
info "controlBoxProcess"
ref <- C.newIORef (CBP Nothing Nothing restarts')
shut <- atomically $ C.newTVar False
when autostart (info "autostart" >> start ref shut)
info "race_"
race_
(go ref shut)
(shutCheck shut)
cancelThread ref
info "controlBoxProcess end"
where
cancelThread r = do
info "cancelThread"
a <- readIORef r
maybe (info "no listener on cancelThread") (\x -> cancel x >> info "listener cancelled") (listenThread a)
maybe (info "no process on cancelThread") (\x -> stopProcess x >> info "process cancelled") (process a)
writeIORef r (CBP Nothing Nothing (restarts a))
shutCheck s = do
info "shutCheck"
atomically $ check =<< readTVar s
info "shutCheck signal received"
status r = do
info "status"
a <- C.readIORef r
C.atomically
( void $
commit
c
(Left $ Status (bool Off On (isJust (process a)), restarts a))
)
loopApp r _ = do
info "loopApp"
p' <- startProcess pc
a <- readIORef r
when (isJust (process a)) (info "eeek, a process ref has been overwritten")
when (isJust (listenThread a)) (info "eeek, a listener ref has been overwritten")
info "process is up"
wo <- async (lloop0 (getStdout p'))
writeIORef r (CBP (Just wo) (Just p') (restarts a))
info "listener is up"
link wo
lloop0 o = do
b <- hIsEOF o
when (not b) (checkOutH o >> lloop0 o)
checkOutH o = do
info "waiting for process output"
t <- Text.hGetLine o
info ("received: " <> t)
C.atomically $ void $ commit (contramap Right c) t
dec r = do
info "dec"
a <- readIORef r
writeIORef r (a {restarts = restarts a - 1})
start r s = do
info "start"
a <- readIORef r
when (isNothing (process a)) $ do
dec r
loopApp r s
stop r s = do
info "stop"
cancelThread r
checkRestarts r s
info t = bool (pure ()) (void $ commit (liftC c) $ Left (Info t)) debug'
shutdown = do
info "shutDown"
void $ commit (liftC c) (Left ShuttingDown)
checkRestarts r s = do
info "check restarts"
n <- restarts <$> C.readIORef r
bool
( do
atomically $ writeTVar s True
shutdown
)
(pure ())
(n > 0)
writeIn r t = do
info ("writeIn: " <> t)
p <- process <$> C.readIORef r
maybe
(info "no stdin available")
(\i -> hPutStrLn (getStdin i) (Text.unpack t) >> hFlush (getStdin i))
p
go r s = do
info "go"
status r
msg <- C.atomically $ emit e
case msg of
Nothing -> go r s
Just msg' ->
case msg' of
Left Check ->
go r s
Left Start -> do
start r s
go r s
Left Stop -> do
stop r s
go r s
Left Quit -> stop r s >> shutdown
Left Reset -> stop r s >> start r s >> go r s
Right t -> writeIn r t >> go r s
controlConsole ::
Cont IO (Box (STM IO) (Either ControlResponse Text) (Either ControlRequest Text))
controlConsole =
Box
<$> ( contramap (either (("Response: " <>) . Text.pack . show) id)
<$> (cStdout 1000 :: Cont IO (Committer (STM IO) Text))
)
<*> ( fmap (either (Right . ("parse error: " <>)) id)
. eParse (parseControlRequest A.takeText) <$> eStdin 1000
)
beep :: Int -> Int -> Double -> IO ()
beep m x s = when (x <= m) (sleep s >> Text.putStrLn ("beep " <> Text.pack (show x)) >> beep m (x + 1) s)
timeOut :: Double -> ControlBox m a b
timeOut t =
Box <$> mempty <*> ((lift (sleep t) >> S.yield (Left Quit)) & toEmit)
timedRequests ::
(MonadConc m) =>
[(ControlRequest, Double)] ->
Cont m (Emitter (STM m) ControlRequest)
timedRequests xs = toEmit $ foldr (>>) (pure ()) $ (\(a, t) -> lift (sleep t) >> S.yield a) <$> xs
testBoxManual :: ControlConfig -> Double -> IO () -> IO ()
testBoxManual cfg t effect =
with
( bmap (pure . Just . Left) (pure . either Just (const Nothing))
<$> consoleControlBox <> timeOut t
)
(controlBox cfg effect)
testBoxAuto :: ControlConfig -> Double -> [(ControlRequest, Double)] -> IO () -> IO ()
testBoxAuto cfg t xs effect =
with
( bmap (pure . Just . Left) (pure . either Just (const Nothing))
<$> ( consoleControlBox
<> timeOut t
<> (Box <$> mempty <*> (fmap Left <$> timedRequests xs))
)
)
(controlBox cfg effect)
cannedCat :: ProcessConfig Handle Handle ()
cannedCat =
setStdin createPipe
$ setStdout createPipe
$ setStderr
closed
"cat"
testCatControl :: ControlConfig -> IO ()
testCatControl cfg = with controlConsole (controlBoxProcess cfg cannedCat)