mudbath (empty) → 0.0.2

raw patch · 4 files changed

+197/−0 lines, 4 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cryptohash, directory, github-types, http-conduit, http-types, process, random, snap-core, snap-server, stm, text, transformers

Files

Main.hs +131/−0
Setup.hs +2/−0
UNLICENSE +24/−0
mudbath.cabal +40/−0

+ Main.hs view

@@ -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 ()

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ UNLICENSE view

@@ -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 <http://unlicense.org/>

+ mudbath.cabal view

@@ -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