How to work with directories/ how to work with processes/ how to do things concurrently

[typeclasses]

How to work with directories/ how to work with processes/ how to do things concurrently

[chris-martin]

Yes! This will be a great practical followup to threads.

I wonder if we could introduce a library or two to help condense this into a smaller example. Maybe path and path-io would take care of some of the path manipulation and directory searching?

[friedbrice]

Cool. I'll look into path and path-io and see if i can clean this up.

[friedbrice]

How's this?

List Git repositories:

{-# LANGUAGE QuasiQuotes #-}

module ListRepos (listRepos, paths) where

import Control.Monad (filterM, join)
import Data.Foldable (traverse_)
import Path (Path, Abs, Rel, Dir, reldir, (</>))
import Path.IO (doesDirExist, getHomeDir, listDir)

paths :: [Path Rel Dir]
paths = [ [reldir|abs/aur|]
        , [reldir|friedbrice|]
        , [reldir|lumi-tech|]
        ]

isGitRepo :: Path Abs Dir -> IO Bool
isGitRepo dir = doesDirExist (dir </> [reldir|.git|])

listRepos :: Path Abs Dir -> IO [Path Abs Dir]
listRepos parentdir = do
    (subdirs, _) <- listDir parentdir
    filterM isGitRepo subdirs

main :: IO ()
main = do
    home <- getHomeDir
    let fullPaths = map (home </>) paths
    repos <- fmap join (traverse listRepos fullPaths)
    traverse_ print repos

Concurrently fetch Git repositories:

module FetchRepos where

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad (join)
import Path (Path, Abs, Dir, toFilePath, (</>))
import Path.IO (getHomeDir)
import System.Exit (ExitCode(ExitSuccess))
import System.Process ( CreateProcess(cwd)
                      , createProcess
                      , shell
                      , waitForProcess
                      )

import ListRepos (listRepos, paths)

fetchRepo :: Path Abs Dir -> CreateProcess
fetchRepo dir =
    (shell "git fetch --prune --all")
    { cwd = Just (toFilePath dir) }

concurrentlyRetryForever :: [CreateProcess] -> IO ()
concurrentlyRetryForever procs = do
    handles <- mapConcurrently createProcess procs

    exitCodes <-
        traverse (waitForProcess . \(_,_,_,h) -> h) handles

    let failures = [ proc
                   | (proc, exitCode) <- zip procs exitCodes
                   , exitCode /= ExitSuccess
                   ]

    if (null failures) then pure ()
    else concurrentlyRetryForever failures

main :: IO ()
main = do
    home <- getHomeDir
    let fullPaths = map (home </>) paths
    repos <- fmap join (traverse listRepos fullPaths)
    concurrentlyRetryForever (map fetchRepo repos)