mudbath 0.0.2 → 0.0.3
raw patch · 5 files changed
+274/−1 lines, 5 files
Files
- Executor.hs +108/−0
- GitHub.hs +39/−0
- Http.hs +30/−0
- Notifications.hs +90/−0
- mudbath.cabal +7/−1
+ Executor.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}++module Executor+ ( executeDeploymentScript+ ) where+++import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import Data.Monoid++import Control.Applicative+import Control.Arrow++import System.Directory+import System.Exit+import System.Process (CreateProcess, createProcess, proc, waitForProcess)+import System.Random++import GitHub+import GitHub.Types+++executeDeploymentScript :: DeploymentEvent -> IO ()+executeDeploymentScript ev = do+ updateDeploymentStatus ev Pending++ tmp <- buildDirectory+ deploy ev tmp+++randomString :: RandomGen d => Int -> d -> (String, d)+randomString len =+ first (Data.List.map toChar) . sequence' (Data.List.replicate len (randomR (0, 61)))+ where+ sequence' [] g = ([], g)+ sequence' (f:fs) g =+ let (f', g') = f g+ (fs', g'') = sequence' fs g'+ in (f' : fs', g'')+ toChar i+ | i < 26 = toEnum $ i + fromEnum 'A'+ | i < 52 = toEnum $ i + fromEnum 'a' - 26+ | otherwise = toEnum $ i + fromEnum '0' - 52+++generateRandomString :: IO Text+generateRandomString = do+ stdgen <- newStdGen+ return $ T.pack $ fst $ randomString 20 stdgen+++buildDirectory :: IO Text+buildDirectory = mappend "/tmp/mudbath/build/" <$> generateRandomString++++setupScript :: Text -> Text -> Text -> Text -> String+setupScript cachePath buildPath url commit = T.unpack $ mconcat $ Data.List.intersperse ";"+ [ "set -e"+ , "if test -d " <> cachePath+ , "then cd " <> cachePath <> " && git fetch --all --quiet"+ , "else git clone --mirror --quiet " <> url <> " " <> cachePath+ , "fi"+ , "rm -rf " <> buildPath+ , "git clone --quiet --reference " <> cachePath <> " " <> url <> " " <> buildPath+ , "cd " <> buildPath+ , "git checkout -q " <> commit+ ]++spawn :: CreateProcess -> IO ExitCode+spawn x = do+ (_, _, _, p) <- createProcess x+ waitForProcess p+++deploy :: DeploymentEvent -> Text -> IO ()+deploy de tmp = do+ clone >>= test >>= updateDeploymentStatus de >> cleanup++ where+ d = deploymentEventDeployment de+ sha = deploymentSha d+ repo = deploymentEventRepository de+ dEnv = deploymentEnvironment d+ repoName = repositoryFullName repo++ clone = do+ let cachePath = "/tmp/mudbath/cache/" <> repoName+ let url = "git@github.com:" <> repoName <> ".git"+ exitCode <- spawn $ proc "sh" [ "-c", setupScript cachePath tmp url sha ]+ print $ "clone " ++ show exitCode+ case exitCode of+ ExitSuccess -> return Success+ _ -> return Error++ test Error = return Error+ test _ = do+ let script = "./config/" <> repoName <> "/" <> dEnv+ print $ show $ "executing " <> script+ exitCode <- spawn $ proc (T.unpack script) [T.unpack tmp]+ print $ "test " ++ show exitCode+ case exitCode of+ ExitSuccess -> return Success+ _ -> return Failure++ cleanup = removeDirectoryRecursive $ T.unpack tmp
+ GitHub.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module GitHub+ ( updateDeploymentStatus+ ) where+++import qualified Control.Exception.Base as CE++import Data.Monoid+import qualified Data.Text as T++import System.Environment (getEnv)++import GitHub.Types+import Http++++getEnvVar :: String -> IO (Either IOError String)+getEnvVar = CE.try . getEnv+++-- | Update the deployment status on GitHub. This requires an access token,+-- which is read from the environment.+updateDeploymentStatus :: DeploymentEvent -> State -> IO ()+updateDeploymentStatus de state =+ getEnvVar "GITHUB_ACCESS_TOKEN" >>= either (\_ -> return ()) sendRequest++ where+ dId = T.pack $ show $ deploymentId $ deploymentEventDeployment de+ repo = deploymentEventRepository de+ repoName = repositoryFullName repo+ url = "https://api.github.com/repos/" <> repoName <> "/deployments/" <> dId <> "/statuses"+++ sendRequest token = do+ httpPOST url (T.pack token) $+ CreateDeploymentStatusRequest state Nothing Nothing
+ Http.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Http+ ( httpPOST+ ) where+++import Control.Monad++import Data.Aeson+import Data.Text+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString as BS++import Network.HTTP.Conduit (RequestBody(..), Request(requestBody,requestHeaders,method), httpLbs, parseUrl, withManager, applyBasicAuth)+import Network.HTTP.Types.Method (methodPost)++++httpPOST :: (ToJSON a) => Text -> Text -> a -> IO ()+httpPOST url token obj = do+ req0 <- parseUrl (T.unpack url)+ void $ withManager $ httpLbs (req1 req0)+ where+ body = RequestBodyLBS $ encode obj+ userAgent = ("User-Agent", BS.concat [ "mudbath/0" ])+ contentType = ("Content-Type","application/json")+ acceptHeader = ("Accept", "application/vnd.github.cannonball-preview+json")+ req1 = \req -> applyBasicAuth (C.pack $ T.unpack token) "x-oauth-basic" $ req { Network.HTTP.Conduit.method = methodPost, requestBody = body, requestHeaders = userAgent : contentType : acceptHeader : requestHeaders req }
+ Notifications.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+++module Notifications+ ( notifyDeploymentStatusChange+ ) where+++import Control.Monad+import Control.Monad.Trans.Except+import qualified Control.Exception.Base as CE++import Data.Aeson+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T++import System.Environment (getEnv)++import Network.HTTP.Conduit (RequestBody(..), Request(requestBody,requestHeaders,method), httpLbs, parseUrl, withManager)+import Network.HTTP.Types.Method (methodPost)++import GitHub.Types++++-- | Send notification about the deployment status change to all configured+-- targets.+--+-- Configuration is done through environment variables. Currently supported+-- are:+--+-- * slack: SLACK_TEAM, SLACK_TOKEN++notifyDeploymentStatusChange :: DeploymentStatusEvent -> IO ()+notifyDeploymentStatusChange ev = do+ notifySlack ev++++getEnvVar :: String -> IO (Either IOError String)+getEnvVar = CE.try . getEnv++++------------------------------------------------------------------------------+-- Slack++data SlackMessage = SlackMessage { smText :: Text }++instance ToJSON SlackMessage where+ toJSON SlackMessage{..} = object [ "text" .= smText ]+++notifySlack :: DeploymentStatusEvent -> IO ()+notifySlack ev = do+ mbConfig <- runExceptT $ do+ team <- ExceptT $ getEnvVar "SLACK_TEAM"+ token <- ExceptT $ getEnvVar "SLACK_TOKEN"+ ExceptT $ return $ Right (team, token)++ case mbConfig of+ Left _ -> return ()+ Right (team, token) -> sendRequest team token++ where+ ds = deploymentStatusEventDeploymentStatus ev+ state = deploymentStatusState ds+ deployment = deploymentStatusEventDeployment ev+ repo = deploymentStatusEventRepository ev++ repoOwner = repositoryOwner repo+ repoName = repositoryFullName repo++ userName = ownerLogin repoOwner++ env = deploymentEnvironment deployment++ sendRequest team token = do+ req <- parseUrl $ "https://" <> team <> ".slack.com/services/hooks/incoming-webhook?token=" <> token++ let msg = userName <> " is deploying " <> repoName <> " to " <> env+ let text = msg <> ": " <> T.pack (show state)++ let body = RequestBodyLBS $ encode $ SlackMessage text+ let contentType = ("Content-Type","application/json")+ let req' = req { Network.HTTP.Conduit.method = methodPost, requestBody = body, requestHeaders = contentType : requestHeaders req }++ void $ withManager $ httpLbs req'
mudbath.cabal view
@@ -1,5 +1,5 @@ name: mudbath-version: 0.0.2+version: 0.0.3 license: OtherLicense license-file: UNLICENSE author: Tomas Carnecky@@ -20,6 +20,12 @@ Executable mudbath Main-Is: Main.hs++ Other-Modules:+ Executor,+ GitHub,+ Http,+ Notifications Build-Depends: aeson Build-Depends: base >= 4.0 && < 5