{- |
Module:      PFile.TrashCan
Copyright:   (c) 2024 Illia Shkroba
License:     BSD3
Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>
Stability:   unstable
Portability: non-portable (Non-Unix systems are not supported)

Types and functions for trashing filesystem's objects.
-}

{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

module PFile.TrashCan
  ( create
  , showCreateError
  , CreateError (..)
  , trash
  , showTrashError
  , TrashError (..)
  , restoreAll
  , restore
  , showRestoreEntryError
  , RestoreEntryError (..)
  , showRestoreError
  , RestoreError (..)
  , remove
  , showRemoveError
  , RemoveError (..)
  , dumpTrashed
  , showDumpTrashedError
  , DumpTrashedError (..)
  , trashed
  , TrashCan (TrashCan, root, dataRoot)
  ) where

import           Control.Monad.Writer       (MonadWriter)
import           Data.IORef
  ( IORef
  , modifyIORef'
  , newIORef
  , readIORef
  )
import           Data.List                  (delete)
import           PFile.Error
  ( liftIOWithError
  , modifyError
  , tellError
  )
import qualified PFile.Mount                as Mount
import           PFile.Path                 (doesPathExist, (<//>))
import qualified PFile.Path                 as Path
import qualified PFile.Profile.LinkHandling as LinkHandling
import           Protolude
import           System.Directory           (getTemporaryDirectory)
import           System.IO.Temp             (createTempDirectory)

-- | Create a new trash can.
--
-- @since 0.1.0.0
create :: (MonadError CreateError m, MonadIO m) => m TrashCan
create :: forall (m :: * -> *).
(MonadError CreateError m, MonadIO m) =>
m TrashCan
create = do
  String
temporaryRoot <- IO String
getTemporaryDirectory
    IO String -> (IOException -> CreateError) -> m String
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` IOException -> CreateError
TemporaryDirectoryResolveError
  String -> String -> IO String
createTempDirectory String
temporaryRoot String
"pfile"
    IO String -> (IOException -> CreateError) -> m String
forall e (m :: * -> *) a.
(MonadError e m, MonadIO m) =>
IO a -> (IOException -> e) -> m a
`liftIOWithError` Absolute -> IOException -> CreateError
TemporaryDirectoryCreateError (String -> Absolute
Path.Absolute String
temporaryRoot)
    m String -> (String -> m TrashCan) -> m TrashCan
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(String -> Absolute
Path.Absolute -> Absolute
root) -> do
      IORef [Absolute]
_trashed <- [Absolute] -> IO (IORef [Absolute])
forall a. a -> IO (IORef a)
newIORef [] IO (IORef [Absolute])
-> (IO (IORef [Absolute]) -> m (IORef [Absolute]))
-> m (IORef [Absolute])
forall a b. a -> (a -> b) -> b
& IO (IORef [Absolute]) -> m (IORef [Absolute])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      TrashCan -> m TrashCan
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TrashCan {Absolute
root :: Absolute
root :: Absolute
root, dataRoot :: Absolute
dataRoot = Absolute
root Absolute -> String -> Absolute
<//> String
"data", IORef [Absolute]
_trashed :: IORef [Absolute]
_trashed :: IORef [Absolute]
_trashed}

showCreateError :: CreateError -> Text
showCreateError :: CreateError -> Text
showCreateError = \case
  TemporaryDirectoryResolveError IOException
cause
    -> Text
"Unable to resolve temporary directory because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a b. (Show a, StringConv String b) => a -> b
show IOException
cause
  TemporaryDirectoryCreateError Absolute
path IOException
cause
    -> Text
"Unable to create temporary directory in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a b. (Show a, StringConv String b) => a -> b
show IOException
cause

-- | Error thrown by 'create'.
--
-- @since 0.1.0.0
data CreateError
  = TemporaryDirectoryResolveError !IOException
  -- ^ 'IOException' was encountered during temporary directory resolving.
  | TemporaryDirectoryCreateError !Path.Absolute !IOException
  -- ^ 'IOException' was encountered during temporary directory creation.

-- | 'PFile.Mount.mount' 'PFile.Path.Absolute' inside of a 'TrashCan' with
-- 'PFile.Profile.LinkHandling.CopyLink' strategy for links.
--
-- @since 0.1.0.0
trash ::
     (MonadError TrashError m, MonadIO m) => Path.Absolute -> TrashCan -> m ()
trash :: forall (m :: * -> *).
(MonadError TrashError m, MonadIO m) =>
Absolute -> TrashCan -> m ()
trash Absolute
originPath trashCan :: TrashCan
trashCan@TrashCan {Absolute
dataRoot :: TrashCan -> Absolute
dataRoot :: Absolute
dataRoot, IORef [Absolute]
_trashed :: TrashCan -> IORef [Absolute]
_trashed :: IORef [Absolute]
_trashed} = do
  let Mount.Mount Absolute
trashPath = Root -> Absolute -> Mount
Mount.mountPath (Absolute -> Root
Mount.Root Absolute
dataRoot) Absolute
originPath
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Absolute -> m Bool
forall (m :: * -> *). MonadIO m => Absolute -> m Bool
doesPathExist Absolute
trashPath) (m () -> m ()) -> (TrashError -> m ()) -> TrashError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrashError -> m ()
forall a. TrashError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (TrashError -> m ()) -> TrashError -> m ()
forall a b. (a -> b) -> a -> b
$ Absolute -> TrashCan -> TrashError
AlreadyTrashedError Absolute
originPath TrashCan
trashCan
  Strategy -> Root -> Absolute -> ExceptT MountError m Mount
forall (m :: * -> *).
(MonadError MountError m, MonadIO m) =>
Strategy -> Root -> Absolute -> m Mount
Mount.mount Strategy
LinkHandling.CopyLink (Absolute -> Root
Mount.Root Absolute
dataRoot) Absolute
originPath
    ExceptT MountError m Mount
-> (ExceptT MountError m Mount -> m Mount) -> m Mount
forall a b. a -> (a -> b) -> b
& (MountError -> TrashError) -> ExceptT MountError m Mount -> m Mount
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError MountError -> TrashError
MountError
    m Mount -> (m Mount -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& m Mount -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
  IORef [Absolute] -> ([Absolute] -> [Absolute]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Absolute]
_trashed (Absolute
trashPath Absolute -> [Absolute] -> [Absolute]
forall a. a -> [a] -> [a]
:) IO () -> (IO () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

showTrashError :: TrashError -> Text
showTrashError :: TrashError -> Text
showTrashError = \case
  AlreadyTrashedError Absolute
path TrashCan {Absolute
root :: TrashCan -> Absolute
root :: Absolute
root}
    -> Text
"Path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is already trashed in: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
root Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
  MountError MountError
cause -> MountError -> Text
Mount.showMountError MountError
cause

-- | Error thrown by 'trash'.
--
-- @since 0.1.0.0
data TrashError
  = AlreadyTrashedError !Path.Absolute !TrashCan
  -- ^ 'PFile.Path.Absolute' is already trashed.
  | MountError !Mount.MountError
  -- ^ Error was encountered during 'PFile.Mount.mount'.

-- | 'restore' all 'trash'ed filesystem's objects back to their original
-- locations. When an error is encountered during 'restore', 'restoreAll'
-- terminates and provides successfully 'restore'ed entries via
-- a 'MonadWriter'.
--
-- @since 0.1.0.0
restoreAll :: (MonadWriter [RestoreEntryError] m, MonadIO m) => TrashCan -> m ()
restoreAll :: forall (m :: * -> *).
(MonadWriter [RestoreEntryError] m, MonadIO m) =>
TrashCan -> m ()
restoreAll TrashCan
trashCan = TrashCan -> m [Absolute]
forall (m :: * -> *). MonadIO m => TrashCan -> m [Absolute]
trashed TrashCan
trashCan m [Absolute] -> ([Absolute] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Absolute -> m ()) -> [Absolute] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \Absolute
path ->
  TrashCan -> Absolute -> ExceptT RestoreError m ()
forall (m :: * -> *).
(MonadError RestoreError m, MonadIO m) =>
TrashCan -> Absolute -> m ()
restore TrashCan
trashCan Absolute
path
    ExceptT RestoreError m ()
-> (ExceptT RestoreError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (RestoreError -> RestoreEntryError)
-> ExceptT RestoreError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadWriter [e2] m =>
(e1 -> e2) -> ExceptT e1 m a -> m ()
tellError (Absolute -> RestoreError -> RestoreEntryError
RestoreEntryError Absolute
path)

-- | 'PFile.Mount.unmount' 'PFile.Path.Absolute' (turned into
-- 'PFile.Mount.Mount') from a 'TrashCan' back to its original location (before
-- 'trash').
--
-- @since 0.1.0.0
restore ::
     (MonadError RestoreError m, MonadIO m) => TrashCan -> Path.Absolute -> m ()
restore :: forall (m :: * -> *).
(MonadError RestoreError m, MonadIO m) =>
TrashCan -> Absolute -> m ()
restore TrashCan {Absolute
dataRoot :: TrashCan -> Absolute
dataRoot :: Absolute
dataRoot, IORef [Absolute]
_trashed :: TrashCan -> IORef [Absolute]
_trashed :: IORef [Absolute]
_trashed} Absolute
path = do
  Root -> Mount -> ExceptT UnmountError m Absolute
forall (m :: * -> *).
(MonadError UnmountError m, MonadIO m) =>
Root -> Mount -> m Absolute
Mount.unmount (Absolute -> Root
Mount.Root Absolute
dataRoot) (Absolute -> Mount
Mount.Mount Absolute
path)
    ExceptT UnmountError m Absolute
-> (ExceptT UnmountError m Absolute -> m Absolute) -> m Absolute
forall a b. a -> (a -> b) -> b
& (UnmountError -> RestoreError)
-> ExceptT UnmountError m Absolute -> m Absolute
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError UnmountError -> RestoreError
UnmountError
    m Absolute -> (m Absolute -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& m Absolute -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
  IORef [Absolute] -> ([Absolute] -> [Absolute]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Absolute]
_trashed (Absolute -> [Absolute] -> [Absolute]
forall a. Eq a => a -> [a] -> [a]
delete Absolute
path) IO () -> (IO () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

showRestoreEntryError :: RestoreEntryError -> Text
showRestoreEntryError :: RestoreEntryError -> Text
showRestoreEntryError = \case
  RestoreEntryError Absolute
path RestoreError
cause
    -> Text
"Unable to restore entry " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RestoreError -> Text
showRestoreError RestoreError
cause

-- | Error provided via 'MonadWriter' by 'restoreAll'.
--
-- @since 0.1.0.0
data RestoreEntryError
  = RestoreEntryError !Path.Absolute !RestoreError
  -- ^ Error was encountered during 'restore'.

showRestoreError :: RestoreError -> Text
showRestoreError :: RestoreError -> Text
showRestoreError = \case
  UnmountError UnmountError
cause -> UnmountError -> Text
Mount.showUnmountError UnmountError
cause

-- | Error thrown by 'restore'.
--
-- @since 0.1.0.0
newtype RestoreError
  = UnmountError Mount.UnmountError
  -- ^ Error was encountered during 'PFile.Mount.unmount'.

-- | Remove a 'TrashCan' forcibly.
--
-- @since 0.1.0.0
remove :: (MonadError RemoveError m, MonadIO m) => TrashCan -> m ()
remove :: forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
TrashCan -> m ()
remove TrashCan {Absolute
root :: TrashCan -> Absolute
root :: Absolute
root} =
  Absolute -> ExceptT RemoveError m ()
forall (m :: * -> *).
(MonadError RemoveError m, MonadIO m) =>
Absolute -> m ()
Path.remove Absolute
root
    ExceptT RemoveError m ()
-> (ExceptT RemoveError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (RemoveError -> RemoveError) -> ExceptT RemoveError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError RemoveError -> RemoveError
TemporaryDirectoryRemoveError

showRemoveError :: RemoveError -> Text
showRemoveError :: RemoveError -> Text
showRemoveError = \case
  TemporaryDirectoryRemoveError RemoveError
cause
    -> Text
"Unable to remove temporary directory because of: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemoveError -> Text
Path.showRemoveError RemoveError
cause

-- | Error thrown by 'remove'.
--
-- @since 0.1.0.0
newtype RemoveError
  = TemporaryDirectoryRemoveError Path.RemoveError
  -- ^ Error was encountered during temporary directory removal.

-- | Dump 'trashed' to a file inside of the 'root' directory.
--
-- @since 0.1.0.0
dumpTrashed ::
     (MonadError DumpTrashedError m, MonadIO m) => TrashCan -> m Path.Absolute
dumpTrashed :: forall (m :: * -> *).
(MonadError DumpTrashedError m, MonadIO m) =>
TrashCan -> m Absolute
dumpTrashed trashCan :: TrashCan
trashCan@TrashCan {Absolute
root :: TrashCan -> Absolute
root :: Absolute
root} = do
  [Absolute]
paths <- TrashCan -> m [Absolute]
forall (m :: * -> *). MonadIO m => TrashCan -> m [Absolute]
trashed TrashCan
trashCan
  let dumped :: Text
dumped = [Text] -> Text
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (Absolute -> String) -> Absolute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> String
Path.unAbsolute (Absolute -> Text) -> [Absolute] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Absolute]
paths
  Absolute -> Text -> ExceptT WriteFileError m ()
forall (m :: * -> *).
(MonadError WriteFileError m, MonadIO m) =>
Absolute -> Text -> m ()
Path.writeFile Absolute
trashedPath Text
dumped
    ExceptT WriteFileError m ()
-> (ExceptT WriteFileError m () -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& (WriteFileError -> DumpTrashedError)
-> ExceptT WriteFileError m () -> m ()
forall e2 (m :: * -> *) e1 a.
MonadError e2 m =>
(e1 -> e2) -> ExceptT e1 m a -> m a
modifyError WriteFileError -> DumpTrashedError
DumpTrashedError
  Absolute -> m Absolute
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Absolute
trashedPath
  where
    trashedPath :: Path.Absolute
    trashedPath :: Absolute
trashedPath = Absolute
root Absolute -> String -> Absolute
<//> String
"trashed.txt"

showDumpTrashedError :: DumpTrashedError -> Text
showDumpTrashedError :: DumpTrashedError -> Text
showDumpTrashedError = \case
  DumpTrashedError WriteFileError
cause -> case WriteFileError
cause of
    Path.CreateParentInWriteFileError {} -> WriteFileError -> Text
Path.showWriteFileError WriteFileError
cause
    Path.WriteFileError Absolute
path IOException
ioCause
      -> Text
"Unable to dump a list of trashed paths to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Absolute -> Text
Path.showAbsolute Absolute
path
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" because of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a b. (Show a, StringConv String b) => a -> b
show IOException
ioCause

-- | Error thrown by 'dumpTrashed'.
--
-- @since 0.1.0.0
newtype DumpTrashedError
  = DumpTrashedError Path.WriteFileError
  -- ^ Error was encountered during writing to a "trashed.txt" file inside of
  -- the 'root' directory.

-- | List of 'trash'ed filesystem's objects.
--
-- @since 0.1.0.0
trashed :: MonadIO m => TrashCan -> m [Path.Absolute]
trashed :: forall (m :: * -> *). MonadIO m => TrashCan -> m [Absolute]
trashed TrashCan {IORef [Absolute]
_trashed :: TrashCan -> IORef [Absolute]
_trashed :: IORef [Absolute]
_trashed} = IORef [Absolute] -> IO [Absolute]
forall a. IORef a -> IO a
readIORef IORef [Absolute]
_trashed IO [Absolute] -> (IO [Absolute] -> m [Absolute]) -> m [Absolute]
forall a b. a -> (a -> b) -> b
& IO [Absolute] -> m [Absolute]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Trash can for filesystem's objects.
--
-- @since 0.1.0.0
data TrashCan
  = TrashCan
      { TrashCan -> Absolute
root     :: !Path.Absolute
      -- ^ Root directory of a 'TrashCan'.
      , TrashCan -> Absolute
dataRoot :: !Path.Absolute
      -- ^ Directory of a 'TrashCan' where 'trash'ed filesystem's objects are
      -- located.
      , TrashCan -> IORef [Absolute]
_trashed :: !(IORef [Path.Absolute])
      -- ^ List of 'trash'ed filesystem's objects in 'IORef'.
      }