khph-0.1.0: src/Khph/Project/Impl.hs
-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
-- | Implementation of the project monad.
module Khph.Project.Impl (Project, ProjectT, run) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>), Applicative, pure)
#endif
import Control.Monad (ap, filterM, forM, forM_, liftM, unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.State as State
import Control.Monad.State (StateT, evalStateT)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Function (on)
import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)
import Data.List (intercalate, isSuffixOf, partition)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromJust, fromMaybe, isNothing, listToMaybe)
import qualified Data.Set as Set
import Data.Set (Set)
import Khph.Args (CommonArgs (..))
import Khph.Config
import Khph.Project.Base
import Khph.Project.Monad
import Khph.Query.Eval
import Khph.Util
import System.Directory (
canonicalizePath,
createDirectoryIfMissing,
doesFileExist,
getCurrentDirectory,
getDirectoryContents,
removeFile,
)
import System.Exit (exitFailure)
import System.FilePath ((</>), makeRelative, pathSeparator, takeFileName)
import System.IO (hPutStrLn, stderr)
import System.IO.Error (catchIOError, isDoesNotExistError)
import System.Posix (
DeviceID,
FileID,
FileStatus,
createSymbolicLink,
deviceID,
fileID,
getFileStatus,
getSymbolicLinkStatus,
isDirectory,
isSymbolicLink,
)
-- TODO This should be controllable.
basicIgnoredSuffixes :: [String]
basicIgnoredSuffixes = ["~"]
data Project = Project
{ projectRoot :: FilePath
, projectFileName :: Maybe FilePath
, projectConfig :: Config
, projectCommonArgs :: CommonArgs
, projectEntriesById :: Map EntryId EntryImpl
, projectEntriesByPath :: Map ProjectPath EntryId
, projectEntriesByTag :: Map Tag (Set EntryId)
, projectTags :: Set Tag
}
data EntryImpl = EntryImpl
{ entryImplId :: EntryId
, entryImplStat :: FileStatus
, entryImplHardLinks :: Set ProjectPath
, entryImplSoftLinks :: Set ProjectPath
, entryImplSourcePath :: Maybe ProjectPath
, entryImplTags :: Map Tag ProjectPath
}
instance Eq EntryImpl where
(==) = (==) `on` entryImplId
instance Ord EntryImpl where
compare = compare `on` entryImplId
instance Show EntryImpl where
show entry =
let softLinksMsg = case Set.toList $ entryImplSoftLinks entry of
[] -> ">"
[x] -> concat ["; soft link ", projectPathToRelativePath x, ">"]
xs -> concat ["; ", show $ length xs, " soft links>"]
in case Set.toList $ entryImplHardLinks entry of
[] -> concat ["<Entry", softLinksMsg]
[x] -> concat ["<Entry ", projectPathToRelativePath x, softLinksMsg]
xs@(x:_) -> concat ["Entry ", projectPathToRelativePath x, "; ", show xs,
" hard links", softLinksMsg]
entryImplLinks :: EntryImpl -> [ProjectPath]
entryImplLinks entry =
Set.toList (entryImplHardLinks entry) ++
Set.toList (entryImplSoftLinks entry)
newtype EntryId = EntryId (DeviceID, FileID)
deriving (Eq, Ord, Show)
data ProjectT m a = ProjectT { runProjectT' :: StateT Project m a }
instance Monad m => Functor (ProjectT m) where
fmap = liftM
instance Monad m => Applicative (ProjectT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (ProjectT m) where
return = ProjectT . return
(ProjectT x) >>= f = ProjectT $ runProjectT' . f =<< x
instance MonadTrans ProjectT where
lift = ProjectT . lift
instance MonadIO m => MonadIO (ProjectT m) where
liftIO = ProjectT . liftIO
instance MonadIO m => MonadProject (ProjectT m) where
type Entry (ProjectT m) = EntryImpl
projectWarn msg = liftIO $ hPutStrLn stderr $ "khph: Warning: " ++ msg
projectDie msg = liftIO $ do
hPutStrLn stderr $ "khph: Error: " ++ msg
exitFailure
printSummary msg = do
proceed <- caPrintSummaries . projectCommonArgs <$> get
when proceed $ liftIO $ hPutStrLn stderr msg
printFileAction msg = do
proceed <- caPrintFileActions . projectCommonArgs <$> get
when proceed $ liftIO $ hPutStrLn stderr msg
getConfig = projectConfig <$> get
getCurrentPathOrDie reason = do
root <- projectRoot <$> get
dir <- liftIO $ canonicalizePath =<< getCurrentDirectory
if pathIsAncestor root dir
then return $ toProjectPath $ makeRelative root dir
else projectDie $ concat $
"getCurrentPath: Expected the current path " : show dir :
" to be below the project root " : show root :
if null reason then ["."] else [", ", reason, "."]
parseRealPath path = do
root <- projectRoot <$> get
liftIO $ parseRealPath' root path
pathRealize projectPath = do
root <- projectRoot <$> get
return $ pathRealize' root projectPath
entrySpecLookup entrySpec = case entrySpec of
EntrySpecAbsolute components -> return [projectPathFromComponents components]
EntrySpecRelative components -> do
currentPath <- getCurrentPathOrDie $ "looking for tags matching " ++ show entrySpec
return [projectPathAppendComponents currentPath components]
EntrySpecByName name ->
filter (\path -> maybeLast (projectPathToComponents path) == Just name) .
Map.keys .
projectEntriesByPath <$>
get
entryAtPath projectPath = do
project <- get
return $
flip Map.lookup (projectEntriesById project) =<<
flip Map.lookup (projectEntriesByPath project) projectPath
queryEntries query = filterM (queryApply query) . Map.elems . projectEntriesById =<< get
entryHardLinks = return . Set.toList . entryImplHardLinks
entrySoftLinks = return . Set.toList . entryImplSoftLinks
entrySourcePath = return . entryImplSourcePath
entryTags = return . Map.keys . entryImplTags
tagList = projectTags <$> get
-- TODO Reuse entrySpecLookup?
tagLookup entrySpec = case entrySpec of
EntrySpecAbsolute components -> case toTag $ projectPathFromComponents components of
Left err -> oops err
Right tag -> doLookup tag
EntrySpecRelative components -> do
currentPath <- getCurrentPathOrDie $ "looking for tags matching " ++ show entrySpec
case toTag $ projectPathAppendComponents currentPath components of
Left err -> oops err
Right tag -> doLookup tag
EntrySpecByName name ->
filter (\tag -> maybeLast (tagToComponents tag) == Just name) .
Set.toList <$>
tagList
where doLookup tag = do
found <- Set.member tag <$> tagList
return $ if found then [tag] else []
oops err =
projectDie $ concat
["tagLookup: Failed to create tag object from ", show entrySpec, ": ", err]
tagCreate entrySpec = do
-- By-name EntrySpecs are not allowed for tag creation.
case entrySpec of
EntrySpecByName name ->
projectDie $ concat
["tagCreate: By-name tag specifications are not allowed, ",
"please use an absolute or relative specification (",
pathSeparator:name, " or .", pathSeparator:name, ")."]
_ -> return ()
-- If the tag exists, we don't need to do anything.
existingTags <- tagLookup entrySpec
case existingTags of
[] -> do
-- The tag doesn't exist, let's create it! Determine a project path for
-- the tag. EntrySpecByName doesn't make any sense here, we need a
-- concrete path.
projectPath <- case entrySpec of
EntrySpecAbsolute components -> return $ projectPathFromComponents components
EntrySpecRelative components -> do
currentPath <- getCurrentPathOrDie $ "creating tag for " ++ show entrySpec
return $ projectPathAppendComponents currentPath components
EntrySpecByName _ ->
projectDie $ concat
["tagCreate: Internal error, still have a by-name spec ", show entrySpec, "."]
-- Calculate a valid Tag object.
tag <- case toTag projectPath of
Left err ->
projectDie $ concat
["tagCreate: Couldn't create tag object from ", show entrySpec, ": ", err]
Right tag -> return tag
-- Create the necessary directories.
path <- pathRealize projectPath
printFileAction $ concat ["mkdir -p ", path]
liftIO $ createDirectoryIfMissing True path
-- Update internal state.
modify $ \project -> project {projectTags = Set.insert tag $ projectTags project}
return (tag, True)
[tag] -> return (tag, False) -- The tag already exists.
_ -> projectDie $ concat
["tagCreate: Internal error, ", show entrySpec,
" matches multiple existing tags: ", show existingTags]
tagAdd entries tags = do
ensureSourcePathsExist entries
forM_ tags $ \tag -> tagAdd' tag $ map (\entry -> (entry, Nothing)) entries
tagAdd1 entry tag baseNameMaybe = do
ensureSourcePathsExist [entry]
tagAdd' tag [(entry, baseNameMaybe)]
tagRemove entries tags = do
ensureSourcePathsExist entries
forM_ tags $ \tag ->
forM_ entries $ \entry -> case Map.lookup tag $ entryImplTags entry of
Nothing -> return ()
Just projectPath -> do
path <- pathRealize projectPath
-- Sanity check: Ensure that this is a soft link.
lstat <- liftIO $ getSymbolicLinkStatus path
if isSymbolicLink lstat
then do -- Remove the tag on disk.
printFileAction $ concat ["rm ", path]
liftIO $ removeFile path
-- Update the project in memory.
let entry' = entry { entryImplSoftLinks = Set.delete projectPath $
entryImplSoftLinks entry
, entryImplTags = Map.delete tag $ entryImplTags entry
}
entryId = entryImplId entry'
modify $ \project ->
project { projectEntriesById = Map.insert entryId entry' $
projectEntriesById project
, projectEntriesByPath = Map.delete projectPath $
projectEntriesByPath project
, projectEntriesByTag = Map.adjust (Set.delete entryId) tag $
projectEntriesByTag project
}
else projectWarn $ concat
["tagRemove: Want to remove ", show tag, " from ", show projectPath,
", but the file is not a soft link. Not removing."]
get :: Monad m => ProjectT m Project
get = ProjectT State.get
modify :: Monad m => (Project -> Project) -> ProjectT m ()
modify = ProjectT . State.modify
-- | Ensures that we have at least one source path for all given entries.
ensureSourcePathsExist :: MonadIO m => [EntryImpl] -> ProjectT m ()
ensureSourcePathsExist entries =
case filter (isNothing . entryImplSourcePath) entries of
[] -> return ()
xs -> projectDie $ concat $
"tagAdd: The following entries aren't linked in source directories: " :
map (("\n- " ++) . show) xs
run :: MonadIO m => CommonArgs -> FilePath -> Maybe FilePath -> ProjectT m a -> m a
run commonArgs projectDir maybeProjectFile action = do
loaded <- load commonArgs projectDir maybeProjectFile
case loaded of
Left err -> die err
Right project -> evalStateT (runProjectT' action) project
load :: MonadIO m => CommonArgs -> FilePath -> Maybe FilePath -> m (Either String Project)
load commonArgs projectRootRaw maybeProjectFileName = do
projectRoot <- liftIO $ canonicalizePath projectRootRaw
let maybeProjectFilePath = (projectRoot </>) <$> maybeProjectFileName
configResult <- case maybeProjectFilePath of
Nothing -> return $ Right defaultConfig
Just projectFilePath -> do
projectFileExists <- liftIO $ doesFileExist projectFilePath
if projectFileExists
then liftIO $ readProjectFile projectFilePath
else return $ Right defaultConfig
case configResult of
Left err -> return $ Left $ "Error parsing project file: " ++ err
Right config -> do
let sourceDirs = Set.toList $ configSourceDirs config
basicIgnoredPaths = (maybe id (:) maybeProjectFilePath) [projectRoot]
customIgnoredPaths = Set.fromList $
map (pathRealize' projectRoot) $
configIgnoredPaths config
entriesByIdRef <- liftIO $ newIORef Map.empty
entriesByTagRef <- liftIO $ newIORef Map.empty
tagsRef <- liftIO $ newIORef Set.empty
forAllEntriesRecursively projectRoot $ \path -> do
let (process, recur) = case undefined of
_ | Set.member path customIgnoredPaths -> (False, False)
_ | elem path basicIgnoredPaths ||
any (`isSuffixOf` path) basicIgnoredSuffixes -> (False, True)
_ -> (True, True)
when process $ do
maybeStat <- liftIO $ catchIOError (Just <$> getFileStatus path) $ \e ->
if isDoesNotExistError e
then return Nothing
else ioError e
lstat <- liftIO $ getSymbolicLinkStatus path
case maybeStat of
Nothing -> return () -- Dead soft link, ignore it.
Just stat -> case (isDirectory lstat, isDirectory stat) of
-- Ignore soft links to directories.
(False, True) -> return ()
(True, _) -> do
projectPath <- liftIO $
either (\err ->
die $ concat
["load: Couldn't parse a project path for ",
show path, ": ", err])
return =<<
parseRealPath' projectRoot path
when (not (any (\src -> projectPathIsPrefixOf src projectPath) sourceDirs)) $ do
tag <- either (\err ->
die $ concat ["load: Error parsing tag from directory ",
show path, ":", err])
return $
toTag projectPath
liftIO $ do
modifyIORef tagsRef $ Set.insert tag
modifyIORef entriesByTagRef $ Map.insert tag Set.empty
(False, False) -> do
let entryId = EntryId (deviceID stat, fileID stat)
projectPath = toProjectPath $ makeRelative projectRoot path
liftIO $ do
entriesById <- readIORef entriesByIdRef
let maybeEntry = Map.lookup entryId entriesById
entryInitial =
flip fromMaybe maybeEntry $
EntryImpl
{ entryImplId = entryId
, entryImplStat = stat
, entryImplHardLinks = Set.empty
, entryImplSoftLinks = Set.empty
, entryImplSourcePath = Nothing
, entryImplTags = Map.empty
}
entryWithLinks =
if isSymbolicLink lstat
then entryInitial
{ entryImplSoftLinks =
Set.insert projectPath $ entryImplSoftLinks entryInitial
}
else entryInitial
{ entryImplHardLinks =
Set.insert projectPath $ entryImplHardLinks entryInitial
}
isSourcePath path =
any (\sourceDir -> projectPathIsPrefixOf sourceDir path) sourceDirs
(sourcePaths, tagPaths) =
partition isSourcePath $ entryImplLinks entryWithLinks
-- If we have no source paths for a file, then ignore any tag
-- (i.e. non-source) paths for the file, since it doesn't make
-- sense to have a bunch of tags on a file we don't manage.
entryWithTags <-
if null sourcePaths
then return entryWithLinks
else do tags <- forM tagPaths $ \tagPath ->
case toTag $ projectPathDropLastComponent tagPath of
Left err ->
die $ concat ["load: Error parsing tag from path ",
show tagPath, ": ", err]
Right tag -> return (tag, tagPath)
return entryWithLinks
{ entryImplSourcePath = listToMaybe sourcePaths
, entryImplTags = Map.fromList tags
}
-- Update entriesById.
writeIORef entriesByIdRef $ Map.insert entryId entryWithTags entriesById
-- Update entriesByTag.
case Map.keys $ entryImplTags entryWithTags of
[] -> return ()
tags -> modifyIORef entriesByTagRef $ \entriesByTag ->
foldr (\tag entriesByTag' ->
Map.alter (Just . Set.insert entryId . fromMaybe Set.empty)
tag
entriesByTag')
entriesByTag
tags
return recur
entriesById <- liftIO $ readIORef entriesByIdRef
entriesByTag <- liftIO $ readIORef entriesByTagRef
tags <- liftIO $ readIORef tagsRef
let entries :: [EntryImpl]
entries = Map.elems entriesById
entriesByPath :: Map ProjectPath EntryId
entriesByPath = foldr (\entry m -> foldr (\path -> Map.insert path $ entryImplId entry)
m
(Set.toList (entryImplHardLinks entry) ++
Set.toList (entryImplSoftLinks entry)))
Map.empty
entries
project :: Project
project =
Project
{ projectRoot = projectRoot
, projectFileName = maybeProjectFileName
, projectConfig = config
, projectCommonArgs = commonArgs
, projectEntriesById = entriesById
, projectEntriesByPath = entriesByPath
, projectEntriesByTag = entriesByTag
, projectTags = tags
}
return $ Right project
parseRealPath' :: FilePath -> FilePath -> IO (Either String ProjectPath)
parseRealPath' root path = do
canonicalPath <- canonicalizePath path
if pathIsAncestor root canonicalPath
then return $ Right $ toProjectPath $ makeRelative root canonicalPath
else return $ Left $ concat
["parseRealPath: Path ", show canonicalPath,
" is not below the project root ", show root, "."]
pathRealize' :: FilePath -> ProjectPath -> FilePath
pathRealize' root path = root </> projectPathToRelativePath path
tagAdd' :: MonadIO m => Tag -> [(EntryImpl, Maybe String)] -> ProjectT m ()
tagAdd' tag entriesAndBaseNames = do
let tagComponents = tagToComponents tag
upToRoot = intercalate [pathSeparator] $ replicate (length tagComponents) ".."
forM_ entriesAndBaseNames $ \(entry, baseNameMaybe) ->
unless (Map.member tag $ entryImplTags entry) $ do
tagDir <- pathRealize $ tagToProjectPath tag
let entryPath = projectPathToRelativePath $ fromJust $ entryImplSourcePath entry
entryBaseName = takeFileName entryPath
linkSourcePath = tagDir </> fromMaybe entryBaseName baseNameMaybe
linkTargetPath = upToRoot </> entryPath
-- Add the tag on disk.
printFileAction $ concat ["ln -s ", linkTargetPath, " ", linkSourcePath]
liftIO $ createSymbolicLink linkTargetPath linkSourcePath
-- Update the project in memory.
let linkSourceProjectPath = projectPathAppend (tagToProjectPath tag) entryBaseName
entry' = entry { entryImplSoftLinks = Set.insert linkSourceProjectPath $
entryImplSoftLinks entry
, entryImplTags = Map.insert tag linkSourceProjectPath $
entryImplTags entry
}
entryId = entryImplId entry'
modify $ \project ->
project { projectEntriesById = Map.insert entryId entry' $
projectEntriesById project
, projectEntriesByPath = Map.insert linkSourceProjectPath entryId $
projectEntriesByPath project
, projectEntriesByTag =
Map.alter (Just . Set.insert entryId . fromMaybe Set.empty) tag $
projectEntriesByTag project
}
forAllEntriesRecursively :: MonadIO m => FilePath -> (FilePath -> m Bool) -> m ()
forAllEntriesRecursively root action = go root
where go path = do
recur <- action path
when recur $ do
typ <- liftIO $ getFileType path
when (typ == Directory) $ do
droppingIOErrors (getDirectoryContents path) $ \contents ->
forM_ contents $ \entry ->
unless (entry `elem` [".", ".."]) $
go $ path </> entry