{-# LANGUAGE ScopedTypeVariables #-}
module Photoname.CopyLink
( createNewLink
)
where
import Control.Exception ( try )
import Control.Monad ( unless, when )
import Control.Newtype.Generics ( op )
import Data.Time.LocalTime ( LocalTime )
import GHC.IO.Exception ( IOException )
import System.Directory ( copyFile, createDirectoryIfMissing )
import System.FilePath ( (</>), takeDirectory )
import System.Posix ( createLink, fileExist, removeLink )
import Text.Printf ( printf )
import Photoname.Common ( CopySwitch (..), DestPath (..), MoveSwitch (..),
NoActionSwitch (..), NoDirsSwitch (..), ParentDir (..), Options (..),
Ph, Prefix (..), SrcPath (..), Suffix (..),
ask, asks, liftIO, throwError )
import Photoname.Date
( PhDate (ExifDate, FilenameDate, NoDateFound)
, formatDateHyphens, formatDateTime, formatYear
)
import Photoname.Log ( lname, noticeM, warningM )
createNewLink :: PhDate -> SrcPath -> Ph DestPath
createNewLink :: PhDate -> SrcPath -> Ph DestPath
createNewLink PhDate
imageDate srcPath :: SrcPath
srcPath@(SrcPath FilePath
srcFp) = do
Options
opts <- ReaderT Options (ExceptT FilePath IO) Options
forall r (m :: * -> *). MonadReader r m => m r
ask
destPath :: DestPath
destPath@(DestPath FilePath
destFp) <- case PhDate
imageDate of
ExifDate LocalTime
lt -> LocalTime -> Ph DestPath
buildDatePath LocalTime
lt
FilenameDate LocalTime
lt -> LocalTime -> Ph DestPath
buildDatePath LocalTime
lt
PhDate
NoDateFound -> FilePath -> Ph DestPath
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FilePath
"Could not extract any date information"
Bool
exists <- IO Bool -> ReaderT Options (ExceptT FilePath IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT Options (ExceptT FilePath IO) Bool)
-> IO Bool -> ReaderT Options (ExceptT FilePath IO) Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
fileExist FilePath
destFp
Bool
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ())
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ReaderT Options (ExceptT FilePath IO) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> ReaderT Options (ExceptT FilePath IO) ())
-> FilePath -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Destination " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
destFp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" exists!"
IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
noticeM FilePath
lname (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
srcFp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
destFp
Bool
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Bool -> NoActionSwitch) -> NoActionSwitch -> Bool
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op Bool -> NoActionSwitch
NoActionSwitch (NoActionSwitch -> Bool)
-> (Options -> NoActionSwitch) -> Options -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> NoActionSwitch
optNoAction (Options -> Bool) -> Options -> Bool
forall a b. (a -> b) -> a -> b
$ Options
opts) (ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ())
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
destFp
if (Bool -> CopySwitch) -> CopySwitch -> Bool
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op Bool -> CopySwitch
CopySwitch (CopySwitch -> Bool) -> (Options -> CopySwitch) -> Options -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CopySwitch
optCopy (Options -> Bool) -> Options -> Bool
forall a b. (a -> b) -> a -> b
$ Options
opts
then IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
srcFp FilePath
destFp
else SrcPath -> DestPath -> ReaderT Options (ExceptT FilePath IO) ()
tryHardLink SrcPath
srcPath DestPath
destPath
Bool
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool -> MoveSwitch) -> MoveSwitch -> Bool
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op Bool -> MoveSwitch
MoveSwitch (MoveSwitch -> Bool) -> (Options -> MoveSwitch) -> Options -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MoveSwitch
optMove (Options -> Bool) -> Options -> Bool
forall a b. (a -> b) -> a -> b
$ Options
opts) (ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ())
-> ReaderT Options (ExceptT FilePath IO) ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$
IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeLink FilePath
srcFp
DestPath -> Ph DestPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure DestPath
destPath
tryHardLink :: SrcPath -> DestPath -> Ph ()
tryHardLink :: SrcPath -> DestPath -> ReaderT Options (ExceptT FilePath IO) ()
tryHardLink (SrcPath FilePath
srcFp) (DestPath FilePath
destFp) = do
Either IOException ()
ei <- IO (Either IOException ())
-> ReaderT Options (ExceptT FilePath IO) (Either IOException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ())
-> ReaderT Options (ExceptT FilePath IO) (Either IOException ()))
-> IO (Either IOException ())
-> ReaderT Options (ExceptT FilePath IO) (Either IOException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createLink FilePath
srcFp FilePath
destFp
(IOException -> ReaderT Options (ExceptT FilePath IO) ())
-> (() -> ReaderT Options (ExceptT FilePath IO) ())
-> Either IOException ()
-> ReaderT Options (ExceptT FilePath IO) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> ReaderT Options (ExceptT FilePath IO) ()
failureHandler () -> ReaderT Options (ExceptT FilePath IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either IOException ()
ei
where
failureHandler :: IOException -> Ph ()
failureHandler :: IOException -> ReaderT Options (ExceptT FilePath IO) ()
failureHandler IOException
_ = do
IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
warningM FilePath
lname FilePath
"Hard link failed, attempting to copy instead"
IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT FilePath IO) ())
-> IO () -> ReaderT Options (ExceptT FilePath IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
srcFp FilePath
destFp
buildDatePath :: LocalTime -> Ph DestPath
buildDatePath :: LocalTime -> Ph DestPath
buildDatePath LocalTime
date = do
FilePath
prefixStr <- (Options -> FilePath)
-> ReaderT Options (ExceptT FilePath IO) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FilePath -> Prefix) -> Prefix -> FilePath
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op FilePath -> Prefix
Prefix (Prefix -> FilePath) -> (Options -> Prefix) -> Options -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Prefix
optPrefix)
FilePath
suffixStr <- (Options -> FilePath)
-> ReaderT Options (ExceptT FilePath IO) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FilePath -> Suffix) -> Suffix -> FilePath
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op FilePath -> Suffix
Suffix (Suffix -> FilePath) -> (Options -> Suffix) -> Options -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Suffix
optSuffix)
let fileName :: FilePath
fileName = FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s%s%s.jpg" FilePath
prefixStr (LocalTime -> FilePath
formatDateTime LocalTime
date) FilePath
suffixStr
FilePath
parentFp <- (Options -> FilePath)
-> ReaderT Options (ExceptT FilePath IO) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FilePath -> ParentDir) -> ParentDir -> FilePath
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op FilePath -> ParentDir
ParentDir (ParentDir -> FilePath)
-> (Options -> ParentDir) -> Options -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ParentDir
optParentDir)
Bool
noDirs <- (Options -> Bool) -> ReaderT Options (ExceptT FilePath IO) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Bool -> NoDirsSwitch) -> NoDirsSwitch -> Bool
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op Bool -> NoDirsSwitch
NoDirsSwitch (NoDirsSwitch -> Bool)
-> (Options -> NoDirsSwitch) -> Options -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> NoDirsSwitch
optNoDirs)
DestPath -> Ph DestPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DestPath -> Ph DestPath)
-> (FilePath -> DestPath) -> FilePath -> Ph DestPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> DestPath
DestPath (FilePath -> Ph DestPath) -> FilePath -> Ph DestPath
forall a b. (a -> b) -> a -> b
$ if Bool
noDirs
then FilePath
parentFp FilePath -> FilePath -> FilePath
</> FilePath
fileName
else FilePath
parentFp FilePath -> FilePath -> FilePath
</> LocalTime -> FilePath
formatYear LocalTime
date FilePath -> FilePath -> FilePath
</>
LocalTime -> FilePath
formatDateHyphens LocalTime
date FilePath -> FilePath -> FilePath
</> FilePath
fileName