------------------------------------------------------------------------------
-- |
-- Module      : PhatSort.Cmd.SeqCp
-- Description : seqcp command implementation
-- Copyright   : Copyright (c) 2019-2023 Travis Cardwell
-- License     : MIT
------------------------------------------------------------------------------

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module PhatSort.Cmd.SeqCp
  ( -- * Options
    Options(..)
    -- * API
  , runIO
  , run
  ) where

-- https://hackage.haskell.org/package/base
import Control.Monad (forM, forM_, unless, when)
import Data.Char (toLower)
import Data.List (dropWhileEnd, isPrefixOf, partition, sortBy)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty)
import Data.Ord (comparing)

-- https://hackage.haskell.org/package/filepath
import System.FilePath ((</>), splitDirectories, takeFileName)

-- https://hackage.haskell.org/package/MonadRandom
import Control.Monad.Random.Class (MonadRandom)

-- https://hackage.haskell.org/package/random-shuffle
import System.Random.Shuffle (shuffleM)

-- (phatsort)
import qualified PhatSort.Monad.FileSystem as FS
import PhatSort.Monad.FileSystem (MonadFileSystem)
import qualified PhatSort.Monad.Stdio as Stdio
import PhatSort.Monad.Stdio (MonadStdio)
import qualified PhatSort.Monad.Sync as Sync
import PhatSort.Monad.Sync (MonadSync)
import qualified PhatSort.Monad.Trans.Error as Error
import PhatSort.Monad.Trans.Error (ErrorT)
import qualified PhatSort.Script as Script
import PhatSort.SortOptions
  ( SortCase(CaseInsensitive, CaseSensitive)
  , SortFirst(FirstDirs, FirstFiles, FirstNone)
  , SortOrder(OrderName, OrderRandom, OrderTime)
  )

------------------------------------------------------------------------------
-- $Options

data Options
  = Options
    { Options -> SortCase
optCase        :: !SortCase
    , Options -> SortFirst
optFirst       :: !SortFirst
    , Options -> Bool
optSync        :: !Bool
    , Options -> SortOrder
optOrder       :: !SortOrder
    , Options -> Bool
optReverse     :: !Bool
    , Options -> Bool
optScript      :: !Bool
    , Options -> Bool
optVerbose     :: !Bool
    , Options -> NonEmpty FilePath
optSources     :: !(NonEmpty FilePath)
    , Options -> FilePath
optDestination :: !FilePath
    }
  deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> FilePath
$cshow :: Options -> FilePath
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show

------------------------------------------------------------------------------
-- $API

-- | Run the command in the 'IO' monad
runIO :: Options -> IO (Either String ())
runIO :: Options -> IO (Either FilePath ())
runIO = forall (m :: * -> *) a.
Monad m =>
ErrorT m a -> m (Either FilePath a)
Error.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m) =>
Options -> ErrorT m ()
run

------------------------------------------------------------------------------

-- | Run the command
run
  :: forall m
   . (MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m)
  => Options
  -> ErrorT m ()
run :: forall (m :: * -> *).
(MonadFileSystem m, MonadRandom m, MonadStdio m, MonadSync m) =>
Options -> ErrorT m ()
run Options{Bool
FilePath
NonEmpty FilePath
SortOrder
SortFirst
SortCase
optDestination :: FilePath
optSources :: NonEmpty FilePath
optVerbose :: Bool
optScript :: Bool
optReverse :: Bool
optOrder :: SortOrder
optSync :: Bool
optFirst :: SortFirst
optCase :: SortCase
optDestination :: Options -> FilePath
optSources :: Options -> NonEmpty FilePath
optVerbose :: Options -> Bool
optScript :: Options -> Bool
optReverse :: Options -> Bool
optOrder :: Options -> SortOrder
optSync :: Options -> Bool
optFirst :: Options -> SortFirst
optCase :: Options -> SortCase
..} = [Target] -> ExceptT FilePath m ()
copyTargets forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadFileSystem m =>
NonEmpty FilePath -> FilePath -> ErrorT m [Target]
getArgTargets NonEmpty FilePath
optSources FilePath
optDestination
  where
    copyDir :: FilePath -> FilePath -> FilePath -> ErrorT m ()
    copyDir :: FilePath -> FilePath -> FilePath -> ExceptT FilePath m ()
copyDir FilePath
argPath FilePath
srcPath FilePath
dstPath = do
      FilePath -> ExceptT FilePath m ()
putProgress FilePath
argPath
      FilePath -> ExceptT FilePath m ()
mkDir FilePath
dstPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT FilePath m ()
sync
      [Target] -> ExceptT FilePath m ()
copyTargets forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> FilePath -> FilePath -> ErrorT m [Target]
getDirTargets FilePath
argPath FilePath
srcPath FilePath
dstPath

    copyFile :: FilePath -> FilePath -> FilePath -> ErrorT m ()
    copyFile :: FilePath -> FilePath -> FilePath -> ExceptT FilePath m ()
copyFile FilePath
argPath FilePath
srcPath FilePath
dstPath = do
      FilePath -> ExceptT FilePath m ()
putProgress FilePath
argPath
      FilePath -> FilePath -> ExceptT FilePath m ()
cp FilePath
srcPath FilePath
dstPath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT FilePath m ()
sync

    copyTargets :: [Target] -> ErrorT m ()
    copyTargets :: [Target] -> ExceptT FilePath m ()
copyTargets [Target]
targets = do
      [Target]
sortedTargets <- [Target] -> ErrorT m [Target]
sortTargets [Target]
targets
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Target]
sortedTargets forall a b. (a -> b) -> a -> b
$ \Target{FilePath
FileStatus
targetStatus :: Target -> FileStatus
targetName :: Target -> FilePath
targetDstPath :: Target -> FilePath
targetSrcPath :: Target -> FilePath
targetArgPath :: Target -> FilePath
targetStatus :: FileStatus
targetName :: FilePath
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
..} ->
        if FileStatus -> Bool
FS.isDirectory FileStatus
targetStatus
          then FilePath -> FilePath -> FilePath -> ExceptT FilePath m ()
copyDir FilePath
targetArgPath FilePath
targetSrcPath FilePath
targetDstPath
          else FilePath -> FilePath -> FilePath -> ExceptT FilePath m ()
copyFile FilePath
targetArgPath FilePath
targetSrcPath FilePath
targetDstPath

    cp :: FilePath -> FilePath -> ErrorT m ()
    cp :: FilePath -> FilePath -> ExceptT FilePath m ()
cp FilePath
srcPath FilePath
dstPath
      | Bool
optScript =
          forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"cp", FilePath
srcPath, FilePath
dstPath]
      | Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> FilePath -> m (Either IOError ())
FS.copyFile FilePath
srcPath FilePath
dstPath

    mkDir :: FilePath -> ErrorT m ()
    mkDir :: FilePath -> ExceptT FilePath m ()
mkDir FilePath
path
      | Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"mkdir", FilePath
path]
      | Bool
otherwise = forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError ())
FS.createDirectory FilePath
path

    putProgress :: FilePath -> ErrorT m ()
    putProgress :: FilePath -> ExceptT FilePath m ()
putProgress FilePath
path
      | Bool -> Bool
not Bool
optVerbose = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"echo", FilePath
path]
      | Bool
otherwise = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn FilePath
path

    sortTargets :: [Target] -> ErrorT m [Target]
    sortTargets :: [Target] -> ErrorT m [Target]
sortTargets [Target]
targets =
      let compareNames :: Target -> Target -> Ordering
compareNames = case SortCase
optCase of
            SortCase
CaseSensitive -> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Target -> FilePath
targetName
            SortCase
CaseInsensitive -> forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> FilePath
targetName)
          compareTimes :: Target -> Target -> Ordering
compareTimes = forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FileStatus -> EpochTime
FS.modificationTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> FileStatus
targetStatus)
          reverse' :: [a] -> [a]
reverse' = if Bool
optReverse then forall a. [a] -> [a]
reverse else forall a. a -> a
id
          go :: [Target] -> m [Target]
go = case SortOrder
optOrder of
            SortOrder
OrderName -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Target -> Target -> Ordering
compareNames
            SortOrder
OrderTime -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Target -> Target -> Ordering
compareTimes
            SortOrder
OrderRandom -> forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM
          ([Target]
dirTargets, [Target]
fileTargets) =
            forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (FileStatus -> Bool
FS.isDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> FileStatus
targetStatus) [Target]
targets
      in  forall (m :: * -> *) a. Monad m => m a -> ErrorT m a
Error.lift forall a b. (a -> b) -> a -> b
$ case SortFirst
optFirst of
            SortFirst
FirstNone -> [Target] -> m [Target]
go [Target]
targets
            SortFirst
FirstDirs -> forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Target] -> m [Target]
go [Target]
dirTargets forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Target] -> m [Target]
go [Target]
fileTargets
            SortFirst
FirstFiles -> forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Target] -> m [Target]
go [Target]
fileTargets forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Target] -> m [Target]
go [Target]
dirTargets

    sync :: ErrorT m ()
    sync :: ExceptT FilePath m ()
sync
      | Bool -> Bool
not Bool
optSync = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
optScript = forall (m :: * -> *). MonadStdio m => FilePath -> m ()
Stdio.putStrLn forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Script.formatCommand [FilePath
"sync"]
      | Bool
otherwise = forall (m :: * -> *). MonadSync m => m ()
Sync.sync

------------------------------------------------------------------------------
-- $Internal

-- | Target file or directory
data Target
  = Target
    { Target -> FilePath
targetArgPath :: !FilePath  -- ^ path for verbose and errors
    , Target -> FilePath
targetSrcPath :: !FilePath  -- ^ absolute source path
    , Target -> FilePath
targetDstPath :: !FilePath  -- ^ absolute destination path
    , Target -> FilePath
targetName    :: !FilePath  -- ^ file or directory name
    , Target -> FileStatus
targetStatus  :: !FS.FileStatus
    }

------------------------------------------------------------------------------

-- | Create 'Target's for arguments, performing checks
getArgTargets
  :: MonadFileSystem m
  => NonEmpty FilePath  -- ^ sources
  -> FilePath           -- ^ destination directory
  -> ErrorT m [Target]
getArgTargets :: forall (m :: * -> *).
MonadFileSystem m =>
NonEmpty FilePath -> FilePath -> ErrorT m [Target]
getArgTargets NonEmpty FilePath
sources FilePath
destDir = do
    FilePath
destPath <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FilePath)
FS.makeAbsolute forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
destDir
    FileStatus
destStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus FilePath
destPath
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileStatus -> Bool
FS.isDirectory FileStatus
destStatus) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"not a directory: " forall a. [a] -> [a] -> [a]
++ FilePath
destDir
    let destDirs :: [FilePath]
destDirs = FilePath -> [FilePath]
splitDirectories FilePath
destPath
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty FilePath
sources) forall a b. (a -> b) -> a -> b
$ \FilePath
targetArgPath -> do
      FilePath
targetSrcPath <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FilePath)
FS.makeAbsolute forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
targetArgPath
      let targetName :: FilePath
targetName = ShowS
takeFileName FilePath
targetSrcPath
          targetDstPath :: FilePath
targetDstPath = FilePath
destPath FilePath -> ShowS
</> FilePath
targetName
      FileStatus
targetStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus FilePath
targetSrcPath
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileStatus -> Bool
FS.isDirectory FileStatus
targetStatus) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> [FilePath]
splitDirectories FilePath
targetSrcPath forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [FilePath]
destDirs) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$
            FilePath
"source directory above target directory: " forall a. [a] -> [a] -> [a]
++ FilePath
targetArgPath
      Bool
exists <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError Bool)
FS.doesPathExist FilePath
targetDstPath
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => FilePath -> ErrorT m a
Error.throw forall a b. (a -> b) -> a -> b
$ FilePath
"already exists: " forall a. [a] -> [a] -> [a]
++ FilePath
targetDstPath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Target{FilePath
FileStatus
targetStatus :: FileStatus
targetDstPath :: FilePath
targetName :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
targetStatus :: FileStatus
targetName :: FilePath
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
..}

------------------------------------------------------------------------------

-- | Get 'Target's for entries in a directory
getDirTargets
  :: MonadFileSystem m
  => FilePath  -- ^ path for verbose and errors
  -> FilePath  -- ^ absolute source path
  -> FilePath  -- ^ absolute destination path
  -> ErrorT m [Target]
getDirTargets :: forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> FilePath -> FilePath -> ErrorT m [Target]
getDirTargets FilePath
argDir FilePath
srcDir FilePath
dstDir = do
    [FilePath]
names <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError [FilePath])
FS.listDirectory FilePath
srcDir
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
names forall a b. (a -> b) -> a -> b
$ \FilePath
targetName -> do
      let targetArgPath :: FilePath
targetArgPath = FilePath
argDir FilePath -> ShowS
</> FilePath
targetName
          targetSrcPath :: FilePath
targetSrcPath = FilePath
srcDir FilePath -> ShowS
</> FilePath
targetName
          targetDstPath :: FilePath
targetDstPath = FilePath
dstDir FilePath -> ShowS
</> FilePath
targetName
      FileStatus
targetStatus <- forall e (m :: * -> *) a.
(Exception e, Monad m) =>
m (Either e a) -> ErrorT m a
Error.errorTE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFileSystem m =>
FilePath -> m (Either IOError FileStatus)
FS.getFileStatus FilePath
targetSrcPath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Target{FilePath
FileStatus
targetStatus :: FileStatus
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
targetName :: FilePath
targetStatus :: FileStatus
targetName :: FilePath
targetDstPath :: FilePath
targetSrcPath :: FilePath
targetArgPath :: FilePath
..}