GitLab maintenance scheduled for Tomorrow, 2020-03-31, from 17:00 to 18:00 CT - Services will be unavailable during this time.

argotk.hs 3.11 KB
Newer Older
1
#! /usr/bin/env runhaskell
2 3 4 5 6 7 8 9 10 11

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

import Argotest
import Turtle
import Data.Default
import Control.Concurrent.Async
12
import System.Environment
13 14 15 16 17
import System.Console.ANSI
import System.Console.ANSI.Types (Color)
import Options.Applicative
import System.Posix.Signals
import Control.Monad
18
import System.Environment.FindBin
19

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

main :: IO ()
36 37 38 39
main = do
  manifests <- getEnv "MANIFESTS"
  let sa = def { manifest = decodeString manifests </> manifest def}
  join $ execParser (info (opts sa <**>helper) idm)
40

41 42
runApp :: StackArgs -> Text -> IO ()
runApp sa app = runSimpleStack $ sa {app = app}
43

44 45 46 47 48 49 50 51 52
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"

53 54
runSimpleStack :: StackArgs -> IO ()
runSimpleStack a@StackArgs{..} = sh $ do
55 56
  cleanLeftovers daemon_out daemon_err cmd_out cmd_err time_file nrm_log
  daemonShell <- prepareDaemonShell dargs daemon_out daemon_err nrm_log
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
  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))

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

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