{-# LANGUAGE OverloadedRecordDot, ScopedTypeVariables #-}

module Photoname.CopyLink
   ( createNewLink
   )
   where

import Control.Exception (try)
import Control.Monad (unless, when)
import Data.Time.LocalTime (LocalTime)
import GHC.IO.Exception (IOException)
import System.Directory (copyFile, createDirectoryIfMissing)
import System.FilePath ((</>), (<.>), takeDirectory, takeExtension)
import System.Posix (createLink, fileExist, removeLink)

import Photoname.Common (CopySwitch (v), DestPath (..),
  Extension (Extension, UseExistingExtension), MoveSwitch (v),
  NoActionSwitch (v), NoDirsSwitch (NoDirsSwitch), ParentDir (ParentDir),
  Options (copy, formatter, extension, move, noAction, noDirs, parentDir, prefix, suffix),
  Ph, Prefix (Prefix), SrcPath (SrcPath), Suffix (Suffix), ask, asks, liftIO,
  throwError)
import Photoname.Date (PhDate (ExifDate, FilenameDate, NoDateFound),
  formatDateHyphens, formatYear)
import Photoname.Log (lname, noticeM, warningM)


createNewLink :: PhDate -> SrcPath -> Ph DestPath
createNewLink :: PhDate -> SrcPath -> Ph DestPath
createNewLink PhDate
imageDate srcPath :: SrcPath
srcPath@(SrcPath String
srcFp) = do
  Options
opts <- ReaderT Options (ExceptT String IO) Options
forall r (m :: * -> *). MonadReader r m => m r
ask

  let ext :: String
ext = case Options
opts.extension of
        (Extension String
ext') -> String
ext'
        Extension
UseExistingExtension -> String -> String
takeExtension String
srcFp

  destPath :: DestPath
destPath@(DestPath String
destFp) <- case PhDate
imageDate of
    ExifDate LocalTime
lt -> LocalTime -> String -> Ph DestPath
buildDatePath LocalTime
lt String
ext
    FilenameDate LocalTime
lt -> LocalTime -> String -> Ph DestPath
buildDatePath LocalTime
lt String
ext
    PhDate
NoDateFound -> String -> Ph DestPath
forall a. String -> ReaderT Options (ExceptT String IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Could not extract any date information"

  -- Check for existence of the target file
  Bool
exists <- IO Bool -> ReaderT Options (ExceptT String IO) Bool
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT Options (ExceptT String IO) Bool)
-> IO Bool -> ReaderT Options (ExceptT String IO) Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
fileExist String
destFp
  Bool
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (ReaderT Options (ExceptT String IO) ()
 -> ReaderT Options (ExceptT String IO) ())
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Options (ExceptT String IO) ()
forall a. String -> ReaderT Options (ExceptT String IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Options (ExceptT String IO) ())
-> String -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String
"Destination " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destFp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exists!"

  -- Display what will be done
  IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
noticeM String
lname (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
srcFp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destFp

  Bool
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Options
opts.noAction.v (ReaderT Options (ExceptT String IO) ()
 -> ReaderT Options (ExceptT String IO) ())
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ do
    -- Make the target dir
    IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
destFp

    -- Make the new file
    if Options
opts.copy.v
      then IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
srcFp String
destFp
      else SrcPath -> DestPath -> ReaderT Options (ExceptT String IO) ()
tryHardLink SrcPath
srcPath DestPath
destPath

    -- If user has specified, remove the original link
    Bool
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Options
opts.move.v (ReaderT Options (ExceptT String IO) ()
 -> ReaderT Options (ExceptT String IO) ())
-> ReaderT Options (ExceptT String IO) ()
-> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$
       IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeLink String
srcFp

  DestPath -> Ph DestPath
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DestPath
destPath


tryHardLink :: SrcPath -> DestPath -> Ph ()
tryHardLink :: SrcPath -> DestPath -> ReaderT Options (ExceptT String IO) ()
tryHardLink (SrcPath String
srcFp) (DestPath String
destFp) = do
  Either IOException ()
ei <- IO (Either IOException ())
-> ReaderT Options (ExceptT String IO) (Either IOException ())
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ())
 -> ReaderT Options (ExceptT String IO) (Either IOException ()))
-> IO (Either IOException ())
-> ReaderT Options (ExceptT String 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
$ String -> String -> IO ()
createLink String
srcFp String
destFp
  (IOException -> ReaderT Options (ExceptT String IO) ())
-> (() -> ReaderT Options (ExceptT String IO) ())
-> Either IOException ()
-> ReaderT Options (ExceptT String IO) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> ReaderT Options (ExceptT String IO) ()
failureHandler () -> ReaderT Options (ExceptT String IO) ()
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either IOException ()
ei
  where
    failureHandler :: IOException -> Ph ()
    failureHandler :: IOException -> ReaderT Options (ExceptT String IO) ()
failureHandler IOException
_ = do
      IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
lname String
"Hard link failed, attempting to copy instead"
      IO () -> ReaderT Options (ExceptT String IO) ()
forall a. IO a -> ReaderT Options (ExceptT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Options (ExceptT String IO) ())
-> IO () -> ReaderT Options (ExceptT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
srcFp String
destFp


{- Construct the destination file path based on the information we have (parent
   dir, subdirs wanted or not, prefix and suffix, and the date info that was
   gathered).
-}
buildDatePath :: LocalTime -> FilePath -> Ph DestPath
buildDatePath :: LocalTime -> String -> Ph DestPath
buildDatePath LocalTime
date String
ext = do
   (Prefix String
prefixStr) <- (Options -> Prefix) -> ReaderT Options (ExceptT String IO) Prefix
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Prefix
prefix
   (Suffix String
suffixStr) <- (Options -> Suffix) -> ReaderT Options (ExceptT String IO) Suffix
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Suffix
suffix
   DateFormatter
dateFormatter <- (Options -> DateFormatter)
-> ReaderT Options (ExceptT String IO) DateFormatter
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> DateFormatter
formatter
   let fileName :: String
fileName = String
prefixStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DateFormatter
dateFormatter LocalTime
date String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffixStr

   (ParentDir String
parentDir') <- (Options -> ParentDir)
-> ReaderT Options (ExceptT String IO) ParentDir
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> ParentDir
parentDir
   (NoDirsSwitch Bool
noDirs') <- (Options -> NoDirsSwitch)
-> ReaderT Options (ExceptT String IO) NoDirsSwitch
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> NoDirsSwitch
noDirs
   DestPath -> Ph DestPath
forall a. a -> ReaderT Options (ExceptT String IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DestPath -> Ph DestPath)
-> (String -> DestPath) -> String -> Ph DestPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DestPath
DestPath (String -> Ph DestPath) -> String -> Ph DestPath
forall a b. (a -> b) -> a -> b
$ if Bool
noDirs'
      then String
parentDir' String -> String -> String
</> String
fileName String -> String -> String
<.> String
ext
      else String
parentDir' String -> String -> String
</> DateFormatter
formatYear LocalTime
date String -> String -> String
</>
         DateFormatter
formatDateHyphens LocalTime
date String -> String -> String
</> String
fileName String -> String -> String
<.> String
ext