├── Setup.hs ├── .gitignore ├── System └── Warp │ ├── Config.hs │ ├── Args.hs │ ├── Match.hs │ ├── Signature.hs │ ├── Facts.hs │ ├── Types.hs │ ├── Executor.hs │ ├── Agent.hs │ └── Payload.hs ├── LICENSE ├── warp.cabal └── warp.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox 2 | /cabal.sandbox.config 3 | /dist 4 | -------------------------------------------------------------------------------- /System/Warp/Config.hs: -------------------------------------------------------------------------------- 1 | module System.Warp.Config where 2 | import System.Warp.Types 3 | import System.Warp.Payload 4 | import System.FilePath.Posix 5 | import qualified Data.ByteString.Lazy as BL 6 | import qualified Data.Aeson as A 7 | 8 | makeAbsolutePaths :: (Monad m) => FilePath -> (m WarpConfig) -> (m WarpConfig) 9 | makeAbsolutePaths from config = do 10 | cfg <- config 11 | return $ cfg { cacert = takeDirectory from cacert cfg 12 | , privkey = takeDirectory from privkey cfg } 13 | 14 | configure :: String -> IO (Either String WarpConfig) 15 | configure path = do 16 | content <- BL.readFile path 17 | return $ makeAbsolutePaths path $ A.eitherDecode content 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2014 Pierre-Yves Ritschard 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /System/Warp/Args.hs: -------------------------------------------------------------------------------- 1 | module System.Warp.Args where 2 | import System.Warp.Types 3 | import Options.Applicative 4 | import Options.Applicative.Arrows 5 | 6 | parseArgs :: Parser WarpArguments 7 | parseArgs = WarpArguments 8 | <$> strOption 9 | ( long "config" 10 | <> short 'f' 11 | <> metavar "FILE" 12 | <> help "Configuration file" 13 | <> value "/etc/warp-agent.conf" ) 14 | <*> flag Normal Verbose 15 | ( long "verbose" 16 | <> short 'v' 17 | <> help "Display more messages" ) 18 | <*> (optional $ strOption 19 | ( long "logfile" 20 | <> short 'l' 21 | <> metavar "FILE" 22 | <> help "Log to file FILE" )) 23 | -------------------------------------------------------------------------------- /System/Warp/Match.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module System.Warp.Match where 3 | import System.Warp.Types 4 | import System.Process 5 | import Data.List(intersperse, isInfixOf, find, null) 6 | import qualified Data.Map as M 7 | 8 | runMatch :: String -> Facts -> Matcher -> Bool 9 | 10 | runMatch _ _ MatchAll = True 11 | 12 | runMatch _ _ MatchNone = True 13 | 14 | runMatch host _ (MatchHost candidate) = (host == candidate) 15 | 16 | runMatch _ facts (MatchFact key val) = case M.lookup key facts of 17 | Nothing -> False 18 | Just myfact -> (myfact == val) 19 | 20 | runMatch host facts (MatchNot matcher) = not $ runMatch host facts matcher 21 | 22 | runMatch host facts (MatchOr matchers) = 23 | case find (runMatch host facts) matchers of 24 | Nothing -> False 25 | Just _ -> True 26 | 27 | runMatch host facts (MatchAnd matchers) = 28 | null $ [ x | x <- matchers, not $ runMatch host facts x] 29 | -------------------------------------------------------------------------------- /System/Warp/Signature.hs: -------------------------------------------------------------------------------- 1 | module System.Warp.Signature where 2 | import Network.TLS.Extra 3 | import Network.TLS 4 | import Codec.Crypto.RSA 5 | import Data.Certificate.X509 6 | import qualified Codec.Binary.Base64.String as B64 7 | import qualified Data.ByteString.Lazy.Char8 as BL 8 | 9 | sign_payload :: String -> String -> IO (String) 10 | sign_payload keypath str = do 11 | (PrivRSA key) <- fileReadPrivateKey keypath 12 | let payload = BL.pack str 13 | let signed = sign key payload 14 | let b64 = concat $ lines $ B64.encode $ BL.unpack signed 15 | return b64 16 | 17 | verify_payload :: String -> String -> String -> IO (Bool) 18 | verify_payload certpath str sig = do 19 | (X509 {x509Cert = cert}) <- fileReadCertificate certpath 20 | let (Certificate {certPubKey = pubkey}) = cert 21 | let (PubKeyRSA pubrsa) = pubkey 22 | let valid = verify pubrsa (BL.pack str) (BL.pack $ B64.decode sig) 23 | return valid 24 | -------------------------------------------------------------------------------- /System/Warp/Facts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module System.Warp.Facts(fetchFacts, startFactThread) where 3 | import System.Warp.Types 4 | import System.Process 5 | import Control.Monad(forever) 6 | import Control.Concurrent.MVar 7 | import Control.Concurrent(forkIO, threadDelay) 8 | import Data.List(intersperse, isInfixOf) 9 | import Data.Map(fromList) 10 | import System.Log.Logger(infoM,debugM) 11 | 12 | toFact (fname:(_:fdata)) = (fname,(concat $ intersperse " " fdata)) 13 | 14 | fetchFacts :: IO (Facts) 15 | fetchFacts = do 16 | output <- readProcess "facter" [] [] 17 | let facts = [toFact (words l) | l <- lines output, isInfixOf "=>" l] 18 | debugM "Warp.Facts" $ "Got " ++ show (length facts) ++ " facts" 19 | return (fromList facts) 20 | 21 | startFactThread :: IO (MVar Facts) 22 | startFactThread = do 23 | box <- newEmptyMVar 24 | debugM "Warp.Facts" "Retrieve initial facts" 25 | facts <- fetchFacts 26 | putMVar box facts 27 | infoM "Warp.Facts" "Starting facter thread" 28 | forkIO $ forever $ do 29 | threadDelay (60 * 1000000) 30 | facts <- fetchFacts 31 | -- try to reduce the locking window to a minimum 32 | _ <- takeMVar box 33 | putMVar box facts 34 | return box 35 | -------------------------------------------------------------------------------- /warp.cabal: -------------------------------------------------------------------------------- 1 | name: warp 2 | version: 0.5.0 3 | synopsis: distributed command and control 4 | -- description: 5 | homepage: https://github.com/pyr/warp-agent 6 | license: MIT 7 | license-file: LICENSE 8 | author: Pierre-Yves Ritschard 9 | maintainer: pyr@spootnik.org 10 | -- copyright: 11 | category: System 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | executable warp-agent 17 | ghc-options: -threaded 18 | main-is: warp.hs 19 | -- other-modules: 20 | -- other-extensions: 21 | build-depends: base >=4.6, hedis >= 0.6.5, aeson >= 0.6.1.0, 22 | bytestring >= 0.10.0.2, unordered-containers >= 0.2.3.3, 23 | hashmap >= 1.3.0.1, text >= 0.11.2.3, 24 | process >= 1.1.0.2, containers >= 0.5.0.0, 25 | stm >= 2.4.2, hostname >= 1.0, 26 | unix >= 2.4.0.1, base64-string >= 0.2, 27 | RSA >= 1.0.6.2, tls-extra >= 0.6.4, tls >= 1.1.5, 28 | certificate >= 1.2.1, split >= 0.1.1, 29 | filepath >= 1.3, optparse-applicative >= 0.10, 30 | hslogger >= 1.2 31 | 32 | -- hs-source-dirs: 33 | default-language: Haskell2010 34 | -------------------------------------------------------------------------------- /System/Warp/Types.hs: -------------------------------------------------------------------------------- 1 | module System.Warp.Types where 2 | import Data.Map(Map) 3 | 4 | type Facts = Map String String 5 | 6 | type GenId = String 7 | 8 | data ServiceAction = ServiceStop | 9 | ServiceStart | 10 | ServiceRestart | 11 | ServiceReload | 12 | ServiceStatus deriving (Show, Read) 13 | 14 | data Command = PingCommand | 15 | SleepCommand Integer | 16 | ShCommand String String [Int] | 17 | ServiceCommand ServiceAction String deriving (Show, Read) 18 | 19 | data Script = Script String [Command] 20 | 21 | data Matcher = MatchAll | 22 | MatchNone | 23 | MatchHost String | 24 | MatchFact String String | 25 | MatchNot Matcher | 26 | MatchOr [Matcher] | 27 | MatchAnd [Matcher] deriving (Show, Read) 28 | 29 | data CommandOutput = CommandSuccess Int String String 30 | | CommandFailure Int String String 31 | | CommandFinished deriving (Show, Read) 32 | 33 | data Request = Request { rq_id :: GenId 34 | , rq_match :: Matcher 35 | , rq_timeout :: Integer 36 | , rq_scriptname :: String 37 | , rq_script :: [Command] 38 | } deriving (Show, Read) 39 | 40 | data Response = Response { res_id :: GenId 41 | , res_host :: String 42 | , res_output :: CommandOutput 43 | } deriving (Show, Read) 44 | 45 | data AckStatus = AckStart | 46 | AckRefused deriving (Show, Read) 47 | 48 | data Ack = Ack { ack_id :: GenId 49 | , ack_host :: String 50 | , ack_status :: AckStatus 51 | } deriving (Show, Read) 52 | 53 | data WarpConfig = WarpConfig { cacert :: String 54 | , privkey :: String 55 | , redis_host :: String 56 | , redis_port :: Integer 57 | } deriving (Show, Read) 58 | 59 | data Verbosity = Normal | Verbose deriving (Show, Read) 60 | data WarpArguments = WarpArguments { config :: FilePath 61 | , verbosity :: Verbosity 62 | , logfile :: Maybe FilePath 63 | } deriving (Show, Read) 64 | -------------------------------------------------------------------------------- /warp.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import System.Warp.Agent 3 | import System.Warp.Facts 4 | import System.Warp.Config 5 | import System.Warp.Args 6 | import System.Warp.Types 7 | import Network.HostName 8 | import System.Environment 9 | import Options.Applicative 10 | import Data.List(break) 11 | import Control.Concurrent.MVar (takeMVar, putMVar) 12 | import qualified Data.Map as M 13 | 14 | import System.IO (stderr) 15 | import System.Log.Logger (updateGlobalLogger, rootLoggerName, 16 | addHandler, removeHandler, 17 | setLevel, traplogging, 18 | infoM, 19 | Priority(DEBUG, INFO, ERROR)) 20 | import System.Log.Handler (setFormatter) 21 | import System.Log.Handler.Simple (fileHandler, streamHandler) 22 | import System.Log.Formatter (simpleLogFormatter) 23 | 24 | opts :: ParserInfo WarpArguments 25 | opts = info (parseArgs <**> helper) 26 | ( fullDesc 27 | <> progDesc "Execute a worker agent for warp" 28 | <> header "warp-agent" ) 29 | 30 | -- Logging configuration 31 | configureLogging :: WarpArguments -> IO () 32 | configureLogging cfg = do 33 | h <- streamHandler stderr DEBUG >>= 34 | \lh -> return $ setFormatter lh (simpleLogFormatter "$time $loggername [$prio] $msg") 35 | updateGlobalLogger rootLoggerName removeHandler 36 | updateGlobalLogger rootLoggerName $ addHandler h 37 | configureLoggingVerbosity $ verbosity cfg 38 | configureLoggingTarget $ logfile cfg 39 | 40 | configureLoggingVerbosity :: Verbosity -> IO () 41 | configureLoggingVerbosity Normal = 42 | updateGlobalLogger rootLoggerName $ setLevel INFO 43 | configureLoggingVerbosity Verbose = 44 | updateGlobalLogger rootLoggerName $ setLevel DEBUG 45 | 46 | configureLoggingTarget :: (Maybe FilePath) -> IO () 47 | configureLoggingTarget Nothing = return () 48 | configureLoggingTarget (Just target) = do 49 | h <- fileHandler target INFO >>= 50 | \lh -> return $ setFormatter lh (simpleLogFormatter "$time $loggername [$prio] $msg") 51 | updateGlobalLogger rootLoggerName $ addHandler h 52 | 53 | -- Main 54 | main :: IO () 55 | main = do 56 | args <- execParser opts 57 | configureLogging args 58 | cfg <- configure $ config args 59 | case cfg of 60 | Left err -> error $ "Unable to parse configuration: " ++ err 61 | Right conf -> do 62 | let (WarpConfig { cacert = cacert 63 | , privkey = privkey 64 | , redis_host = redis_host 65 | , redis_port = redis_port}) = conf 66 | 67 | traplogging "Warp.main" ERROR "A fatal exception occurred" $ do 68 | factbox <- startFactThread 69 | facts <- takeMVar factbox 70 | hostname <- return $ M.lookup "fqdn" facts 71 | putMVar factbox facts 72 | case hostname of 73 | Nothing -> error $ "Unable to get FQDN from facts" 74 | Just fqdn -> do 75 | infoM "Warp.main" $ "My hostname is " ++ fqdn 76 | redis_listen factbox fqdn redis_host redis_port cacert privkey 77 | -------------------------------------------------------------------------------- /System/Warp/Executor.hs: -------------------------------------------------------------------------------- 1 | module System.Warp.Executor (runScript) where 2 | import System.Warp.Types 3 | import System.Warp.Payload 4 | import System.Process 5 | import System.IO 6 | import System.Posix.IO 7 | import System.Exit 8 | import System.Posix.Directory 9 | import Control.Concurrent 10 | import Data.List(elem) 11 | import qualified Control.Exception as C 12 | 13 | serviceAction :: ServiceAction -> String 14 | serviceAction ServiceStop = "stop" 15 | serviceAction ServiceStart = "start" 16 | serviceAction ServiceRestart = "restart" 17 | serviceAction ServiceStatus = "status" 18 | serviceAction ServiceReload = "reload" 19 | 20 | readProcessMixedWithExitCode 21 | :: FilePath -- ^ command to run 22 | -> [String] -- ^ any arguments 23 | -> IO (ExitCode,String) -- ^ exitcode, stdout, stderr 24 | readProcessMixedWithExitCode cmd args = do 25 | (p_r, p_w) <- createPipe 26 | h_r <- fdToHandle p_r 27 | h_w <- fdToHandle p_w 28 | (Just inh, _, _, pid) <- createProcess (proc cmd args) { 29 | std_in = CreatePipe, 30 | std_out = UseHandle h_w, 31 | std_err = UseHandle h_w } 32 | outMVar <- newEmptyMVar 33 | 34 | -- fork off a thread to start consuming stdout 35 | out <- hGetContents h_r 36 | _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar () 37 | 38 | -- now write and flush any input 39 | hClose inh -- done with stdin 40 | 41 | -- wait on the output 42 | takeMVar outMVar 43 | hClose h_r 44 | 45 | -- wait on the process 46 | ex <- waitForProcess pid 47 | 48 | return (ex, out) 49 | 50 | runRequestCommand :: Command -> IO (CommandOutput) 51 | 52 | runRequestCommand PingCommand = do 53 | return (CommandSuccess 0 "alive" "") 54 | 55 | runRequestCommand (SleepCommand amount) = do 56 | threadDelay (fromIntegral (amount * 1000000) :: Int) 57 | return (CommandSuccess 0 "slept well" "") 58 | 59 | runRequestCommand (ShCommand script cwd exits) = do 60 | current_wd <- getWorkingDirectory 61 | if cwd /= "." then 62 | changeWorkingDirectory cwd 63 | else 64 | do {return () } 65 | (exit,out) <- readProcessMixedWithExitCode "bash" ["-c", script] 66 | if cwd /= "." then 67 | changeWorkingDirectory current_wd 68 | else 69 | do {return ()} 70 | case exit of 71 | ExitSuccess -> return (CommandSuccess 0 out "") 72 | (ExitFailure code) -> if (elem code exits) then 73 | return (CommandSuccess code out "") 74 | else 75 | return (CommandFailure code out "") 76 | 77 | 78 | runRequestCommand (ServiceCommand action service) = do 79 | (exit, out, err) <- readProcessWithExitCode "service" 80 | [service, serviceAction action] [] 81 | case exit of 82 | ExitSuccess -> return (CommandSuccess 0 out err) 83 | (ExitFailure code) -> return (CommandFailure code out err) 84 | 85 | 86 | runNext :: CommandOutput -> (CommandOutput -> IO ()) -> [Command] -> IO () 87 | 88 | runNext (CommandSuccess code out err) reporter commands = do 89 | reporter (CommandSuccess code out err) 90 | runScript commands reporter 91 | return () 92 | 93 | runNext (CommandFailure code out err) reporter commands = do 94 | reporter (CommandFailure code out err) 95 | 96 | runScript :: [Command] -> (CommandOutput -> IO ()) -> IO () 97 | 98 | runScript [] reporter = do 99 | reporter CommandFinished 100 | 101 | runScript (cmd:commands) reporter = do 102 | output <- runRequestCommand cmd 103 | runNext output reporter commands 104 | -------------------------------------------------------------------------------- /System/Warp/Agent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module System.Warp.Agent where 3 | import System.Warp.Types 4 | import System.Warp.Payload 5 | import System.Warp.Match 6 | import System.Warp.Facts 7 | import System.Warp.Executor 8 | import System.Warp.Signature 9 | import Database.Redis 10 | import Data.List.Split (splitOn) 11 | import Data.Monoid (mempty) 12 | import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) 13 | import qualified Data.ByteString as B 14 | import qualified Data.ByteString.Char8 as BC 15 | import qualified Data.ByteString.Lazy as BL 16 | import qualified Data.Aeson as A 17 | import qualified Data.Map as M 18 | import System.Log.Logger (infoM, debugM, warningM) 19 | 20 | redis_publish conn rid host privkey output = do 21 | debugM "Warp.Agent" $ "Request " ++ (show rid) ++ 22 | case output of 23 | CommandFinished -> " is finished" 24 | CommandSuccess _ _ _ -> " was successfully executed" 25 | CommandFailure e _ _ -> " has failed (" ++ (show e) ++ ")" 26 | let resp = Response { res_id = rid 27 | , res_host = host 28 | , res_output = output} 29 | let resdata = B.concat $ BL.toChunks $ A.encode resp 30 | sig <- sign_payload privkey $ BC.unpack resdata 31 | runRedis conn $ publish (BC.pack $ ("warp:res:" ++ rid ++ ":" ++ sig)) resdata 32 | return () 33 | 34 | redis_ack conn rid privkey payload = do 35 | let jdata = B.concat $ BL.toChunks $ A.encode payload 36 | sig <- sign_payload privkey $ BC.unpack jdata 37 | let chan = "warp:ack:" ++ (rid :: String) ++ sig 38 | runRedis conn $ publish (BC.pack chan) jdata 39 | return mempty 40 | 41 | redis_run_request conn host privkey req = do 42 | let Request { rq_id = rid, rq_script = script } = req 43 | let ack_payload = Ack { ack_id = rid 44 | , ack_host = host 45 | , ack_status = AckStart } 46 | let jdata = B.concat $ BL.toChunks $ A.encode ack_payload 47 | sig <- sign_payload privkey $ BC.unpack jdata 48 | runRedis conn $ publish (BC.pack $ ("warp:ack:" ++ rid ++ ":" ++ sig)) jdata 49 | runScript script (redis_publish conn rid host privkey) 50 | return mempty 51 | 52 | 53 | redis_match_request conn host box req privkey = do 54 | debugM "Warp.Agent" $ "Check if request " ++ (show req) ++ " should be executed" 55 | let Request { rq_match = matcher, rq_id = rid } = req 56 | facts <- takeMVar box 57 | let valid_req = runMatch host facts matcher 58 | putMVar box facts 59 | if valid_req then do 60 | debugM "Warp.Agent" $ "Execute request ID " ++ (show rid) 61 | redis_run_request conn host privkey req 62 | else do 63 | debugM "Warp.Agent" $ "Request ID " ++ (show rid) ++ " is not for me" 64 | redis_ack conn rid privkey (Ack { ack_id = rid 65 | , ack_host = host 66 | , ack_status = AckRefused}) 67 | 68 | 69 | redis_msg conn host box cacert privkey payload = do 70 | let chan = msgChannel payload 71 | debugM "Warp.Agent" $ "Got new message on channel: " ++ (BC.unpack chan) 72 | let sig = last $ splitOn ":" $ BC.unpack chan 73 | valid <- verify_payload cacert (BC.unpack $ msgMessage payload) sig 74 | case valid of 75 | True -> do 76 | debugM "Warp.Agent" $ "Signature is valid" 77 | let to_decode = BL.fromChunks [(msgMessage payload)] 78 | let msg = (A.decode $ to_decode) :: Maybe Request 79 | case msg of 80 | Nothing -> do 81 | warningM "Warp.Agent" $ "Invalid JSON message received: " ++ (show to_decode) 82 | return () 83 | Just req -> redis_match_request conn host box req privkey 84 | return () 85 | False -> do 86 | warningM "Warp.Agent" $ "Got invalid signature on channel: " ++ (BC.unpack chan) 87 | return mempty 88 | 89 | redis_listen :: MVar Facts -> String -> String -> Integer -> String -> String -> IO () 90 | redis_listen factbox host redis_host redis_portnum cacert privkey = do 91 | let redis_port = (PortNumber (fromIntegral redis_portnum)) 92 | let (ConnInfo _ _ auth db max_conn _) = defaultConnectInfo 93 | let ci = (ConnInfo redis_host redis_port auth db max_conn 600) 94 | infoM "Warp.Agent" $ "Connect to redis host " ++ redis_host ++ ":" ++ (show redis_portnum) 95 | cx <- connect ci 96 | runRedis cx $ pubSub (psubscribe ["warpreq:*"]) (redis_msg cx host factbox cacert privkey) 97 | -------------------------------------------------------------------------------- /System/Warp/Payload.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module System.Warp.Payload where 3 | import Control.Applicative 4 | import Data.Aeson 5 | import System.Warp.Types 6 | import Data.HashMap.Strict (member) 7 | import qualified Data.Text as T 8 | import qualified Data.ByteString.Lazy as B 9 | 10 | instance FromJSON Matcher where 11 | parseJSON (String "all") = pure MatchAll 12 | parseJSON (String "none") = pure MatchNone 13 | parseJSON (Object o) | member "or" o = MatchOr <$> o .: "or" 14 | | member "and" o = MatchAnd <$> o .: "and" 15 | | member "not" o = MatchNot <$> o .: "not" 16 | | member "host" o = MatchHost <$> o .: "host" 17 | | member "fact" o = MatchFact <$> o .: "fact" 18 | <*> o .: "value" 19 | | otherwise = empty 20 | parseJSON _ = fail "invalid matcher" 21 | 22 | instance FromJSON ServiceAction where 23 | parseJSON (String action) = case action of 24 | "start" -> pure ServiceStart 25 | "restart" -> pure ServiceRestart 26 | "stop" -> pure ServiceStop 27 | "status" -> pure ServiceStatus 28 | "reload" -> pure ServiceReload 29 | 30 | instance FromJSON Command where 31 | parseJSON (String "ping") = pure PingCommand 32 | parseJSON (String sh) = pure (ShCommand (T.unpack sh) "." [0]) 33 | parseJSON (Object o) | (member "exits" o && member "cwd" o) = ShCommand <$> o .: "shell" 34 | <*> o .: "cwd" 35 | <*> o .: "exits" 36 | | member "cwd" o = ShCommand <$> o .: "shell" 37 | <*> o .: "cwd" 38 | <*> pure [0] 39 | | member "exits" o = ShCommand <$> o .: "shell" 40 | <*> pure "." 41 | <*> o .: "exits" 42 | | member "shell" o = ShCommand <$> o .: "shell" 43 | <*> pure "." 44 | <*> pure [0] 45 | | member "sleep" o = SleepCommand <$> o .: "sleep" 46 | | member "service" o = ServiceCommand <$> o .: "action" 47 | <*> o .: "service" 48 | | otherwise = empty 49 | 50 | instance FromJSON Request where 51 | parseJSON (Object o) = Request <$> o .: "id" 52 | <*> o .:? "match" .!= MatchAll 53 | <*> o .: "timeout" 54 | <*> o .: "script_name" 55 | <*> o .: "script" 56 | parseJSON _ = fail "Failed to parse request!" 57 | 58 | instance ToJSON CommandOutput where 59 | toJSON (CommandSuccess code out err) = 60 | object [ "status" .= String "success", 61 | "code" .= code, 62 | "stdout" .= out, 63 | "stderr" .= err] 64 | toJSON (CommandFailure code out err) = 65 | object [ "status" .= String "failure", 66 | "code" .= code, 67 | "stdout" .= out, 68 | "stderr" .= err] 69 | toJSON CommandFinished = 70 | object [ "status" .= String "finished" ] 71 | 72 | instance ToJSON Response where 73 | toJSON Response{ res_id = id 74 | , res_host = host 75 | , res_output = output } = 76 | object [ "id" .= id, 77 | "host" .= host, 78 | "output" .= output ] 79 | 80 | instance ToJSON AckStatus where 81 | toJSON AckStart = String "starting" 82 | toJSON AckRefused = String "refused" 83 | 84 | instance ToJSON Ack where 85 | toJSON Ack{ack_id = id, ack_host = host, ack_status = status } = 86 | object [ "id" .= id, "host" .= host, "status" .= status ] 87 | 88 | instance FromJSON WarpConfig where 89 | parseJSON (Object o) = WarpConfig <$> o .: "cacert" 90 | <*> o .: "privkey" 91 | <*> o .:? "redis_host" .!= "localhost" 92 | <*> o .:? "redis_port" .!= 6379 93 | --------------------------------------------------------------------------------