Homebrew Brewfile Dump with Haskell

#!/usr/bin/env stack {- stack script --resolver nightly-2019-06-20 --package directory --package req --package aeson --package process --package parsec --package filepath --package unix -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- This script creates a Brewfile using `brew bundle dump` -- and adds to that all the apps from `/Applications` -- that can be installed via Homebrew as casks. -- -- Later you can use `brew bundle` to install or upgrade -- all dependencies listed the Brewfile. -- -- It can be useful to restore the same packages and apps -- on a different Mac. import Control.Monad import Control.Monad.IO.Class import Data.Aeson import Data.Char import Data.List import GHC.Generics import Network.HTTP.Req import System.Directory import System.Exit import System.FilePath.Posix import System.Posix.Files import System.Process import Text.Parsec newtype Response = Response [Package] deriving (Generic, Show, ToJSON, FromJSON) newtype Package = Package {name :: [String]} deriving (Generic, Show, ToJSON) instance FromJSON Package where parseJSON = withObject "Package" $ \v -> Package <$> v .: "name" data BrewfileLine = Tap String | Brew String | Cask String deriving (Eq) instance Show BrewfileLine where show (Tap s) = "tap \"" <> s <> "\"" show (Brew s) = "brew \"" <> s <> "\"" show (Cask s) = "cask \"" <> s <> "\"" instance Ord BrewfileLine where (<=) (Tap s1) (Tap s2) = fmap toLower s1 <= fmap toLower s2 (<=) (Tap _) _ = True (<=) (Brew s1) (Brew s2) = fmap toLower s1 <= fmap toLower s2 (<=) (Brew _) _ = True (<=) (Cask s1) (Cask s2) = fmap toLower s1 <= fmap toLower s2 (<=) (Cask _) _ = False main :: IO () main = do doesBrewfileExist <- fileExist "Brewfile" when doesBrewfileExist $ die "Brewfile already exists! Aborted." installed <- getInstalledApps installable <- fetchInstallableAppsWithBrew let casks = installed `intersect` installable lines <- getBrewDumpLines let all = union casks <$> lines either (die . show) (writeBrewfile >=> \_ -> putStrLn "Brewfile generated!") all getInstalledApps :: IO [BrewfileLine] getInstalledApps = do filePaths <- listDirectory "/Applications" let names = takeBaseName <$> filePaths pure $ Cask <$> names fetchInstallableAppsWithBrew :: IO [BrewfileLine] fetchInstallableAppsWithBrew = runReq defaultHttpConfig $ do res <- req GET (https "formulae.brew.sh" /: "api" /: "cask.json") NoReqBody jsonResponse mempty pure . fmap Cask . unNames $ (responseBody res :: Response) unNames :: Response -> [String] unNames (Response xs) = unName <$> xs where unName :: Package -> String unName (Package name) = head name getBrewDumpLines :: IO (Either ParseError [BrewfileLine]) getBrewDumpLines = do out <- readProcess "brew" ["bundle", "dump", "--file=/dev/stdout"] [] pure $ parse brewfileParser "" out writeBrewfile :: [BrewfileLine] -> IO () writeBrewfile = writeFile "Brewfile" . unlines . fmap show . sort . nub -- PARSER brewfileParser :: Stream s m Char => ParsecT s u m [BrewfileLine] brewfileParser = endBy1 brewfileLine $ char '\n' brewfileLine :: Stream s m Char => ParsecT s u m BrewfileLine brewfileLine = brewfileLine' "tap" Tap <|> brewfileLine' "brew" Brew <|> brewfileLine' "cask" Cask brewfileLine' :: Stream s m Char => String -> (String -> BrewfileLine) -> ParsecT s u m BrewfileLine brewfileLine' prefix constructor = do string $ prefix <> " " name <- quoted skipMany $ satisfy (/= '\n') pure $ constructor name quote :: Stream s m Char => ParsecT s u m Char quote = char '"' quoted :: Stream s m Char => ParsecT s u m String quoted = between quote quote (many1 $ noneOf "\"")