sync-git.hs

readme.md

# create ~/.config/sync-git/config.dhall
~/dev/gists/sync-git.hs

config.dhall

let GitRepo =
      { Type = { repoPath : Text, name : Text, commands : List Text }
      , default.commands =
        [ "git pull", "git push origin master", "git fetch -pa" ]
      }

let Config =
      { Type = { concurrency : Natural, repos : List GitRepo.Type }
      , default = { concurrency = 7, repos = [] : List GitRepo.Type }
      }

in  Config::{
    , concurrency = 7
    , repos = [ { repoPath = "/home/user/repo", name = "some repo" } ]
    }

sync-git.hs

#!/usr/bin/env stack
{-
  stack --resolver lts-16.9 script
    --package turtle
    --package foldl
    --package dhall
    --package text
    --package async
    --package validation
    --package process
-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where


import           Control.Concurrent.Async (Concurrently (..))
import           Control.Concurrent.QSem  (QSem, newQSem, signalQSem, waitQSem)
import           Control.Exception        (bracket_)
import           Control.Monad            (void)
import           Data.Foldable            (forM_, sequenceA_)
import qualified Data.Text                as T
import qualified Data.Text.IO             as TIO
import           Data.Validation          (Validation (..))
import           Dhall                    (FromDhall (..), Generic, Natural,
                                           auto, input)
import qualified System.Process           as P
import           Text.Printf              (printf)
import           Turtle                   (ExitCode (..), MonadIO, Text, cd,
                                           empty, fromString, liftIO,
                                           systemStrictWithErr)

data Config = MkConfig { repos       :: [GitRepo]
                       , concurrency :: Natural
                       }
  deriving (Generic)

data GitRepo = MkRepo { repoPath :: FilePath
                      , name     :: Text
                      , commands :: [Text]
                      }
  deriving (Generic)

instance FromDhall GitRepo
instance FromDhall Config

executeIn :: MonadIO m => Text -> FilePath -> m (Validation [(ExitCode, Text, Text)] ())
executeIn cmd' path = do
  let cmd = P.shell . concat $ ["cd ", path, " && ", T.unpack cmd']
  ret@(!ec, !_out, !_err) <- systemStrictWithErr cmd empty
  if ec == ExitSuccess
    then pure (Success ())
    else pure (Failure [ret])

sync :: MonadIO m => GitRepo -> m ()
sync MkRepo{repoPath, name, commands} = do
  results <- traverse (`executeIn` repoPath) commands
  case sequenceA_ results of
    Success () -> liftIO $ printf "**** %s : OK *****\n" name
    Failure problems -> liftIO $ do
      printf "**** %s : ERRO *****\n" name
      forM_ problems $ \(ec, o, e) -> do
        print ec
        TIO.putStrLn e
        TIO.putStrLn o

withConc :: QSem -> (a -> IO b) -> a -> Concurrently b
withConc sem f x =
  Concurrently (bracket_ (waitQSem sem) (signalQSem sem) (f x))

forConc_ :: Traversable t => Natural -> (a -> IO b) -> t a -> IO ()
forConc_ concurrency f xs = do
  sem <- newQSem . fromIntegral $ concurrency
  void $ runConcurrently $ traverse (withConc sem f) xs

main :: IO ()
main = do
  MkConfig{repos, concurrency} <- input auto "~/.config/sync-git/config.dhall"
  forConc_ concurrency sync repos