pagure-hook-receiver (empty) → 0.1.0.0

raw patch · 5 files changed

+131/−0 lines, 5 filesdep +basedep +containersdep +scottysetup-changed

Dependencies added: base, containers, scotty, shelly, text, transformers, unix

Files

• LICENSE +26/−0
• Setup.hs +2/−0
• pagure-hook-receiver.cabal +31/−0
• src/Web/Pagure/HookReceiver/Post.hs +32/−0
• src/Web/Pagure/HookReceiver/StandardHooks.hs +40/−0

@@ -0,0 +1,26 @@+Copyright (c) 2015, Ricky Elrod+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -0,0 +1,31 @@+name:                pagure-hook-receiver+version:             0.1.0.0+synopsis:            Receive hooks from pagure and do things with them+-- description:+homepage:            https://pagure.io/pagure-hook-receiver+license:             BSD2+license-file:        LICENSE+author:              Ricky Elrod+maintainer:          relrod@redhat.com+-- copyright:+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  exposed-modules:+      Web.Pagure.HookReceiver.Post+    , Web.Pagure.HookReceiver.StandardHooks+  -- other-modules:+  -- other-extensions:+  build-depends:       base >= 4 && < 5+                     , containers >= 0.5 && < 0.6+                     , scotty >= 0.9 && < 1+                     , shelly >= 1 && < 2+                     , text >= 1 && < 2+                     , transformers >= 0.3 && < 1+                     , unix >= 2.5 && < 2.8+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Web.Pagure.HookReceiver.Post+-- Copyright : (C) 2015 Ricky Elrod+-- License : BSD2 (see LICENSE file)+-- Maintainer : Ricky Elrod <relrod@redhat.com>+-- Stability : experimental+-- Portability : ghc+--+-- The POST hook receiver for Pagure projects.+----------------------------------------------------------------------------+module Web.Pagure.HookReceiver.Post where++import Control.Monad.IO.Class+import qualified Data.Map as M+import qualified Data.Text as T+import Shelly (rm_rf, fromText, shelly)+import Web.Scotty++runPagureListener :: Int -> M.Map String [String -> IO ()] -> IO ()+runPagureListener port projectMapping =+  scotty port $+    post "/:projectname" $ do+      name <- param "projectname"+      case M.lookup name projectMapping of+       Nothing -> text "Project not found."+       Just hooks -> do+         let hooks' = fmap (\f -> f name) hooks+         liftIO (sequence_ hooks')+         shelly $ rm_rf (fromText (T.pack ("clones/" ++ name)))+         text "OK."

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Web.Pagure.HookReceiver.StandardHooks+-- Copyright : (C) 2015 Ricky Elrod+-- License : BSD2 (see LICENSE file)+-- Maintainer : Ricky Elrod <relrod@redhat.com>+-- Stability : experimental+-- Portability : ghc+--+-- Common hooks for pagure updates+----------------------------------------------------------------------------+module Web.Pagure.HookReceiver.StandardHooks where++import Control.Monad.IO.Class+import Data.Monoid+import qualified Data.Text as T+import Shelly (chdir, fromText, mkdir_p, run_, shelly)+import System.Posix.Files++cloneRepo :: MonadIO m => String -> m ()+cloneRepo s = shelly $ do+  mkdir_p "clones"+  run_ "/usr/bin/git" ["clone"+                      ,"https://pagure.io/" <> T.pack s+                      ,"clones/" <> T.pack s+                      ]++-- | Clones the repo if necessary, using 'cloneRepo', then adds a github remote+-- and pushes to it (using @--all@ so that tags and branches get mirrored as+-- well).+githubMirror :: MonadIO m => String -> String -> String -> m ()+githubMirror gh key s = shelly $ do+  cloneRepo s+  liftIO $ do+    writeFile ("clones/" ++ s ++ ".key") key+    setFileMode ("clones/" ++ s ++ ".key") (unionFileModes ownerReadMode ownerWriteMode)+  chdir (fromText . T.pack $ "clones/" ++ s) $ do+    run_ "/usr/bin/git" ["remote", "add", "github", "git@github.com:" <> T.pack gh]+    run_ "/usr/bin/ssh-agent" ["bash", "-c", "ssh-add ../" <> T.pack s <> ".key; git push --all github"]