Util.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/>.

-- | Miscellaneous utilities.
module Khph.Util (
  butLast,
  maybeLast,
  splitOn,
  stripTrailingPathSeparators,
  anyM,
  allM,
  warn,
  die,
  rightOrDie,
  splitPath,
  pathIsAncestor,
  droppingIOErrors,
  LinkType (..),
  FileType (..),
  getFileType,
  parserEq,
  ) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.List (findIndex, isPrefixOf)
import System.Exit (exitFailure)
import System.FilePath (isPathSeparator, normalise, splitDirectories)
import System.IO (hPrint, hPutStrLn, stderr)
import System.IO.Error (
  catchIOError,
  doesNotExistErrorType,
  ioeGetErrorType,
  tryIOError,
  )
import System.Posix (
  getFileStatus,
  getSymbolicLinkStatus,
  isDirectory,
  isRegularFile,
  isSymbolicLink,
  )
import Text.Parsec ((<?>), ParsecT, anyToken, try)

butLast :: [a] -> [a]
butLast [] = []
butLast xs = take (length xs - 1) xs

maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast (x:[]) = Just x
maybeLast (_:xs) = maybeLast xs

-- | Splits a list at elements for which a predicate returns true.  The matching
-- elements themselves are dropped.
splitWhen :: (a -> Bool) -> [a] -> [[a]]
splitWhen _ [] = []
splitWhen f xs = case findIndex f xs of
  Just index -> let (term, _:rest) = splitAt index xs
                in term : splitWhen f rest
  Nothing -> [xs]

-- | Splits a string on a specified character.
splitOn :: Char -> String -> [String]
splitOn ch = splitWhen (== ch)

stripTrailingPathSeparators :: FilePath -> FilePath
stripTrailingPathSeparators "" = ""
stripTrailingPathSeparators str =
  if isPathSeparator $ last str
  then reverse $ dropWhile isPathSeparator $ reverse str
  else str

anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
anyM f (x:xs) = do b <- f x
                   if b then return True else anyM f xs

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM f (x:xs) = do b <- f x
                   if b then allM f xs else return False

warn :: MonadIO m => String -> m ()
warn msg = liftIO $ hPutStrLn stderr $ "khph: Warning: " ++ msg

die :: MonadIO m => String -> m a
die msg = liftIO $ do
  hPutStrLn stderr $ "khph: Error: " ++ msg
  exitFailure

rightOrDie :: MonadIO m => Either String a -> m a
rightOrDie = either (liftIO . die) return

splitPath :: FilePath -> [String]
splitPath = splitDirectories . normalise

pathIsAncestor :: FilePath -> FilePath -> Bool
pathIsAncestor path1 path2 = splitPath path1 `isPrefixOf` splitPath path2

-- | Executes an IO action, calling the handler function if the action succeeds,
-- and printing the error message to stderr if the action throws an exception.
droppingIOErrors :: MonadIO m => IO a -> (a -> m ()) -> m ()
droppingIOErrors action onSuccess = do
  result <- liftIO $ tryIOError action
  case result of
    Left err -> liftIO $ hPrint stderr err
    Right x -> onSuccess x

data LinkType = HardLink | SoftLink
              deriving (Eq, Show)

data FileType =
    Nonexistant
  | File
  | Directory
  | SymlinkTo FileType
  | Other
  deriving (Eq, Show)

getFileType :: FilePath -> IO FileType
getFileType = query getSymbolicLinkStatus
  where query f path = flip catchIOError handler $ do
          stat <- f path
          case undefined of
            _ | isRegularFile stat -> return File
            _ | isDirectory stat -> return Directory
            _ | isSymbolicLink stat -> fmap SymlinkTo $ query getFileStatus path
            _ -> return Other

        handler e =
          if ioeGetErrorType e == doesNotExistErrorType
          then return Nonexistant
          else ioError e

parserEq :: (Eq a, Show a, Monad m) => a -> ParsecT [a] u m ()
parserEq t =
  try (do t' <- anyToken
          if t == t' then return () else fail "") <?>
  show t