-- 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