gdo-0.1.0: Lib.hs

module Lib
       ( putStrErr
       , putStrLnErr
         -- * directory names
       , getMetaDir
       , getMissingDepsFile
       , metaIgnoreFiles
       , getDefaultDirs
         -- * Actions
       , executeRecipe
       , getRecipeFile
       , upToDate
       , recordDependency
       )
       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)
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),hFileSize)
import           System.IO.Error (isDoesNotExistError)
import qualified System.Process as Proc

putStrLnErr :: (MonadIO m) => String -> m ()
putStrLnErr msg =
  liftIO $ hPutStrLn stderr msg

putStrErr :: (MonadIO m) => String -> m ()
putStrErr = liftIO . hPutStr stderr

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
  createFile tempFileName
  finally
    (do
        process <- modEnv $ Proc.proc recipe
                   [targetDir,takeBaseName target, tempFileName]
        (_,_,_,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 tempFileName
                  when (filesize /= 0) $ renameFile tempFileName target
        return code
    )
    (do exists <- doesFileExist tempFileName
        when exists $ removeFile tempFileName
    )
  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")

upToDate :: (MonadIO m) =>
            [FilePath]
         -> FilePath
         -> m Bool
upToDate mDefaultsDir buildTarget = do
  metaDepDir <- getMetaDir buildTarget
  liftIO $
    not . Prelude.null <$> getRecipeFile mDefaultsDir buildTarget >>= \canBuild ->
    if canBuild
    then 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 $ either (const False) id r
    else return True
  where
    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

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)

hashFile :: (MonadIO m) => FilePath -> m (Digest MD5)
hashFile target = do
  bs <- liftIO $ BS.readFile target
  return $ hash bs