diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Snap.Core +import Snap.Http.Server + +import Crypto.Hash + +import Data.Monoid +import Data.Aeson hiding (Success, Error) +import Data.Aeson.Types (parseMaybe) +import Data.Text.Encoding +import Data.Maybe +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as BC8 + +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception + +import System.Environment + +import GitHub.Types +import Executor +import Notifications + + + +main :: IO () +main = do + + hookPath <- fromMaybe "webhook" <$> lookupEnv "HOOKPATH" + mbSecretKey <- lookupEnv "SECRET_TOKEN" + queue <- newTQueueIO + + -- Fork the background build thead, Ignore all exceptions, because IO is + -- dirty and can throw exceptions at any time. And we don't actually care + -- about those, all we want is to keep the thread running. At any cost. + + void $ forkIO $ forever $ + backgroundBuildThread queue `catch` ignoreException + + quickHttpServe $ + path (BC8.pack hookPath) (method POST $ hook queue mbSecretKey) <|> writeText "ok\n" + + where + + backgroundBuildThread queue = do + de <- atomically $ readTQueue queue + processEvent de + + + ignoreException :: SomeException -> IO () + ignoreException e = do + putStrLn $ "ignoreException: " ++ show e + + + +-- | The handler of the webhook. It parses the request body as an GitHub event +-- and processes it. +-- +-- Some events are processed immediately, others are put into the queuer to +-- process them in the background thread. +hook :: TQueue Event -> Maybe String -> Snap () +hook queue mbSecretKey = do + hdrs <- headers <$> getRequest + + body <- do + body <- readRequestBody (100 * 1000) + case (mbSecretKey, getHeader "X-Hub-Signature" hdrs) of + + -- No secret key and no signature. Pass along the body unverified. + (Nothing, Nothing) -> return body + + -- Signature is available but no secret key to verify it. Log this + -- and accept the body. + (Nothing, Just _) -> do + liftIO $ putStrLn $ + "Ignoring signature because the secret token was not provided" + return body + + -- Secret token is available but the request is not signed. Reject + -- the request. + (Just _, Nothing) -> do + writeText "Signature missing" + res <- getResponse + finishWith $ setResponseCode 400 res + + -- Both the signature and secret token are available. Verify the + -- signature and reject the request if that fails. + (Just sc, Just sig) -> do + let mac = hmac (BC8.pack sc) (LBS.toStrict body) :: HMAC SHA1 + if sig == ("sha1=" <> digestToHexByteString (hmacGetDigest mac)) + then return body + else do + liftIO $ do + putStrLn "Signature does not match:" + print $ show sig + print $ digestToHexByteString $ hmacGetDigest mac + + writeText "Signature does not match" + res <- getResponse + finishWith $ setResponseCode 400 res + + + let mbEvent = do + eventName <- getHeader "X-GitHub-Event" hdrs + value <- decode body + parseMaybe (eventParser $ decodeUtf8 eventName) value + + case mbEvent of + Nothing -> return () + Just ev -> void $ liftIO $ case ev of + (DeploymentEventType _) -> atomically $ writeTQueue queue ev + _ -> processEvent ev + + + +processEvent :: Event -> IO () +processEvent (DeploymentEventType de) = + executeDeploymentScript de + +processEvent (DeploymentStatusEventType dse) = + notifyDeploymentStatusChange dse + +processEvent _ = + return () diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/mudbath.cabal b/mudbath.cabal new file mode 100644 --- /dev/null +++ b/mudbath.cabal @@ -0,0 +1,40 @@ +name: mudbath +version: 0.0.2 +license: OtherLicense +license-file: UNLICENSE +author: Tomas Carnecky +maintainer: tomas.carnecky@gmail.com +category: Testing +build-type: Simple +cabal-version: >=1.8 + +synopsis: Continuous deployment server for use with GitHub +description: + Mudbath is continuous deployment server which integrates with GitHub. It + listens for deployment events and when it receives one, executes a shell + script. It reports progress back to GitHub in the form of deployment + status updates. + + Mudbath can also send notifications to Slack if the proper keys are + provided. Other notification sinks can be easily added if needed. + +Executable mudbath + Main-Is: Main.hs + + Build-Depends: aeson + Build-Depends: base >= 4.0 && < 5 + Build-Depends: bytestring + Build-Depends: directory + Build-Depends: github-types == 0.1.0.5 + Build-Depends: http-conduit + Build-Depends: http-types + Build-Depends: process + Build-Depends: random + Build-Depends: snap-core + Build-Depends: snap-server + Build-Depends: stm + Build-Depends: text + Build-Depends: transformers >= 0.4 + Build-Depends: cryptohash + + Ghc-Options: -threaded -Wall