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

[friedbrice]

This is how I check my git repos every morning. This is a pretty long example, so it probably needs to be split into three smaller examples (which I'm happy to do if you think it'll make for good content).

#!/usr/bin/env stack
{- stack script --resolver lts-13.26 -}

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad (filterM, join)
import GHC.IO.Exception (ExitCode(ExitSuccess))
import System.Directory (doesDirectoryExist, getHomeDirectory, listDirectory)
import System.Process (CreateProcess(cwd), createProcess, shell, waitForProcess)

-- config, relative to user home directory
dirs :: [FilePath]
dirs = ["abs/aur", "friedbrice", "lumihq"]

-- Concat paths without fear
(+/) :: FilePath -> FilePath -> FilePath
(+/) "" "" = ""
(+/) parent child = case (last parent, head child) of
    ('/', '/') -> parent ++ tail child
    ('/', _) -> parent ++ child
    (_, '/') -> parent ++ child
    _ -> parent ++ "/" ++ child

fetchRepo :: FilePath -> CreateProcess
fetchRepo dir = (shell "git fetch --prune --all") { cwd = Just dir }

listRepos :: FilePath -> IO [FilePath]
listRepos parentdir = do
    files <- listDirectory parentdir
    let paths = (parentdir +/) <$> files
    filterM (doesDirectoryExist . (+/ ".git")) paths

concurrentlyRetryForever :: [CreateProcess] -> IO ()
concurrentlyRetryForever procs = do
    handles <- mapConcurrently createProcess procs
    codes <- traverse (waitForProcess . \(_,_,_,h) -> h) $ handles
    let failures = [ p | (p, c) <- zip procs codes, c /= ExitSuccess ]
    if null failures then pure () else concurrentlyRetryForever failures

main :: IO ()
main = do
    home <- getHomeDirectory
    let fullPaths = (home +/) <$> dirs
    repos <- join <$> traverse listRepos fullPaths
    concurrentlyRetryForever (fetchRepo <$> repos)

[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)