diff --git a/Executor.hs b/Executor.hs new file mode 100644 --- /dev/null +++ b/Executor.hs @@ -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 diff --git a/GitHub.hs b/GitHub.hs new file mode 100644 --- /dev/null +++ b/GitHub.hs @@ -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 diff --git a/Http.hs b/Http.hs new file mode 100644 --- /dev/null +++ b/Http.hs @@ -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 } diff --git a/Notifications.hs b/Notifications.hs new file mode 100644 --- /dev/null +++ b/Notifications.hs @@ -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' diff --git a/mudbath.cabal b/mudbath.cabal --- a/mudbath.cabal +++ b/mudbath.cabal @@ -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