cabalg-0.2.8: src/Main.hs

import           Control.Applicative
import           Control.Exception
import           Control.Monad
import           Data.Foldable
import           Data.List
import           Data.Maybe
import           Data.Traversable
import           Data.Version                 (showVersion)
import           Paths_cabalg                 (version)
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.IO.Error
import           System.Process

import           Args
import           Git
import           System.Directory.NonExistent


main :: IO ()
main = do
  action <- fromArgs <$> getArgs
  case action of
    Help -> printHelp
    Version -> putStrLn $ showVersion version
    Install repos args -> do
      cabalFiles <- Data.Traversable.mapM fetch repos
      cabalInstall (catMaybes cabalFiles) args


fetch :: String -> IO (Maybe FilePath)
fetch urlAndMaybeRevision = do
  dir <-  getWorkingDirectory
  newDir <- createNonExistentDirectory dir ("cabalg_" ++ repoName urlAndMaybeRevision)
  case maybeRevision of
    Just revision -> cloneRevision url revision newDir
    Nothing -> clone url newDir
  findCabalFile newDir
    where
      maybeRevision = case dropWhile (/= '@') urlAndMaybeRevision of
        '@':x -> Just x
        _ -> Nothing
      url = takeWhile (/= '@') urlAndMaybeRevision


getWorkingDirectory :: IO FilePath
getWorkingDirectory =
  liftM2 fromMaybe getCurrentDirectory . fmap Data.Foldable.msum . traverse lookupEnv' $ ["TMPDIR", "TEMP"]


lookupEnv' :: String -> IO (Maybe String)
lookupEnv' var = do
  fmap eitherToMaybe . tryJust (guard . isDoesNotExistError) $ getEnv var
 where
  eitherToMaybe (Left  _) = Nothing
  eitherToMaybe (Right x) = Just x


cabalInstall :: [String] -> Maybe String -> IO ()
cabalInstall cabalFiles args = do
  let process = proc "cabal" ("install" : cabalFiles ++ words (fromMaybe "" args))
  (_, _, _, procHandle) <- createProcess process
  void $ waitForProcess procHandle


repoName :: String -> String
repoName = takeWhile (/= '@') . lastSplitOn '/'
  where lastSplitOn :: Eq a => a -> [a] -> [a]
        lastSplitOn c = go []
          where
            go acc (x:xs) | x == c = go [] xs
                          | otherwise = go (acc ++ [x]) xs
            go acc [] = acc


findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile path = ((path </>) `fmap`) `fmap` Data.List.find (".cabal" `isSuffixOf`) `fmap` getDirectoryContents path