Dir.hs

{-# LANGUAGE CPP, PackageImports #-}
-- | About the directory in which the context is persited.
module System.Console.Hawk.Context.Dir
  ( createDefaultContextDir
  , findContextFromCurrDirOrDefault
  , checkContextDir
  ) where

import Prelude hiding (fail)

import Control.Monad hiding (fail)
#if MIN_VERSION_base(4,12,0)
import Control.Monad.Fail (fail)
#else
import Prelude (fail)
#endif
import "mtl" Control.Monad.Trans
import System.Directory
import System.FilePath

import Control.Monad.Trans.Uncertain
import System.Console.Hawk.Context.Paths
import System.Console.Hawk.UserPrelude.Defaults
import System.Directory.Extra


-- | Create a default context
createDefaultContextDir :: FilePath -> UncertainT IO ()
createDefaultContextDir contextDir = do
    _ <- checkContextDir contextDir
    liftIO $ do
      createDirectoryIfMissing True contextDir
      preludeExists <- doesFileExist preludeFile
      unless preludeExists $ writeFile preludeFile defaultPrelude
  where
    paths = mkContextPaths contextDir
    preludeFile = originalPreludePath paths

-- | Find a project context
findContext :: FilePath -> IO (Maybe FilePath)
findContext startDir =
    foldM (maybe validDirOrNothing (const . return . Just)) Nothing possibleContextDirs
  where
    mkHawkPath = (</> ".hawk")
    possibleContextDirs = map mkHawkPath (ancestors startDir)

    validDirOrNothing dir = do
      dirExists <- doesDirectoryExist dir
      if dirExists
       then do
         permissions <- getPermissions dir
         if writable permissions && searchable permissions
           then do
             prelude <- findFile [dir] "prelude.hs"
             case prelude of
               Nothing -> return Nothing
               Just f -> do
                 preludePermissions <- getPermissions f
                 if readable preludePermissions
                   then return $ Just dir
                   else return Nothing
           else return Nothing
       else return Nothing

-- | Find a project context starting from the current working directory
findContextFromCurrDir :: IO (Maybe FilePath)
findContextFromCurrDir = getCurrentDirectory >>= findContext

-- | Find a project context or return the default
findContextFromCurrDirOrDefault :: IO FilePath
findContextFromCurrDirOrDefault = do
    maybeProjectContextDir <- findContextFromCurrDir
    case maybeProjectContextDir of
      Nothing -> getDefaultContextDir
      Just projectContextDir -> return projectContextDir

-- | Check if a directory is a valid context and return true if the directory
-- doesn't exist and the parent has the right permissions
checkContextDir :: FilePath -> UncertainT IO Bool
checkContextDir dir = do
    fileExists <- liftIO $ doesFileExist dir
    when fileExists $ fail $ concat [
       "context directory '",dir,"' cannot be"
      ,"created because a file with the same"
      ,"name exists"]
    dirExists <- liftIO $ doesDirectoryExist dir
    if dirExists
      then do
        permissions <- liftIO $ getPermissions dir
        unless (writable permissions) $ fail $ concat [
           "cannot use '",dir,"' as context directory because it is not "
          ,"writable"]
        unless (searchable permissions) $ fail $ concat [
           "cannot use '",dir,"' as context directory because it is not "
          ,"searchable"]
        return False
      else do
        -- if the directory doesn't exist then its parent must be writable
        -- and searchable
        let parent = case takeDirectory dir of {"" -> ".";p -> p}
        permissions <- liftIO $ getPermissions parent
        unless (writable permissions) $ fail $ concat[
           "cannot create context directory '",dir,"' because the parent "
          ," directory is not writable (",show permissions,")"]
        unless (searchable permissions) $ fail $ concat[
           "cannot create context directory '",dir,"' because the parent "
          ," directory is not searchable (",show permissions,")"]
        warn $ concat ["directory '",dir,"' doesn't exist, creating a "
                      ,"default one"]
        return True

getDefaultContextDir :: IO FilePath
getDefaultContextDir = do
    home <- getHomeDirectory
    return $ home </> ".hawk"