Utils.hs 4.91 KB
Newer Older
1
{-# LANGUAGE LambdaCase, OverloadedStrings, DataKinds,
2
  FlexibleInstances, TypeOperators #-}
3 4 5

module Argo.Utils where

Valentin Reis's avatar
Valentin Reis committed
6
import           Argo.Args
7 8 9 10 11 12
import           Turtle
import           Prelude                 hiding ( FilePath )
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
import           System.Posix.Signals
import           System.Process          hiding ( shell )
13 14 15 16 17 18 19 20 21
import           Data.Conduit
import           Data.Conduit.Process    hiding ( shell )
import           Data.ByteString               as B
                                         hiding ( empty )
import           Data.Text.Encoding            as TE
import           Data.Conduit.Combinators      as CC
import           Control.Exception.Base
import           Data.Typeable
import           Data.Text                     as T
22 23 24

-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
25
colorShell color she = setC color *> she *> setC White
26 27 28
  where setC c = liftIO $ setSGR [SetColor Foreground Dull c]

printInfo :: Text -> Shell ()
29
printCommand :: Text -> Shell ()
30 31
printError :: Text -> Shell ()
printWarning :: Text -> Shell ()
32
printSuccess :: Text -> Shell ()
33
printTest :: Text -> Shell ()
34 35 36 37 38 39 40
dieRed :: Text -> Shell ()

printInfo = printf ("Info: " % s)
printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s)
printError = colorShell Red . printf ("Error: " % s)
printSuccess = colorShell Green . printf ("Success: " % s)
Valentin Reis's avatar
Valentin Reis committed
41
printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n")
42 43
dieRed str =
  colorShell Red (printf ("Failure: " % s) str) >> exit (ExitFailure 1)
44

45
myWhich :: FilePath -> Shell FilePath
46 47 48 49 50
myWhich str = which str >>= \case
  (Just p) ->
    printInfo (format ("Found " % fp % " at " % fp % "\n") str p) >> return p
  Nothing -> die $ format ("Argo `" % fp % "` not in $PATH.") str

51
myWhichMaybe :: FilePath -> Shell (Maybe FilePath)
52 53 54 55 56
myWhichMaybe str = which str >>= \case
  (Just p) -> printInfo (format ("Found " % fp % " at " % fp % "\n") str p)
    >> return (Just p)
  Nothing -> return Nothing

57 58 59 60 61 62 63 64 65
sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
sudoRemoveFile printer desc filePath = do
  foundSocket <- testfile filePath
  when foundSocket $ go False
  printInfo $ format ("OK: " % s % " " % fp % "\n") desc filePath
 where
  go useSudo = do
    printer $ format ("found stale " % s % " at " % fp % ".. ") desc filePath
    shell
Valentin Reis's avatar
Valentin Reis committed
66
        (format ((if useSudo then "sudo " else "") % "rm -rf " % fp) filePath)
67
        Turtle.empty
68 69
      >>= \case
            ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
70
            ExitFailure _ -> if useSudo
71 72 73 74 75 76 77 78 79
              then printer $ format
                ("Failed to remove stale " % s % ", even with sudo.")
                desc
              else do
                printer $ format
                  ("Failed to remove stale " % s % ". Trying sudo..\n")
                  desc
                go True

80
verboseShell :: Text -> Shell Line -> Shell ExitCode
81
verboseShell command i = printCommand command >> shell command i
82

83
verboseShell' :: Text -> Shell Line -> Shell (ExitCode, Text, Text)
84 85
verboseShell' command i =
  printCommand command >> shellStrictWithErr command i
86

87
cleanSocket :: FilePath -> Shell ()
88
cleanSocket = sudoRemoveFile printError "socket"
89
cleanLog :: FilePath -> Shell ()
Valentin Reis's avatar
Valentin Reis committed
90
cleanLog = sudoRemoveFile printWarning "log folder"
91 92 93

kbInstallHandler :: IO () -> IO Handler
kbInstallHandler h = installHandler keyboardSignal (Catch h) Nothing
94 95 96 97 98

data PatternMatched = PatternMatched deriving (Show, Typeable)
instance Exception PatternMatched

data Instrumentation = Instrumentation
Valentin Reis's avatar
Valentin Reis committed
99 100 101 102 103
  CreateProcess
  StdOutLog
  StdErrLog
  (Maybe TestText)
  deriving (Show)
104

105
runI :: Instrumentation -> IO (Either PatternMatched (ExitCode, (), ()))
106 107
runI (Instrumentation crProc (StdOutLog stdOut) (StdErrLog stdErr) t) = try
  (reroutedDaemon crProc)
108 109
 where
  reroutedDaemon process =
110
    withSinkFile (T.unpack stdOut)
Valentin Reis's avatar
Valentin Reis committed
111
      $ \outSink ->
112
          withSinkFile (T.unpack stdErr) $ \errSink -> sourceProcessWithStreams
113 114
            process
            mempty
Valentin Reis's avatar
Valentin Reis committed
115 116
            (makeMatcher t .| outSink)
            (makeMatcher t .| errSink)
117
  makeMatcher maybeMessage = case maybeMessage of
Valentin Reis's avatar
Valentin Reis committed
118 119
    Just (TestText msg) -> untilMatch msg
    Nothing             -> awaitForever yield
120 121 122 123 124 125 126 127 128 129
  untilMatch :: Text -> ConduitT ByteString ByteString IO ()
  untilMatch message = do
    inb <- await
    case inb of
      Just b -> if B.isInfixOf (TE.encodeUtf8 message) b
        then throw PatternMatched
        else do
          yield b
          untilMatch message
      _ -> return ()
Valentin Reis's avatar
Valentin Reis committed
130 131

processBehaviorToI :: CreateProcess -> ProcessBehavior -> Maybe Instrumentation
132
processBehaviorToI crProc = \case
Valentin Reis's avatar
Valentin Reis committed
133
  DontRun                        -> Nothing
134 135
  JustRun stdOut stdErr                -> Just $ Instrumentation crProc stdOut stdErr Nothing
  SucceedTestOnMessage t stdOut stdErr -> Just $ Instrumentation crProc stdOut stdErr (Just t)