{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Provides functionality for moving a file to a trash location.
module Charon
  ( -- * Delete
    delete,
    permDelete,
    emptyTrash,

    -- * Restore
    restore,

    -- * Information
    getIndex,
    getMetadata,

    -- * Transformations
    convert,
    merge,
  )
where

import Charon.Backend.Cbor qualified as Cbor
import Charon.Backend.Data (Backend (BackendCbor, BackendFdo, BackendJson))
import Charon.Backend.Data qualified as Backend.Data
import Charon.Backend.Fdo qualified as Fdo
import Charon.Backend.Json qualified as Json
import Charon.Data.Index (Index)
import Charon.Data.Metadata (Metadata)
import Charon.Data.Paths
  ( PathI (MkPathI),
    PathIndex (TrashEntryFileName, TrashEntryOriginalPath, TrashHome),
  )
import Charon.Data.Paths qualified as Paths
import Charon.Data.UniqueSeqNE (UniqueSeqNE)
import Charon.Env (HasBackend (getBackend), HasTrashHome (getTrashHome))
import Charon.Exception (BackendDetectE (MkBackendDetectE))
import Charon.Prelude
import Charon.Utils qualified as Utils
import Data.Text qualified as T
import Effects.FileSystem.PathWriter qualified as PW

-- NOTE: For functions that can encounter multiple exceptions, the first
-- one is rethrown.

-- | @delete trash p@ moves path @p@ to the given trash location @trash@ and
-- writes an entry in the trash index. If the trash location is not given,
-- defaults to XDG data e.g. @~\/.local/share/charon/@.
delete ::
  forall env m.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadIORef m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m,
    MonadTime m
  ) =>
  UniqueSeqNE (PathI TrashEntryOriginalPath) ->
  m ()
delete :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadFileWriter m, MonadIORef m,
 MonadLoggerNS m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m,
 MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
delete UniqueSeqNE (PathI 'TrashEntryOriginalPath)
paths = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"delete" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In delete"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> 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
>>= \case
      Backend
BackendCbor -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileWriter m, MonadIORef m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m, MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
Cbor.delete UniqueSeqNE (PathI 'TrashEntryOriginalPath)
paths
      Backend
BackendFdo -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadFileWriter m, MonadIORef m,
 MonadLoggerNS m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m,
 MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
Fdo.delete UniqueSeqNE (PathI 'TrashEntryOriginalPath)
paths
      Backend
BackendJson -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileWriter m, MonadIORef m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m, MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryOriginalPath) -> m ()
Json.delete UniqueSeqNE (PathI 'TrashEntryOriginalPath)
paths

-- | Permanently deletes the paths from the trash.
permDelete ::
  forall env m.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixCompat m,
    MonadLoggerNS m,
    MonadReader env m,
    MonadTerminal m,
    MonadTime m
  ) =>
  Bool ->
  UniqueSeqNE (PathI TrashEntryFileName) ->
  m ()
permDelete :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadFileWriter m,
 MonadHandleWriter m, MonadIORef m, MonadPathReader m,
 MonadPathWriter m, MonadPosixCompat m, MonadLoggerNS m,
 MonadReader env m, MonadTerminal m, MonadTime m) =>
Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
permDelete Bool
force UniqueSeqNE (PathI 'TrashEntryFileName)
paths = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"permDelete" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In permDelete"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> 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
>>= \case
      Backend
BackendCbor -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadHandleWriter m, MonadIORef m,
 MonadPathReader m, MonadPathWriter m, MonadLoggerNS m,
 MonadReader env m, MonadPosixCompat m, MonadTerminal m) =>
Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Cbor.permDelete Bool
force UniqueSeqNE (PathI 'TrashEntryFileName)
paths
      Backend
BackendFdo -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadFileWriter m, MonadHandleWriter m,
 MonadIORef m, MonadPathReader m, MonadPathWriter m,
 MonadLoggerNS m, MonadReader env m, MonadPosixCompat m,
 MonadTerminal m, MonadTime m) =>
Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Fdo.permDelete Bool
force UniqueSeqNE (PathI 'TrashEntryFileName)
paths
      Backend
BackendJson -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadHandleWriter m, MonadIORef m,
 MonadPathReader m, MonadPathWriter m, MonadLoggerNS m,
 MonadReader env m, MonadPosixCompat m, MonadTerminal m) =>
Bool -> UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Json.permDelete Bool
force UniqueSeqNE (PathI 'TrashEntryFileName)
paths

-- | Reads the index at either the specified or default location. If the
-- file does not exist, returns empty.
getIndex ::
  forall env m.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m
  ) =>
  m Index
getIndex :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadReader env m,
 MonadTerminal m) =>
m Index
getIndex = Text -> m Index -> m Index
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"getIndex" (m Index -> m Index) -> m Index -> m Index
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In getIndex"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> m Index) -> m Index
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Backend
BackendCbor -> Text -> m Index -> m Index
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" m Index
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadPathReader m, MonadLoggerNS m,
 MonadReader env m, MonadPosixCompat m, MonadTerminal m) =>
m Index
Cbor.getIndex
      Backend
BackendFdo -> Text -> m Index -> m Index
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" m Index
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadPathReader m, MonadLoggerNS m,
 MonadReader env m, MonadPosixCompat m, MonadTerminal m) =>
m Index
Fdo.getIndex
      Backend
BackendJson -> Text -> m Index -> m Index
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" m Index
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadPathReader m, MonadLoggerNS m,
 MonadReader env m, MonadPosixCompat m, MonadTerminal m) =>
m Index
Json.getIndex

-- | Retrieves metadata for the trash directory.
getMetadata ::
  forall m env.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m
  ) =>
  m Metadata
getMetadata :: forall (m :: * -> *) env.
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadLoggerNS m,
 MonadPathReader m, MonadPosixCompat m, MonadReader env m,
 MonadTerminal m) =>
m Metadata
getMetadata = Text -> m Metadata -> m Metadata
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"getMetadata" (m Metadata -> m Metadata) -> m Metadata -> m Metadata
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In getMetadata"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> m Metadata) -> m Metadata
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Backend
BackendCbor -> Text -> m Metadata -> m Metadata
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" m Metadata
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadLoggerNS m, MonadPathReader m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m) =>
m Metadata
Cbor.getMetadata
      Backend
BackendFdo -> Text -> m Metadata -> m Metadata
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" m Metadata
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadLoggerNS m, MonadPathReader m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m) =>
m Metadata
Fdo.getMetadata
      Backend
BackendJson -> Text -> m Metadata -> m Metadata
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" m Metadata
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadLoggerNS m, MonadPathReader m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m) =>
m Metadata
Json.getMetadata

-- | @restore trash p@ restores the trashed path @\<trash\>\/p@ to its original
-- location.
restore ::
  forall env m.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadIORef m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m,
    MonadTime m
  ) =>
  UniqueSeqNE (PathI TrashEntryFileName) ->
  m ()
restore :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadFileWriter m, MonadIORef m,
 MonadLoggerNS m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m,
 MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
restore UniqueSeqNE (PathI 'TrashEntryFileName)
paths = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"restore" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In restore"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> 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
>>= \case
      Backend
BackendCbor -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadIORef m, MonadFileReader m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Cbor.restore UniqueSeqNE (PathI 'TrashEntryFileName)
paths
      Backend
BackendFdo -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadIORef m, MonadFileReader m, MonadFileWriter m,
 MonadLoggerNS m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m,
 MonadTime m) =>
UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Fdo.restore UniqueSeqNE (PathI 'TrashEntryFileName)
paths
      Backend
BackendJson -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadIORef m, MonadFileReader m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
UniqueSeqNE (PathI 'TrashEntryFileName) -> m ()
Json.restore UniqueSeqNE (PathI 'TrashEntryFileName)
paths

-- | Empties the trash.
emptyTrash ::
  forall m env.
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadCatch m,
    MonadFileReader m,
    MonadHandleWriter m,
    MonadLoggerNS m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m
  ) =>
  Bool ->
  m ()
emptyTrash :: forall (m :: * -> *) env.
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadCatch m, MonadFileReader m, MonadHandleWriter m,
 MonadLoggerNS m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m) =>
Bool -> m ()
emptyTrash Bool
force = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"emptyTrash" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In emptyTrash"
  (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
    m Backend -> (Backend -> 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
>>= \case
      Backend
BackendCbor -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m ()
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadHandleWriter m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
Bool -> m ()
Cbor.emptyTrash Bool
force
      Backend
BackendFdo -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m ()
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadHandleWriter m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
Bool -> m ()
Fdo.emptyTrash Bool
force
      Backend
BackendJson -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m ()
forall (m :: * -> *) env.
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadFileReader m, MonadHandleWriter m, MonadLoggerNS m,
 MonadPathReader m, MonadPathWriter m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
Bool -> m ()
Json.emptyTrash Bool
force

convert ::
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadAsync m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadIORef m,
    MonadLoggerNS m,
    MonadMask m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadPosixCompat m,
    MonadReader env m,
    MonadTerminal m,
    MonadTime m
  ) =>
  Backend ->
  m ()
convert :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadAsync m,
 MonadFileReader m, MonadFileWriter m, MonadIORef m,
 MonadLoggerNS m, MonadMask m, MonadPathReader m, MonadPathWriter m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m,
 MonadTime m) =>
Backend -> m ()
convert Backend
dest = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"convert" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In convert"

  (MkPathI OsPath
trashHome') <- (env -> PathI 'TrashHome) -> m (PathI 'TrashHome)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> PathI 'TrashHome
forall a. HasTrashHome a => a -> PathI 'TrashHome
getTrashHome

  Backend
src <- (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend
  if Backend
src Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
dest
    then do
      let msg :: String
msg =
            [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"--backend == requested conversion type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Backend -> String
forall s. IsString s => Backend -> s
Backend.Data.backendName Backend
dest,
                String
". Nothing to do."
              ]
      $(logInfo) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
      String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
msg
    else do
      $(logDebug) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Current backend: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Backend -> String
forall s. IsString s => Backend -> s
Backend.Data.backendName Backend
src)

      -- 1. Get Rosetta
      Rosetta
rosetta <- case Backend
src of
        Backend
BackendCbor -> Text -> m Rosetta -> m Rosetta
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" m Rosetta
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadAsync m, MonadCatch m,
 MonadLoggerNS m, MonadFileReader m, MonadPathReader m,
 MonadPosixCompat m, MonadReader env m, MonadTerminal m) =>
m Rosetta
Cbor.toRosetta
        Backend
BackendFdo -> Text -> m Rosetta -> m Rosetta
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" m Rosetta
forall env (m :: * -> *).
(HasTrashHome env, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadFileReader m, MonadPathReader m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
m Rosetta
Fdo.toRosetta
        Backend
BackendJson -> Text -> m Rosetta -> m Rosetta
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" m Rosetta
forall env (m :: * -> *).
(HasTrashHome env, MonadAsync m, MonadCatch m, MonadLoggerNS m,
 MonadFileReader m, MonadPathReader m, MonadPosixCompat m,
 MonadReader env m, MonadTerminal m) =>
m Rosetta
Json.toRosetta

      $(logDebug) (Text
"Rosetta: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rosetta -> Text
forall a. Show a => a -> Text
showt Rosetta
rosetta)

      OsPath
newTrashTmpRaw <- OsPath -> m OsPath
forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadPathReader m, MonadThrow m,
 MonadTime m) =>
OsPath -> m OsPath
Utils.getRandomTmpFile [osp|tmp_trash_new|]

      let newTrashTmp :: PathI TrashHome
          newTrashTmp :: PathI 'TrashHome
newTrashTmp = OsPath -> PathI 'TrashHome
forall (i :: PathIndex). OsPath -> PathI i
MkPathI OsPath
newTrashTmpRaw

      PathI 'TrashHome -> Rosetta -> m ()
fromRosettaFn PathI 'TrashHome
newTrashTmp Rosetta
rosetta
        m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
          OsPath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadPathReader m, MonadPathWriter m) =>
OsPath -> m ()
PW.removeDirectoryRecursiveIfExists OsPath
newTrashTmpRaw
          $(logError) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Exception writing rosetta: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptiont SomeException
ex
          SomeException -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
ex

      -- 3. Back up old trash
      OsPath
oldTrashTmpRaw <- OsPath -> m OsPath
forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadPathReader m, MonadThrow m,
 MonadTime m) =>
OsPath -> m OsPath
Utils.getRandomTmpFile [osp|tmp_trash_old|]

      OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameDirectory OsPath
trashHome' OsPath
oldTrashTmpRaw
        m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
          let msg :: String
msg =
                [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Exception moving old trash dir:\n",
                    SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
                  ]
          $(logError) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
          String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
msg
          -- cleanup: remove newTrashTmp
          OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeDirectoryRecursive OsPath
newTrashTmpRaw
          SomeException -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
ex

      -- 4. Move newTrashTmp -> trash
      OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameDirectory OsPath
newTrashTmpRaw OsPath
trashHome'
        m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
          let msg :: String
msg =
                [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Exception moving new trash dir:\n",
                    SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
                  ]
          $(logError) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
          String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
msg
          -- cleanup: remove newTrashTmp, move oldTrashTmpRaw back
          OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeDirectoryRecursive OsPath
newTrashTmpRaw
          OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameDirectory OsPath
oldTrashTmpRaw OsPath
trashHome'
          SomeException -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
ex

      -- 4. Delete oldTrashTmpRaw
      OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeDirectoryRecursive OsPath
oldTrashTmpRaw
  where
    fromRosettaFn :: PathI 'TrashHome -> Rosetta -> m ()
fromRosettaFn PathI 'TrashHome
th Rosetta
r = case Backend
dest of
      Backend
BackendCbor -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> Rosetta -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadFileReader m,
 MonadFileWriter m, MonadIORef m, MonadMask m, MonadPathReader m,
 MonadPathWriter m) =>
PathI 'TrashHome -> Rosetta -> m ()
Cbor.fromRosetta PathI 'TrashHome
th Rosetta
r
      Backend
BackendFdo -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> Rosetta -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadFileReader m,
 MonadFileWriter m, MonadIORef m, MonadMask m, MonadPathReader m,
 MonadPathWriter m, MonadTime m) =>
PathI 'TrashHome -> Rosetta -> m ()
Fdo.fromRosetta PathI 'TrashHome
th Rosetta
r
      Backend
BackendJson -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> Rosetta -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLoggerNS m, MonadFileReader m,
 MonadFileWriter m, MonadIORef m, MonadMask m, MonadPathReader m,
 MonadPathWriter m) =>
PathI 'TrashHome -> Rosetta -> m ()
Json.fromRosetta PathI 'TrashHome
th Rosetta
r

merge ::
  ( HasBackend env,
    HasCallStack,
    HasTrashHome env,
    MonadFileReader m,
    MonadFileWriter m,
    MonadIORef m,
    MonadLoggerNS m,
    MonadMask m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadReader env m,
    MonadTerminal m,
    MonadTime m
  ) =>
  PathI TrashHome ->
  m ()
merge :: forall env (m :: * -> *).
(HasBackend env, HasCallStack, HasTrashHome env, MonadFileReader m,
 MonadFileWriter m, MonadIORef m, MonadLoggerNS m, MonadMask m,
 MonadPathReader m, MonadPathWriter m, MonadReader env m,
 MonadTerminal m, MonadTime m) =>
PathI 'TrashHome -> m ()
merge PathI 'TrashHome
dest = Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"merge" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
"In merge"

  PathI 'TrashHome
src <- (env -> PathI 'TrashHome) -> m (PathI 'TrashHome)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> PathI 'TrashHome
forall a. HasTrashHome a => a -> PathI 'TrashHome
getTrashHome

  PathI 'TrashHome
src' <- (HasCallStack => OsPath -> m OsPath)
-> PathI 'TrashHome -> m (PathI 'TrashHome)
forall (f :: * -> *) (i :: PathIndex).
Functor f =>
(HasCallStack => OsPath -> f OsPath) -> PathI i -> f (PathI i)
Paths.liftPathIF' HasCallStack => OsPath -> m OsPath
OsPath -> m OsPath
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m OsPath
canonicalizePath PathI 'TrashHome
src
  PathI 'TrashHome
dest' <- (HasCallStack => OsPath -> m OsPath)
-> PathI 'TrashHome -> m (PathI 'TrashHome)
forall (f :: * -> *) (i :: PathIndex).
Functor f =>
(HasCallStack => OsPath -> f OsPath) -> PathI i -> f (PathI i)
Paths.liftPathIF' HasCallStack => OsPath -> m OsPath
OsPath -> m OsPath
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m OsPath
canonicalizePath PathI 'TrashHome
dest

  $(logDebug) (Text
"Merging into: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PathI 'TrashHome -> Text
forall (i :: PathIndex). PathI i -> Text
Paths.toText PathI 'TrashHome
dest')

  if PathI 'TrashHome
src' PathI 'TrashHome -> PathI 'TrashHome -> Bool
forall a. Eq a => a -> a -> Bool
== PathI 'TrashHome
dest'
    then do
      let msg :: String
msg =
            [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"Source path ",
                OsPath -> String
decodeOsToFpDisplayEx (OsPath -> String) -> OsPath -> String
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome
src' PathI 'TrashHome
-> Optic' An_Iso NoIx (PathI 'TrashHome) OsPath -> OsPath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx (PathI 'TrashHome) OsPath
#unPathI,
                String
" is the same as dest path ",
                OsPath -> String
decodeOsToFpDisplayEx (OsPath -> String) -> OsPath -> String
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome
dest' PathI 'TrashHome
-> Optic' An_Iso NoIx (PathI 'TrashHome) OsPath -> OsPath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx (PathI 'TrashHome) OsPath
#unPathI,
                String
". Nothing to do."
              ]
      $(logInfo) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
      String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn String
msg
    else do
      $(logDebug) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Dest path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PathI 'TrashHome -> Text
forall (i :: PathIndex). PathI i -> Text
Paths.toText PathI 'TrashHome
dest
      Backend
backend <- (env -> Backend) -> m Backend
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Backend
forall a. HasBackend a => a -> Backend
getBackend

      case Backend
backend of
        Backend
BackendCbor ->
          PathI 'TrashHome -> m (Maybe Bool)
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadLoggerNS m, MonadPathReader m) =>
PathI 'TrashHome -> m (Maybe Bool)
Cbor.isCbor PathI 'TrashHome
dest m (Maybe Bool) -> (Maybe Bool -> 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
>>= \case
            Just Bool
False -> BackendDetectE -> m ()
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (BackendDetectE -> m ()) -> BackendDetectE -> m ()
forall a b. (a -> b) -> a -> b
$ Backend -> BackendDetectE
MkBackendDetectE Backend
BackendCbor
            Maybe Bool
_ -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"cbor" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> PathI 'TrashHome -> m ()
forall (m :: * -> *).
(HasCallStack, MonadFileReader m, MonadIORef m, MonadLoggerNS m,
 MonadMask m, MonadPathReader m, MonadPathWriter m) =>
PathI 'TrashHome -> PathI 'TrashHome -> m ()
Cbor.merge PathI 'TrashHome
src' PathI 'TrashHome
dest'
        Backend
BackendFdo ->
          PathI 'TrashHome -> m (Maybe Bool)
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadLoggerNS m, MonadPathReader m) =>
PathI 'TrashHome -> m (Maybe Bool)
Fdo.isFdo PathI 'TrashHome
dest m (Maybe Bool) -> (Maybe Bool -> 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
>>= \case
            Just Bool
False -> BackendDetectE -> m ()
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (BackendDetectE -> m ()) -> BackendDetectE -> m ()
forall a b. (a -> b) -> a -> b
$ Backend -> BackendDetectE
MkBackendDetectE Backend
BackendFdo
            Maybe Bool
_ -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"fdo" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> PathI 'TrashHome -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTrashHome env, MonadFileReader m,
 MonadFileWriter m, MonadIORef m, MonadLoggerNS m, MonadMask m,
 MonadPathReader m, MonadPathWriter m, MonadReader env m,
 MonadTime m) =>
PathI 'TrashHome -> PathI 'TrashHome -> m ()
Fdo.merge PathI 'TrashHome
src' PathI 'TrashHome
dest'
        Backend
BackendJson ->
          PathI 'TrashHome -> m (Maybe Bool)
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadLoggerNS m, MonadPathReader m) =>
PathI 'TrashHome -> m (Maybe Bool)
Json.isJson PathI 'TrashHome
dest m (Maybe Bool) -> (Maybe Bool -> 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
>>= \case
            Just Bool
False -> BackendDetectE -> m ()
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (BackendDetectE -> m ()) -> BackendDetectE -> m ()
forall a b. (a -> b) -> a -> b
$ Backend -> BackendDetectE
MkBackendDetectE Backend
BackendJson
            Maybe Bool
_ -> Text -> m () -> m ()
forall (m :: * -> *) a. MonadLoggerNS m => Text -> m a -> m a
addNamespace Text
"json" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathI 'TrashHome -> PathI 'TrashHome -> m ()
forall (m :: * -> *).
(HasCallStack, MonadFileReader m, MonadIORef m, MonadLoggerNS m,
 MonadMask m, MonadPathReader m, MonadPathWriter m) =>
PathI 'TrashHome -> PathI 'TrashHome -> m ()
Json.merge PathI 'TrashHome
src' PathI 'TrashHome
dest'

initalLog ::
  ( HasTrashHome env,
    MonadLoggerNS m,
    MonadReader env m
  ) =>
  Text ->
  m ()
initalLog :: forall env (m :: * -> *).
(HasTrashHome env, MonadLoggerNS m, MonadReader env m) =>
Text -> m ()
initalLog Text
start = do
  $(logTrace) Text
start
  (env -> PathI 'TrashHome) -> m (PathI 'TrashHome)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> PathI 'TrashHome
forall a. HasTrashHome a => a -> PathI 'TrashHome
getTrashHome m (PathI 'TrashHome) -> (PathI 'TrashHome -> 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
>>= \PathI 'TrashHome
th -> $(logDebug) (Text
"TrashHome: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PathI 'TrashHome -> Text
forall (i :: PathIndex). PathI i -> Text
Paths.toText PathI 'TrashHome
th)