gdo-0.1.2: Lib.hs

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

import           Control.Exception (finally,tryJust)
import           Control.Monad (when,filterM,guard)
import           Control.Monad.IO.Class (liftIO, MonadIO)
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)
import           System.Directory (getCurrentDirectory, makeAbsolute, doesFileExist, renameFile, removeFile, createDirectoryIfMissing, getDirectoryContents, removeDirectoryRecursive, withCurrentDirectory)
import           System.Environment (getEnvironment,lookupEnv)
import           System.Exit (ExitCode(ExitSuccess))
import           System.FilePath ((</>), takeBaseName, dropFileName, replaceBaseName, addExtension,splitSearchPath)
import           System.IO (hPutStrLn,stderr,hPutStr,withFile,IOMode(ReadMode,WriteMode,AppendMode),hFileSize)
import           System.IO.Error (isDoesNotExistError)
import qualified System.Process as Proc (env, waitForProcess, createProcess, proc)

import           DepInfo

-- | 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 putStrLnErr $ "*** redo failed for target "++show target
          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) => FilePath -> m (Digest MD5)
hashFile target = do
  bs <- liftIO $ BS.readFile target
  return $ hash bs

upToDate :: (MonadIO m) =>
            [FilePath]
         -> FilePath
         -> m Bool
upToDate mDefaultsDir buildTarget = do
  metaDepDir <- getMetaDir buildTarget
  liftIO $
    maybe
      -- When no recipe exists, we assume the target is up to date.
      (return True)
      ( const $ do
           r <- tryJust
                (guard . isDoesNotExistError)
                ( do md5s <- Prelude.filter (not . (`elem` metaIgnoreFiles)) <$>
                             getDirectoryContents metaDepDir
                     depsNotChanged <- and <$> mapM upToDate' md5s
                     noNewFiles <- not <$> newFilesCreated
                     return $ depsNotChanged && noNewFiles
                )
           return $ fromRight (const False) r
      ) =<< getRecipeFile mDefaultsDir buildTarget
  where
    fromRight :: (a -> b) -> Either a b -> b
    fromRight f = either f id
    upToDate' :: String -> IO Bool
    upToDate' oldHash = do
      metaDepDir <- getMetaDir buildTarget
      r <- tryJust (guard . isDoesNotExistError) $ do
        dep <- readFile $ metaDepDir </> oldHash
        newHash <- show <$> hashFile dep
        depUpToDate <- upToDate mDefaultsDir dep
        let allUpToDate = oldHash == newHash && depUpToDate
        return allUpToDate
      case r of
       Right b -> return b
       Left _ -> return False
    newFilesCreated :: IO Bool
    newFilesCreated = do
      missingDepsFile <- getMissingDepsFile buildTarget
      r <- tryJust (guard . isDoesNotExistError) $
           Prelude.filter (\e -> (e `notElem` metaIgnoreFiles) ||
                                 Prelude.null e) .
           lines <$>
           readFile missingDepsFile
      case r of
       Left _ -> return False
       Right watchlist -> or <$> mapM
                          doesFileExist watchlist

getHashesAndDepsForTarget :: FilePath -> IO [DepInfo]
getHashesAndDepsForTarget target = do
  metaDir <- getMetaDir target
  (filenames, oldMd5s) <- withCurrentDirectory metaDir $ do
    hashes <- filter (not . (`elem` metaIgnoreFiles)) <$>
              getDirectoryContents metaDir
    (,) <$> mapM readFile hashes <*> pure hashes
  md5s <- mapM hashFromPath filenames
  return (zipWith3 DepInfo
          filenames
          (map Just oldMd5s)
          (map (Just . show)  md5s))
  where
    hashFromPath :: FilePath -> IO (Digest MD5)
    hashFromPath f = hash <$> BS.readFile f

recordDependency :: FilePath -- ^ target name
                 -> FilePath -- ^ dependency name
                 -> IO ()
recordDependency target dep = do
  newHash <- show <$> hashFile dep
  metaDepDir <- getMetaDir target
  let md5file = metaDepDir </> newHash
  liftIO $ createDirectoryIfMissing True metaDepDir
  liftIO $ withFile md5file WriteMode
    (`hPutStr` dep)

recordMissingDependency :: FilePath -> FilePath -> IO ()
recordMissingDependency target dep = do
  metaDepsDir <- getMetaDir target
  missingDepsFile <- getMissingDepsFile target
  liftIO $ createDirectoryIfMissing True metaDepsDir
  liftIO $ withFile
    missingDepsFile
    AppendMode
    (`hPutStrLn` dep)

purgeRecordedDependencies :: FilePath -> IO ()
purgeRecordedDependencies target =
  removeDirectoryRecursive =<< getMetaDir target