argotk.hs 3.01 KB
Newer Older
1
#! /usr/bin/env runhaskell
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

{-# LANGUAGE
    OverloadedStrings
  , LambdaCase
  , RecordWildCards #-}

import Argotest
import Turtle
import Data.Default
import Control.Concurrent.Async
import System.Console.ANSI
import System.Console.ANSI.Types (Color)
import Options.Applicative
import System.Posix.Signals
import Control.Monad

opts :: Parser (IO ())
opts = subparser
20 21 22 23 24 25 26 27 28 29 30 31
  ( command "clean" (info (pure $ runClean def)
     (progDesc "Clean sockets, logfiles."))
 <> command "daemon"  (info (pure $ runDaemon def)
     (progDesc "Set up and launch the daemon in synchronous mode, \
               \with properly cleaned sockets, logfiles."))
 <> command "application"  (info (runApp <$> argument str idm)
     (progDesc "Setup stack and run an arbitrary command in a container."))
 <> command "helloworld"  (info (pure $ runHelloWorld def )
     (progDesc "Setup stack and check that hello world app sends \
               \message back to cmd."))
 <> help "Type of action to run"
 )
32 33 34 35

main :: IO ()
main = join $ execParser (info (opts <**>helper) idm)

36 37 38
runApp :: Text -> IO ()
runApp app = runSimpleStack $ def {app = app}

39 40 41 42 43 44 45 46 47
runHelloWorld :: StackArgs -> IO ()
runHelloWorld a@StackArgs{..} = do
  let passStr = "HelloWorldFromApp"
  runSimpleStack $ a {app = format ("echo "%s) passStr}
  readTextFile cmd_err >>= \x -> case match (has "HelloWorldFromApp") x of
    [] -> die ("Hello world app failed to run.")
    _  -> sh $ printInfo "The hello world app executed properly in a \
                         \container and its message was received by `cmd`.\n"

48 49
runSimpleStack :: StackArgs -> IO ()
runSimpleStack a@StackArgs{..} = sh $ do
50 51
  cleanLeftovers daemon_out daemon_err cmd_out cmd_err time_file nrm_log
  daemonShell <- prepareDaemonShell dargs daemon_out daemon_err nrm_log
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
  liftIO $ do
    withAsync daemonShell $ \daemon -> do
    let handler = do
                  sh $ printInfo "Interrupted. Killing daemon..."
                  cancel daemon
                  sh $ colorShell Green $ printf "Killed daemon.\n"
    liftIO $ installHandler keyboardSignal (Catch handler) Nothing
    withAsync (time $ sh $ cmdShell manifest app cmd_out cmd_err ) $ \cmd -> do
    let handler = do
                  sh $ printInfo "Interrupted. Killing daemon..."
                  cancel daemon
                  sh $ colorShell Green $ printf "Killed daemon.\n"
                  sh $ printInfo "Interrupted. Killing cmd..."
                  cancel cmd
                  sh $ colorShell Green $ printf "Killed cmd.\n"
    liftIO $ installHandler keyboardSignal (Catch handler) Nothing
    (waitEitherCancel daemon cmd >>= \case
      Left _ -> die "Daemon died"
      Right (_,t) -> writeTextFile time_file (repr t))

72

73 74 75
  -- printInfo "Killing the daemon.\n"
  -- liftIO $ cancel daemon
  -- printInfo "Daemon killed.\n"
76 77 78 79 80 81 82


runClean :: StackArgs -> IO ()
runClean StackArgs{..} = sh $
  cleanLeftovers daemon_out daemon_err cmd_out cmd_err time_file nrm_log

runDaemon :: StackArgs -> IO ()
83
runDaemon StackArgs{..} = sh $ prepareDaemonShell dargs daemon_out daemon_err nrm_log >>= liftIO