gdo-0.1.3: Lib.hs

{-# LANGUAGE RecordWildCards #-}

module Lib
       ( putStrErr
       , putStrLnErr
         -- * directory names
       , getMetaDir
       , getMissingDepsFile
       , getDefaultDirs
         -- * Actions
       , executeRecipe
       , getRecipeFile
       , upToDate
       , recordDependency
       , recordMissingDependency
       , purgeRecordedDependencies
       , getHashesAndDepsForTarget
       )
       where

import           Control.Exception (finally)
import           Control.Monad (when,filterM,foldM)
import           Control.Monad.Fail (MonadFail(fail))
import           Control.Monad.IO.Class (liftIO, MonadIO)
import           Control.Monad.Trans.Maybe (runMaybeT)
import           Crypto.Hash (hash,Digest,MD5)
import qualified Data.ByteString as BS
import qualified Data.Map as Map (toList,fromList,insert)
import           Data.Maybe (listToMaybe, isJust)
import qualified Prelude
import           Prelude hiding (fail,readFile)
import           System.Directory (getCurrentDirectory, makeAbsolute, doesFileExist, renameFile, removeFile, createDirectoryIfMissing, getDirectoryContents, removeDirectoryRecursive, withCurrentDirectory, doesDirectoryExist)
import           System.Environment (getEnvironment,lookupEnv)
import           System.Exit (ExitCode(ExitSuccess),exitFailure)
import           System.FilePath ((</>), takeBaseName, dropFileName, replaceBaseName, addExtension,splitSearchPath)
import           System.IO (hPutStrLn,stderr,hPutStr,withFile,IOMode(ReadMode,WriteMode,AppendMode),hFileSize)
import qualified System.Process as Proc (env, waitForProcess, createProcess, proc)

import           DepInfo

type Hash = String

readFile :: (MonadFail m, MonadIO m) => FilePath -> m String
readFile p = ifM (liftIO $ doesFileExist p)
  (liftIO $ Prelude.readFile p)
  (fail $ "File "++p++"does not exist")

-- | Print a string to standard error output with a newline character
-- in the end.
putStrLnErr :: (MonadIO m) => String -> m ()
putStrLnErr msg =
  liftIO $ hPutStrLn stderr msg

-- | Print a string to standard error output.
putStrErr :: (MonadIO m) => String -> m ()
putStrErr = liftIO . hPutStr stderr

-- | Get the path for the directory where the targets meta information
-- is stored.  This will only work, if you are in the same directory
-- as the target.
getMetaDir :: (MonadIO m) =>
              String -- ^ target name
           -> m FilePath
getMetaDir target = do
  current <- liftIO $ makeAbsolute =<< getCurrentDirectory
  return $ current </> metadir </> target

metadir :: FilePath
metadir = ".gdo"

getMissingDepsFile :: (MonadIO m) => String -> m FilePath
getMissingDepsFile target = (</> gdoMissingFile) <$> getMetaDir target

gdoMissingFile :: FilePath
gdoMissingFile = "gdo---watch-dir"

metaIgnoreFiles :: [FilePath]
metaIgnoreFiles = [".","..",gdoMissingFile]

-- | Execute a build recipe for a given target.
executeRecipe :: FilePath -- ^ build target
              -> FilePath -- ^ recipe file
              -> IO ExitCode
executeRecipe target recipe = do
  currentDir <- getCurrentDirectory
  let tempFilePath = currentDir </> tempFileName
  createFile tempFilePath
  finally
    (do
        process <- modEnv $ Proc.proc recipe
                   [targetDir,takeBaseName target, tempFilePath]
        (_,_,_,ph) <- liftIO $ Proc.createProcess process
        code <- liftIO $ Proc.waitForProcess ph
        if code /= ExitSuccess
          then do
            putStrLnErr $ "*** redo failed for target "++show target
            exitFailure
          else do filesize <- getFileSize tempFilePath
                  when (filesize /= 0) $ renameFile tempFilePath target
        return code
    )
    (do exists <- doesFileExist tempFilePath
        when exists $ removeFile tempFilePath
    )
  where
    modEnv process = do
      oldEnv <- liftIO getEnvironment
      return process {Proc.env =
                        Just (Map.toList .
                              Map.insert "REDO_TARGET" target .
                              Map.fromList $ oldEnv)
                     }
    targetDir = dropFileName target
    tempFileName = target ++ "---gdo"
    getFileSize :: FilePath -> IO Integer
    getFileSize path = withFile path ReadMode hFileSize
    createFile :: FilePath -> IO ()
    createFile path = writeFile path ""

-- | Find out which recipe file to use to build a target.
getRecipeFile :: (MonadIO m) =>
                 [FilePath] -- ^ List of extra search paths with
                            -- potential default do files
              -> FilePath   -- ^ the target name
              -> m (Maybe FilePath)
getRecipeFile defaultDirs target =
  liftIO $ mapM makeAbsolute =<< listToMaybe <$>
    filterM doesFileExist
    ( [ addExtension target ".do"
      , replaceBaseName target "default" ++ ".do"
      ] ++ defaultsDirFile
    )
  where
    defaultDoFile = replaceBaseName target "default" ++ ".do"
    defaultsDirFile = fmap (</> defaultDoFile) defaultDirs

-- Get the default dirs from the environment.
getDefaultDirs :: (MonadIO m) => m [FilePath]
getDefaultDirs =
  maybe [] splitSearchPath <$> liftIO (lookupEnv "GDO_DEFAULTS")

hashFile :: (MonadIO m, MonadFail m) => FilePath -> m Hash
hashFile target = do
  targetExists <- liftIO (doesFileExist target)
  if targetExists
    then (show :: Digest MD5 -> String) . hash <$> liftIO (BS.readFile target)
    else fail $ "Files "++target++"does not exist!"

upToDate :: (MonadIO m) =>
            [FilePath]
         -> FilePath
         -> m Bool
upToDate mDefaultsDir buildTarget = do
  recipeExists <- isJust <$> liftIO (getRecipeFile mDefaultsDir buildTarget)
  if recipeExists
    then do
    mDepInfos <- runMaybeT (getHashesAndDepsForTarget buildTarget)
    case mDepInfos of
      Nothing -> return False
      Just depInfos -> do
        directDepsUpToDate <- if recipeExists
          then do
          return $ and . map depInfoUpToDate $ depInfos
          else return True
        depsUpToDate <-
          mapM (upToDate mDefaultsDir . depInfoFilePath) depInfos
        return (and $ directDepsUpToDate:depsUpToDate)
    else return True

ifM :: (Monad m) => m Bool -> m a -> m a -> m a
ifM condM consequence alternative = do
  cond <- condM
  if cond
    then consequence
    else alternative

getOldHashes :: (MonadIO m, MonadFail m) => String -> m [(String, FilePath)]
getOldHashes target = do
  metaDir <- liftIO $ getMetaDir target
  ifM (liftIO $ doesDirectoryExist metaDir)
    (liftIO $ withCurrentDirectory metaDir
      ( foldM putHashInMap mempty =<<
        (filter (not . (`elem` metaIgnoreFiles)) <$>
         (getDirectoryContents metaDir)))
    )
    ( fail "Metadata directory does not exist" )
  where
    putHashInMap hashmap filepath =
      (:) <$> ((,) <$> readFile filepath <*> pure filepath) <*> pure hashmap

getHashesAndDepsForTarget :: (MonadIO m, MonadFail m) =>
                             String -> m [DepInfo]
getHashesAndDepsForTarget target = do
  existingDeps <- mapM (liftIO . getDepInfo) =<< getOldHashes target
  nonExistingDeps <- futureDependencies
  return (existingDeps ++ nonExistingDeps)
  where
    getDepInfo (depInfoFilePath, oldHash) = do
      let
        depInfoSavedMD5 = Just oldHash
      depInfoCurrentMD5 <- runMaybeT $ hashFile depInfoFilePath
      return DepInfo {..}
    futureDependencies = do
      missingDepsFile <- getMissingDepsFile target
      r <- runMaybeT $
           Prelude.filter (\e -> (e `notElem` metaIgnoreFiles) ||
                                 Prelude.null e) .
           lines <$>
           readFile missingDepsFile
      case r of
       Nothing -> return []
       Just watchlist ->
         mapM (\ depInfoFilePath -> do
                  let
                    depInfoSavedMD5 = Nothing
                  depInfoCurrentMD5 <- runMaybeT (hashFile depInfoFilePath)
                  return DepInfo {..}
              )
         watchlist

-- | `recordDependency target dep` records the existing file `dep` as
-- a dependency of `target`.
--
-- `target` can be absolute paths or paths relative to the current
-- working directory.
recordDependency :: FilePath -- ^ target name
                 -> FilePath -- ^ dependency name
                 -> IO ()
recordDependency target dep = do
  newHash <- hashFile dep
  metaDepDir <- getMetaDir target
  let md5file = metaDepDir </> newHash
  liftIO $ createDirectoryIfMissing True metaDepDir
  liftIO $ withFile md5file WriteMode
    (`hPutStr` dep)

-- | `recordMissingDependency target dep` records `dep` as a
-- dependency of `target` if it should be created.
--
-- `target` can be absolute paths or paths relative to the current
-- working directory.
recordMissingDependency :: FilePath -> FilePath -> IO ()
recordMissingDependency target dep = do
  metaDepsDir <- getMetaDir target
  missingDepsFile <- getMissingDepsFile target
  liftIO $ createDirectoryIfMissing True metaDepsDir
  liftIO $ withFile
    missingDepsFile
    AppendMode
    (`hPutStrLn` dep)

-- | Remove all recorded dependencies for a target.  This makes the
-- target stale by definition.
purgeRecordedDependencies :: FilePath -> IO ()
purgeRecordedDependencies target =
  removeDirectoryRecursive =<< getMetaDir target