temp.hs

#!/usr/bin/env stack
-- stack --resolver=lts-12.9 script

{-#LANGUAGE
  ConstraintKinds,
  FlexibleContexts,
  GADTs,
  LambdaCase,
  KindSignatures,
  MultiWayIf,
  NamedFieldPuns,
  OverloadedLists,
  OverloadedStrings,
  PartialTypeSignatures,
  PatternGuards,
  RecordWildCards,
  ViewPatterns
  #-}

module Main where

import Prelude hiding (putStrLn)

import Data.Text.IO (putStrLn)
import Control.Concurrent (MVar (..), ThreadId (..), forkIO, killThread, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar, threadDelay)
import Control.Concurrent.STM (atomically)
import Control.Monad (forever, join)
import Control.Monad.RWS.Strict (MonadIO (..), liftIO)
import Data.Text (Text (..), append, isPrefixOf, singleton, snoc)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime)
import GHC.Exts (IsString (..))
import GHC.IO.Handle (hSetEcho)
import Pipes (Consumer (..), Producer (..), Pipe (..), (>->), await, runEffect, yield)
import Pipes.Concurrent (Buffer (..), Input (..), Output (..), bounded, fromInput, spawn, toOutput, unbounded)
import System.Exit (die)
import System.IO (BufferMode (..), hSetBuffering, stdin)
import System.Posix.Signals (Signal (..))

data ConsoleEvent :: * where
  CeBegan :: ConsoleEvent
  CeKeyboard :: Char -> ConsoleEvent
  CeSignal :: Signal -> ConsoleEvent
  CeTimeout :: ConsoleEvent
  deriving (Eq, Show)

chars :: Producer ConsoleEvent IO ()
chars = liftIO getChar >>= yield . CeKeyboard

dumped :: Consumer ConsoleEvent IO ()
dumped = await >>= liftIO . putStrLn . fromString . show

withTimeout :: (MonadIO t) => Int -> IO (Pipe ConsoleEvent ConsoleEvent t (), Producer ConsoleEvent t ())
withTimeout ((* 1000000) -> s) =
  do
    (oTimeout, iTimeout) <- spawn $ bounded 1
    vTid <- launchTimeout oTimeout >>= newMVar

    return (factorTimeout vTid oTimeout, fromInput iTimeout)
  where
    launchTimeout :: Output ConsoleEvent -> IO ThreadId
    launchTimeout o =
      forkIO . forever $ do
        threadDelay $ s
        (atomically $ send o CeTimeout) >>= \case
          True -> return ()
          otherwise -> die "withTimeout can not send timeout"

    relaunchTimeout :: Output ConsoleEvent -> ThreadId -> IO ThreadId
    relaunchTimeout o oldTid = 
      do
        tid <- launchTimeout o
        killThread oldTid
        return tid

    factorTimeout :: (MonadIO t) => MVar ThreadId -> Output ConsoleEvent -> Pipe ConsoleEvent ConsoleEvent t ()
    factorTimeout v o =
      do
        ce <- await
        liftIO . modifyMVar_ v $ relaunchTimeout o
        yield ce

dump :: (Show r, MonadIO m) => Text -> r -> m ()
dump s r =
  do
    z <- liftIO getCurrentTimeZone
    u <- liftIO getCurrentTime

    liftIO . putStrLn . fromString . show $ (
      s,
      formatTime defaultTimeLocale "%Y%m%dT%H%M%S.%qZ%Z" $ utcToLocalTime z u, 
      r)

dumpPipe :: (Show r, MonadIO m) => Pipe r r m ()
dumpPipe =
  do
    r <- await
    dump "pipe" r
    yield r

main :: IO ()
main =
  do
    hSetBuffering stdin NoBuffering
    hSetEcho stdin False

    exitSemaphore <- newEmptyMVar
    (o1, i1) <- spawn $ bounded 1
    (o2, i2) <- spawn $ bounded 1

    (timeoutTrap, timeoutRender) <- withTimeout 2
    
    runEffect $ yield CeBegan >-> toOutput o1

    forkIO $ do
      runEffect . forever $ chars >-> toOutput o1
      putMVar exitSemaphore ()

    -- other inputs would be piped to o1 here
      
    forkIO $ do
      runEffect . forever $ fromInput i1 >-> timeoutTrap >-> toOutput o2
      putMVar exitSemaphore ()

    forkIO $ do
      runEffect . forever $ timeoutRender >-> toOutput o2
      putMVar exitSemaphore ()

    forkIO $ do
      -- logic would be done before dumpPipe
      runEffect . forever $ fromInput i2 >-> dumpPipe >-> (await >> return ())
      putMVar exitSemaphore ()

    takeMVar exitSemaphore