1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
{-# LANGUAGE QuasiQuotes #-}
module MyTools where
import Control.Applicative (some)
import Control.Exception (Exception, IOException, throwIO)
import Control.Exception.Base (try)
import Data.Error.Tree
import Data.List qualified as List
import Data.Text qualified as Text
import FieldParser qualified as Field
import Label
import MyLabel
import MyPrelude
import Options.Applicative.Builder.Completer (requote)
import Options.Applicative.Simple (simpleOptions)
import Options.Applicative.Simple qualified as Opts
import Options.Applicative.Types qualified as Opts.Types
import Options.Applicative qualified as OptParse
import Parse (Parse, fieldParser, runParse)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import System.Directory qualified as Dir
import System.Environment qualified
import System.FilePath.Posix ((</>))
import System.FilePath.Posix qualified as File
import System.Process qualified as Proc
import Tool
copyMain :: IO ()
copyMain = do
((), run) <-
simpleOptions
"latest"
"copy"
"Various ways of copying files"
(pure ())
( do
Opts.addCommand
"template"
"Use the given file as a template and create new file with the given name in the same directory"
copyAsTemplate
( do
Opts.strArgument (Opts.metavar "FILE" <> Opts.completer completeFile)
-- TODO: this is a hack to be able to use the file in the next argument (it leads to the argument not being in the usage message)
& thenParser
( \file -> do
name <-
Opts.strArgument
( Opts.metavar "NAME"
<> Opts.completer
( Opts.listCompleter
[ File.takeFileName file,
File.takeFileName file <> ".bak",
File.takeFileName file <> "_copy"
]
)
)
pure (t2 #file file #name name)
)
)
)
run
completeFile :: Opts.Completer
completeFile = Opts.mkCompleter $ \word -> do
isFish <- System.Environment.getEnv "SHELL" <&> ("fish" `List.isInfixOf`)
if isFish
then do
let cmd =
unwords
[ "complete",
"-C",
-- loool (via the impl of __fish_complete_path), probably extremely buggy
"\"'' " <> requote word <> "\""
]
Proc.readProcess "fish" ["--private", "--no-config", "-c", cmd] "" <&> lines & try @IOException <&> hush <&> fromMaybe []
else do
let cmd = unwords ["compgen", "-A", "file", "--", requote word]
Proc.readProcess "bash" ["-c", cmd] "" <&> lines & try @IOException <&> hush <&> fromMaybe []
thenParser :: (a -> Opts.Parser b) -> Opts.Parser a -> Opts.Parser b
thenParser f a = Opts.Types.BindP a f
assertMsg :: Bool -> Text -> IO ()
assertMsg b msg = unless b $ exitWithMessage msg
warnMsg :: Bool -> Text -> IO ()
warnMsg b msg = unless b $ putStderrLn [fmt|Warning: {msg}|]
copyAsTemplate ::
(HasField "file" r FilePath, HasField "name" r FilePath) =>
r ->
IO ()
copyAsTemplate opts = do
canon <- Dir.canonicalizePath opts.file
isFile <- Dir.doesFileExist canon
assertMsg isFile $ [fmt|File does not exist or is a directory: {canon}|]
let dir = File.takeDirectory canon
let finalPath = dir </> opts.name
targetExists <- Dir.doesFileExist finalPath
assertMsg (not targetExists) $ [fmt|Target file already exists: {finalPath}|]
Dir.copyFile canon finalPath
putStrLn finalPath
cameraMain :: IO ()
cameraMain = do
tools <- readToolsJson (lbl #toolsEnvVar "CAMERA_TOOLS") $ do
exiftool <- readTool "exiftool"
pure $ lbl #exiftool exiftool
((), run) :: ((), IO ()) <-
simpleOptions
"latest"
"camera"
"Tooling to deal with the files from my camera"
(pure ())
( do
Opts.addSubCommands
"set-creation-date"
"set the creation date of the given media file(s) in the mtime and exif metadata"
( do
Opts.addCommand
"copy-single-file"
"Set the creation date of the target file to the creation date of the source file, using exiftool"
( \dat -> do
cameraTransferCreationDateMetadata tools dat
>>= unwrapIOError
)
( do
from_cdate <- Opts.strArgument (Opts.metavar "FROM_CDATE" <> Opts.completer completeFile)
to_exif <- Opts.strArgument (Opts.metavar "TO_EXIF" <> Opts.completer completeFile)
pure $ t2 #from_cdate from_cdate #to_exif to_exif
)
Opts.addCommand
"copy-dir"
"Given a source directory and a list of target files, copy the creation date into the files of the target directory that have the same filename (case insensitive) as files in the source directory, using exiftool. This is useful for converting a subset of the camera videos via handbrake, which does not copy the creation date into the metadata."
( \dat -> do
cameraTransferCreationDateMetadataDir tools dat
>>= unwrapIOErrorTree
)
( do
source_dir <- Opts.strArgument (Opts.metavar "SOURCE_DIR" <> Opts.completer completeFile)
to_dir <- some $ Opts.strArgument (Opts.metavar "TARGET_FILES.." <> Opts.completer completeFile)
pure $ t2 #source_dir source_dir #to_exif to_dir
)
)
)
run
cameraTransferCreationDateMetadataDir :: (HasField "exiftool" dat Tool) => dat -> T2 "source_dir" FilePath "to_exif" [FilePath] -> IO (Either ErrorTree ())
cameraTransferCreationDateMetadataDir tools dat = tryErrorTree $ do
sourceDir <- Dir.canonicalizePath dat.source_dir
isSourceDir <- Dir.doesDirectoryExist sourceDir
assertThrowError isSourceDir $ [fmt|Source directory does not exist: {sourceDir}|]
-- iterate over the target files, asserting that the source file exists in the source directory, collecting an error tree; if the target file does not exist, we just ignore it (so that the original camera dir can keep all the original videos)
targetFiles <- dat.to_exif & traverse Dir.canonicalizePath
targetFiles
& foldMap
( \targetFile -> do
isTargetFile <- Dir.doesFileExist targetFile
if isTargetFile
then pure [targetFile]
else do
-- target files are listed by the user, so they are allowed to not exist (we just ignore them)
putStderrLn [fmt|Warning: Target file does not exist: {targetFile}|]
pure []
)
let fileNameLower fn = fn & File.takeFileName & stringToText & Text.toLower
sourceDirContents <-
Dir.listDirectory sourceDir
<&> map (sourceDir </>)
sourceDirContents & \case
IsEmpty -> throwError' "Source directory is empty"
IsNonEmpty sourceFiles -> do
-- Check if the target files exist in the source directory, ignoring case
sourceFiles
& foldMap
( \sourceFile -> do
let sourceFileName = fileNameLower sourceFile
targetFiles
& List.find (\tf -> fileNameLower tf == sourceFileName)
& \case
Nothing -> []
Just targetFile -> [t2 #from_cdate sourceFile #to_exif targetFile]
)
-- Now we have a list of source files and their matching target files
& traverse_ (ExceptT . cameraTransferCreationDateMetadata tools)
& runExceptT
>>= expectIOError "Error setting creation date for target file"
data MyError = MyError Error
deriving stock (Show)
instance Exception MyError
data MyErrorTree = MyErrorTree ErrorTree
deriving stock (Show)
instance Exception MyErrorTree
tryError :: IO a -> IO (Either Error a)
tryError act =
try @MyError act <&> \case
Left (MyError msg) -> Left msg
Right res -> Right res
-- | Catch ErrorTrees, returning an Either type. If a single Error is thrown, catch as well and wrap in ErrorTree.
tryErrorTree :: IO a -> IO (Either ErrorTree a)
tryErrorTree act =
( try @MyErrorTree act >>= \case
Left (MyErrorTree msg) -> pure $ Left msg
Right res -> pure $ Right res
)
& try @MyError
>>= \case
Left (MyError msg) -> pure $ Left $ singleError msg
Right res -> pure res
assertThrowError :: Bool -> Error -> IO ()
assertThrowError b msg = unless b $ throwIO $ MyError msg
assertThrowErrorTree :: Bool -> ErrorTree -> IO ()
assertThrowErrorTree b msg = unless b $ throwIO $ MyErrorTree msg
throwError' :: Error -> IO ()
throwError' msg = throwIO $ MyError msg
throwErrorTree :: ErrorTree -> IO ()
throwErrorTree msg = throwIO $ MyErrorTree msg
{-
exiftool "-CreateDate="(stat --format='%Y' /run/media/philip/3632-3861/PRIVATE/M4ROOT/CLIP/C0001.MP4 | date --date "@"(stat --format='%Y' /run/media/philip/3632-3861/PRIVATE/M4ROOT/CLIP/C0001.MP4) +"%Y-%m-%d %H:%M:%S") ~/tmp/video/C0001.mp4
-}
cameraTransferCreationDateMetadata ::
(HasField "exiftool" dat Tool) =>
dat ->
T2 "from_cdate" FilePath "to_exif" FilePath ->
IO (Either Error ())
cameraTransferCreationDateMetadata tools dat = tryError $ do
canonFrom <- Dir.canonicalizePath dat.from_cdate
canonTo <- Dir.canonicalizePath dat.to_exif
isFromFile <- Dir.doesFileExist canonFrom
isToFile <- Dir.doesFileExist canonTo
assertThrowError isFromFile $ [fmt|Source file does not exist: {canonFrom}|]
assertThrowError isToFile $ [fmt|Target file does not exist: {canonTo}|]
-- Get the creation date of the source file cdate using stat and date
creationDate' <- parseProcess (lmap (Text.strip . stringToText) $ Parse.fieldParser Field.decimalNatural) "stat" ["--format=%Y", canonFrom] ""
creationDate <- Proc.readProcess "date" ["--date=@" <> show creationDate', "+%Y-%m-%d %H:%M:%S"] ""
-- Set the creation date on the target file
let args = ["-CreateDate=" <> creationDate, canonTo]
Proc.callProcess tools.exiftool.toolPath args
-- also set the mdate of the target file
Dir.setModificationTime canonTo {- UtcTime from unix timestamp -} $
posixSecondsToUTCTime $
fromIntegral @Natural @POSIXTime creationDate'
putStderrLn [fmt|Set creation date of {canonTo} to {creationDate}|]
parseProcess :: Parse String a -> FilePath -> [String] -> String -> IO a
parseProcess parser cmd args input = do
output <- Proc.readProcess cmd args input
Parse.runParse [fmt|Cannot parse output of "{cmd}"|] parser output
& unwrapIOErrorTree
|