argotk.hs 2.82 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 52 53 54 55 56 57 58 59 60 61
  cleanLeftovers daemon_out daemon_err cmd_out cmd_err time_file nrm_log

  daemonShell <- prepareDaemonShell dargs daemon_out daemon_err nrm_log
  daemonAsync <- fork $ sh $ daemonShell
  let handler = do
                sh $ printInfo "Interrupted. Killing daemon..."
                cancel daemonAsync
                sh $ colorShell Green $ printf "Killed daemon.\n"
  liftIO $ installHandler keyboardSignal (Catch handler) Nothing

  printInfo "Launching the application through cmd.\n"
  (_,t) <- time $
62
    shell (format ("cmd run -u toto "%fp%"  "%s%" > "%fp%" 2>"%fp) manifest app cmd_out cmd_err) empty >>= \case
63 64 65 66 67 68 69 70 71 72 73 74 75 76
      ExitSuccess   -> printInfo "cmd has exited successfuly.\n"
      ExitFailure n -> die ("cmd failed with exit code " <> repr n <>
        " . The application logs are at " <> repr cmd_out <> " " <> repr cmd_err )
  liftIO $ writeTextFile time_file (repr t)

  printInfo "Killing the daemon.\n"
  liftIO $ cancel daemonAsync
  printInfo "Daemon killed.\n"

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

runDaemon :: StackArgs -> IO ()
77 78
runDaemon StackArgs{..} = sh $
  prepareDaemonShell dargs daemon_out daemon_err nrm_log >>= id