Publish photo-hs

Signed-off-by: magic_rb <magic_rb@redalder.org>

overlays/photo-hs/.gitignore

@@ -0,0 +1 @@
+percept

overlays/photo-hs/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for photo-hs
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

overlays/photo-hs/LICENSE

@@ -0,0 +1,165 @@
+                  GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+  This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+  0. Additional Definitions.
+
+  As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+  "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+  An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+  A "Combined Work" is a work produced by combining or linking an
+Application with the Library.  The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+  The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+  The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+  1. Exception to Section 3 of the GNU GPL.
+
+  You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+  2. Conveying Modified Versions.
+
+  If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+   a) under this License, provided that you make a good faith effort to
+   ensure that, in the event an Application does not supply the
+   function or data, the facility still operates, and performs
+   whatever part of its purpose remains meaningful, or
+
+   b) under the GNU GPL, with none of the additional permissions of
+   this License applicable to that copy.
+
+  3. Object Code Incorporating Material from Library Header Files.
+
+  The object code form of an Application may incorporate material from
+a header file that is part of the Library.  You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+   a) Give prominent notice with each copy of the object code that the
+   Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the object code with a copy of the GNU GPL and this license
+   document.
+
+  4. Combined Works.
+
+  You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+   a) Give prominent notice with each copy of the Combined Work that
+   the Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the Combined Work with a copy of the GNU GPL and this license
+   document.
+
+   c) For a Combined Work that displays copyright notices during
+   execution, include the copyright notice for the Library among
+   these notices, as well as a reference directing the user to the
+   copies of the GNU GPL and this license document.
+
+   d) Do one of the following:
+
+       0) Convey the Minimal Corresponding Source under the terms of this
+       License, and the Corresponding Application Code in a form
+       suitable for, and under terms that permit, the user to
+       recombine or relink the Application with a modified version of
+       the Linked Version to produce a modified Combined Work, in the
+       manner specified by section 6 of the GNU GPL for conveying
+       Corresponding Source.
+
+       1) Use a suitable shared library mechanism for linking with the
+       Library.  A suitable mechanism is one that (a) uses at run time
+       a copy of the Library already present on the user's computer
+       system, and (b) will operate properly with a modified version
+       of the Library that is interface-compatible with the Linked
+       Version.
+
+   e) Provide Installation Information, but only if you would otherwise
+   be required to provide such information under section 6 of the
+   GNU GPL, and only to the extent that such information is
+   necessary to install and execute a modified version of the
+   Combined Work produced by recombining or relinking the
+   Application with a modified version of the Linked Version. (If
+   you use option 4d0, the Installation Information must accompany
+   the Minimal Corresponding Source and Corresponding Application
+   Code. If you use option 4d1, you must provide the Installation
+   Information in the manner specified by section 6 of the GNU GPL
+   for conveying Corresponding Source.)
+
+  5. Combined Libraries.
+
+  You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+   a) Accompany the combined library with a copy of the same work based
+   on the Library, uncombined with any other library facilities,
+   conveyed under the terms of this License.
+
+   b) Give prominent notice with the combined library that part of it
+   is a work based on the Library, and explaining where to find the
+   accompanying uncombined form of the same work.
+
+  6. Revised Versions of the GNU Lesser General Public License.
+
+  The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+  Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+  If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.

overlays/photo-hs/exe/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import MyLib (libMain)
+
+main :: IO ()
+main = libMain

overlays/photo-hs/lib/.dir-locals.el

@@ -0,0 +1,4 @@
+;;; Directory Local Variables            -*- no-byte-compile: t -*-
+;;; For more information see (info "(emacs) Directory Variables")
+
+((haskell-mode . ((lsp-lens-enable . nil))))

overlays/photo-hs/lib/AppData.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances #-}
+module AppData
+  ( AppData(..)
+  , askPhotoDir
+  , askStoreDir
+  ) where
+
+import Options (Options)
+import Constants qualified
+import Data.Text qualified as T
+import System.FilePath ((</>))
+import Data.Functor ((<&>))
+import Control.Monad.Reader.Class (MonadReader(..), asks)
+
+data AppData
+  = AppData
+  { options :: Options
+  , photoDir :: FilePath
+  }
+
+-- instance MonadReader AppData m => MonadReader SqlBackend m where
+--   ask :: MonadReader AppData m => m SqlBackend
+--   ask = ask @AppData <&> \appdata -> appdata.conn
+--   local :: MonadReader AppData m => (SqlBackend -> SqlBackend) -> m a -> m a
+--   local f = local @AppData (\appdata -> appdata { conn = f appdata.conn })
+
+askPhotoDir :: (MonadReader AppData m) => m FilePath
+askPhotoDir = asks (\s -> s.photoDir)
+
+askStoreDir :: (MonadReader AppData m) => m FilePath
+askStoreDir = askPhotoDir <&> (</> T.unpack Constants.storeDirectory)
+
+

overlays/photo-hs/lib/Commands.hs

@@ -0,0 +1,11 @@
+module Commands
+  ( module Commands.AddPhoto
+  , module Commands.Init
+  , module Commands.List
+  , module Commands.EditMeta
+  ) where
+
+import Commands.AddPhoto
+import Commands.Init
+import Commands.List
+import Commands.EditMeta

overlays/photo-hs/lib/Commands/AddPhoto.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Commands.AddPhoto
+  ( commandAddPhoto
+  ) where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger (MonadLogger)
+import Control.Monad.Reader (MonadReader)
+import AppData (AppData, askStoreDir)
+import Data.Text (Text)
+import Data.Time (ZonedTime)
+import Crypto.Hash (Digest, SHA256)
+import Photo (getPhotoExtension, Photo (..))
+import Data.Functor ((<&>))
+import Control.Applicative ((<|>))
+import System.FilePath (takeBaseName)
+import qualified Data.Text as T
+import Data.Maybe (fromMaybe)
+import Data.Time.LocalTime (zonedTimeToUTC)
+import Git.Annex (gitAnnexAdd)
+import Control.Exception (throw)
+import Percept.Error (PhotoException(..))
+import qualified Schema as S
+import Control.Monad.Extra (forM_, whenM)
+import Database.Persist.Monad (MonadSqlQuery)
+import qualified System.Directory as D
+import Git (gitCommit)
+import qualified Photo as P
+import Percept.Operations (calculateImageDigest, readImageCreationUTCTime, inStorePathForPhoto, savePhotoFile, saveMetadataFile, cachePhoto)
+import Database.Esqueleto.Experimental.Monad
+
+commandAddPhoto
+  :: (MonadIO m, MonadLogger m, MonadSqlQuery m, MonadReader AppData m)
+  => FilePath
+  -> Maybe Text
+  -> [P.Tag]
+  -> Maybe ZonedTime
+  -> Maybe Text
+  -> m (Digest SHA256)
+commandAddPhoto filePath name tags cmdlineCreationTime description = do
+  digest <- calculateImageDigest filePath
+  creationTime <- readImageCreationUTCTime filePath <&> (<|> cmdlineCreationTime)
+
+  case creationTime of
+    Just imageCreationTime -> do
+      let
+        photo
+          = Photo
+          { hash = P.Hash . T.pack . show $ digest
+          , name = fromMaybe (T.pack $ takeBaseName filePath) name
+          , tags = tags
+          , date = zonedTimeToUTC imageCreationTime
+          , description = fromMaybe "" description
+          , imageType = T.drop 1 $ getPhotoExtension filePath
+          }
+      storeDir <- askStoreDir
+      photoStorePath <- inStorePathForPhoto photo
+
+      whenM (liftIO $ D.doesFileExist photoStorePath) (throw (PhotoAlreadyExists photo))
+
+      savePhotoFile filePath photo
+      saveMetadataFile photo
+
+      cachePhoto photo
+
+      gitAnnexAdd storeDir photoStorePath
+      _ <- gitCommit (T.pack storeDir) ("Add " <> photo.name)
+
+      pure digest
+    Nothing -> throw UnknownCreationTime
+

overlays/photo-hs/lib/Commands/Annex.hs

@@ -0,0 +1,3 @@
+module Commands.Annex
+  (
+  ) where

overlays/photo-hs/lib/Commands/Debug.hs

@@ -0,0 +1,4 @@
+module Commands.Debug
+  (
+  ) where
+

overlays/photo-hs/lib/Commands/EditMeta.hs

@@ -0,0 +1,38 @@
+module Commands.EditMeta
+  ( commandEditMeta
+  ) where
+import Control.Monad.IO.Class (MonadIO)
+import Database.Persist.Monad.Class (MonadSqlQuery)
+import qualified Options as O
+import qualified Photo as P
+import Percept.Operations (readMetadataFile, saveMetadataFile, cachePhoto, inStorePathForPhoto, inStorePathForMetadata)
+import AppData (AppData, askStoreDir)
+import Control.Monad.Reader.Class (MonadReader)
+import qualified Data.List as L
+import Git (gitAdd, gitCommit)
+import qualified Data.Text as T
+import Data.Functor ((<&>))
+import Percept.Util (handleGitError)
+
+commandEditMeta :: (MonadIO m, MonadReader AppData m, MonadSqlQuery m) => P.Hash -> O.EditOperation -> m P.Photo
+commandEditMeta hash editOp = do
+  photo <- readMetadataFile hash
+
+  let
+    newPhoto =
+      case editOp of
+        O.AddTags tags -> photo { P.tags = photo.tags `L.union` tags }
+        O.RemoveTags tags -> photo { P.tags = photo.tags L.\\ tags }
+        O.ClearTags -> photo { P.tags = [] }
+        O.SetTags tags -> photo { P.tags = tags }
+        O.SetName name -> photo { P.name = name }
+        O.SetDescription description -> photo { P.description = description }
+
+  saveMetadataFile newPhoto
+  cachePhoto newPhoto
+
+  storeDir <- askStoreDir <&> T.pack
+  inStorePathForMetadata photo.hash >>= gitAdd storeDir . T.pack >>= handleGitError
+  gitCommit storeDir ("Edit metadata of " <> photo.name ) >>= handleGitError
+
+  pure newPhoto

overlays/photo-hs/lib/Commands/Git.hs

@@ -0,0 +1,3 @@
+module Commands.Git
+  (
+  ) where

overlays/photo-hs/lib/Commands/Init.hs

@@ -0,0 +1,39 @@
+module Commands.Init
+  ( commandInit
+  ) where
+import Control.Monad.IO.Class (MonadIO (..))
+import Options (Options (..))
+import Constants qualified
+import qualified Data.Text as T
+import System.FilePath ((</>))
+import System.Process.Typed (ExitCode (..))
+import qualified System.Directory as D
+import Percept.Util (handleExitCode, (<$/>), handleGitError)
+import Control.Exception (throw, bracket)
+import Percept.Error (PhotoException(..))
+import Git.Annex (gitAnnexInit)
+import Git (gitInit, gitAdd, gitCommit)
+import qualified Database.Sqlite as SqlLite
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+
+commandInit :: (MonadIO m) => Options -> Text -> m ()
+commandInit opts photoDir = do
+  let
+    cmd = ("git", ["init"])
+    storePath = photoDir <$/> Constants.storeDirectory
+    dryRun = opts.dryRun
+
+  if not dryRun then do
+    liftIO $ D.createDirectoryIfMissing True (T.unpack photoDir)
+    gitInit (T.unpack storePath) >>= handleGitError
+    gitAnnexInit (T.unpack storePath)
+
+    -- initialize database
+    liftIO $ bracket (SqlLite.open (storePath <$/> Constants.sqlFile)) SqlLite.close (const $ pure ())
+
+    liftIO $ T.writeFile (T.unpack $ storePath <$/> Constants.gitignoreFile) Constants.gitignoreText
+    gitAdd storePath Constants.gitignoreFile >>= handleGitError
+    gitCommit storePath "Initial commit" >>= handleGitError
+  else
+    liftIO . putStrLn $ "Would execute `" ++ unwords (uncurry (:) cmd) ++ "`"

overlays/photo-hs/lib/Commands/List.hs

@@ -0,0 +1,81 @@
+module Commands.List
+  ( commandList
+  ) where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Photo as P
+import qualified Options as O
+import Database.Esqueleto.Experimental (where_, (^.), (==.), table, from, Entity (..), val, Value (..), SqlExpr, SqlString, notExists, valList, (&&.), notIn, with, (/=.), except_, (!=.), selectQuery, SqlQuery, in_, distinct, union_, toSqlSetOperation, exists)
+import Database.Esqueleto.Experimental.Monad (select)
+import Database.Esqueleto.Internal.Internal (unsafeSqlBinOp, unsafeSqlFunctionParens)
+import qualified Schema as S
+import Database.Persist.Monad.Class (MonadSqlQuery)
+import Data.Text (Text)
+import Control.Monad (void, forM)
+
+-- | @LIKE@ operator.
+regexp :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)
+regexp a b = unsafeSqlFunctionParens "REGEXP" (a, b)
+
+commandList :: (MonadIO m, MonadSqlQuery m) => O.Filter -> m [P.Photo]
+commandList filter = do
+  photos <- select do
+    photos <- from $ table @S.Photo
+    case filter.name of
+      Just name ->
+        if filter.useRegex then
+          where_ (photos ^. S.PhotoName `regexp` val name)
+        else
+          where_ (photos ^. S.PhotoName ==. val name)
+      Nothing -> pure ()
+
+    case filter.tags of
+      Just (O.TagsAll (tag:tags)) ->
+        where_ $ notExists $ void $ from $
+          ( let
+              tagToSet = toSqlSetOperation . pure @(SqlQuery) . val . P.unTag
+            in
+             foldr union_ (tagToSet tag) (map tagToSet tags)
+          )
+          `except_`
+          (do
+              taggedPhotos <- from $ table @S.TaggedPhoto
+
+              where_ ( taggedPhotos ^. S.TaggedPhotoPhotoHash ==. photos ^. S.PhotoHash
+                   &&. taggedPhotos ^. S.TaggedPhotoTagText `in_` (valList $ map P.unTag (tag:tags))
+                     )
+
+              pure (taggedPhotos ^. S.TaggedPhotoTagText)
+          )
+
+      Just (O.TagsSome tags) ->
+        where_ $ exists $ void $ from $
+          do
+            taggedPhotos <- from $ table @S.TaggedPhoto
+
+            where_ ( taggedPhotos ^. S.TaggedPhotoPhotoHash ==. photos ^. S.PhotoHash
+                 &&. taggedPhotos ^. S.TaggedPhotoTagText `in_` (valList $ map P.unTag tags)
+                   )
+
+            pure (val (1 :: Int))
+      Just (O.TagsAll []) -> pure ()
+      Nothing -> pure ()
+
+    pure photos
+
+  forM photos \(Entity { entityVal }) -> do
+    tags <- map (P.Tag . unValue) <$> select do
+      taggedPhotos <- from $ table @S.TaggedPhoto
+
+      where_ ( taggedPhotos ^. S.TaggedPhotoPhotoHash ==. val entityVal.hash )
+
+      pure ( taggedPhotos ^. S.TaggedPhotoTagText )
+    pure
+      $ P.Photo
+      { hash = entityVal.hash
+      , name = entityVal.name
+      , date = entityVal.date
+      , description = entityVal.description
+      , imageType = entityVal.imageType
+      , tags = tags
+      }

overlays/photo-hs/lib/Constants.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Constants
+  ( sqlFile
+  , storeDirectory
+  , gitignoreFile
+  , gitignoreText
+  )
+where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Percept.Util ((<$/>))
+
+sqlFile :: Text
+sqlFile = "photos.sqlite3"
+
+storeDirectory :: Text
+storeDirectory = ".store"
+
+gitignoreFile :: Text
+gitignoreFile = ".gitignore"
+
+gitignoreText :: Text
+gitignoreText
+  = T.unlines
+  [ sqlFile
+  , sqlFile <> "-shm"
+  , sqlFile <> "-wal"
+  ]

overlays/photo-hs/lib/Database/Esqueleto/Experimental/Monad.hs

@@ -0,0 +1,93 @@
+module Database.Esqueleto.Experimental.Monad
+  ( select
+  , insertMany_
+  , insert
+  , insert_
+  , insertUnique
+  , upsert
+  , repsert
+  , repsertMany
+  , delete
+  ) where
+
+import Database.Persist.Monad.Class (MonadSqlQuery)
+import qualified Database.Esqueleto.Experimental as E
+import Database.Esqueleto.Internal.Internal qualified as E (SqlSelect, Update)
+import Database.Persist.Monad (unsafeLiftSql)
+import Database.Persist.Class.PersistEntity (Update)
+
+select :: (MonadSqlQuery m, E.SqlSelect a r) => E.SqlQuery a -> m [r]
+select q = unsafeLiftSql "esqueleto-select" (E.select q)
+
+type InsertConstraints record m
+  = ( MonadSqlQuery m
+    , E.PersistRecordBackend record E.SqlBackend
+    , E.SafeToInsert record
+    )
+
+insertMany_
+  :: forall record m
+   . InsertConstraints record m
+  => [record]
+  -> m ()
+insertMany_ entities = unsafeLiftSql "esqueleto-insert-many_" (E.insertMany_ entities)
+
+insert
+  :: forall record m
+   . InsertConstraints record m
+  => record
+  -> m (E.Key record)
+insert entity = unsafeLiftSql "esqueleto-insert" (E.insert entity)
+
+insert_
+  :: forall record m
+   . InsertConstraints record m
+  => record
+  -> m ()
+insert_ entity = unsafeLiftSql "esqueleto-insert_" (E.insert_ entity)
+
+insertUnique
+  :: forall record m
+   . InsertConstraints record m
+  => record
+  -> m (Maybe (E.Key record))
+insertUnique entity = unsafeLiftSql "esqueleto-insert-unique" (E.insertUnique entity)
+
+repsert
+  :: forall record m
+   . ( MonadSqlQuery m
+     , E.PersistRecordBackend record E.SqlBackend
+     )
+  => E.Key record
+  -> record
+  -> m ()
+repsert key entity = unsafeLiftSql "esqueleto-repsert" (E.repsert key entity)
+
+upsert
+  :: forall record m
+   . ( MonadSqlQuery m
+     , E.PersistRecordBackend record E.SqlBackend
+     , E.OnlyOneUniqueKey record
+     , E.SafeToInsert record
+     )
+  => record
+  -> [Update record]
+  -> m (E.Entity record)
+upsert entity updates = unsafeLiftSql "esqueleto-upsert" (E.upsert entity updates)
+
+repsertMany
+  :: forall record m
+   . ( MonadSqlQuery m
+     , E.PersistRecordBackend record E.SqlBackend
+     )
+  => [(E.Key record, record)]
+  -> m ()
+repsertMany entities = unsafeLiftSql "esqueleto-repsert-many" (E.repsertMany entities)
+
+delete
+  :: forall record m
+   . ( MonadSqlQuery m
+     )
+  => E.SqlQuery ()
+  -> m ()
+delete query = unsafeLiftSql "esqueleto-repsert-many" (E.delete query)

overlays/photo-hs/lib/Exif/Tool.hs

@@ -0,0 +1,41 @@
+module Exif.Tool
+  ( exiftoolWrite
+  , exiftoolRead
+  ) where
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.Text (Text)
+import Data.HashMap.Strict (HashMap)
+import Control.Monad.Logger (MonadLogger, logWarnN)
+import GHC.IO.Exception (ExitCode(..))
+import System.Process.Typed (readProcess, runProcess, proc)
+import Data.Text qualified as T
+import Data.HashMap.Strict qualified as HM
+import Data.Aeson qualified as A
+import Data.Functor ((<&>))
+
+exiftoolWrite :: (MonadIO m) => FilePath -> HashMap Text Text -> m ()
+exiftoolWrite imagePath fields = do
+  let
+    toFlag (field, value) = "-" <> field <> "=" <> value <> ""
+    flags = map toFlag . filter ((/= "SourceFile") . fst) $ HM.toList fields
+
+    pc = proc "/nix/store/6scrhdz42mq882wnlz71rz8yq1a5h6gk-perl5.38.2-Image-ExifTool-12.84/bin/exiftool" (["-j", imagePath] ++ map T.unpack flags)
+
+  liftIO $ print flags
+  runProcess pc
+  pure ()
+
+exiftoolRead :: (MonadIO m, MonadLogger m) => FilePath -> [Text] -> m (Maybe (HashMap Text Text))
+exiftoolRead imagePath fields =
+  let
+    toFlag field = "-" <> field
+    flags = map toFlag fields
+
+    pc = proc "/nix/store/6scrhdz42mq882wnlz71rz8yq1a5h6gk-perl5.38.2-Image-ExifTool-12.84/bin/exiftool" (["-j", imagePath] ++ map T.unpack flags)
+  in
+  readProcess pc >>= \case
+    (ExitFailure exitCode, _, _stderr) -> do
+      logWarnN ("exiftool exited with exit code: " <> T.pack (show exitCode) <> "\n")
+      pure Nothing
+    (ExitSuccess, stdout, _) -> do
+      pure $ A.decode stdout <&> head

overlays/photo-hs/lib/Git.hs

@@ -0,0 +1,44 @@
+module Git (gitCommit, gitInit, gitAdd) where
+
+import Data.Text (Text)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.Process.Typed (proc, runProcess, ExitCode, setWorkingDir)
+import qualified Data.Text as T
+import Data.Function ((&))
+import qualified System.Directory as D
+
+gitCommit
+  :: ( MonadIO m
+     )
+  => Text
+  -> Text
+  -> m ExitCode
+gitCommit repoPath message = runProcess pc
+  where pc = proc "git" ["commit", "-m", T.unpack message]
+          & setWorkingDir (T.unpack repoPath)
+
+gitInit
+  :: ( MonadIO m
+     )
+  => FilePath
+  -> m ExitCode
+gitInit repoPath = do
+  let
+    pc = proc "git" ["init"]
+      & setWorkingDir repoPath
+
+  liftIO $ D.createDirectoryIfMissing True repoPath
+  runProcess pc
+
+gitAdd
+  :: ( MonadIO m
+     )
+  => Text
+  -> Text
+  -> m ExitCode
+gitAdd repoPath filePath = do
+  let
+    pc = proc "git" ["add", T.unpack filePath]
+      & setWorkingDir (T.unpack repoPath)
+
+  runProcess pc

overlays/photo-hs/lib/Git/Annex.hs

@@ -0,0 +1,30 @@
+module Git.Annex
+  ( gitAnnexAdd
+  , gitAnnexInit
+  ) where
+
+import Control.Monad.IO.Class (MonadIO)
+import System.Process.Typed (proc, runProcess, ExitCode (..), setWorkingDir)
+import Data.Function ((&))
+
+gitAnnexAdd :: (MonadIO m) => FilePath -> FilePath -> m ()
+gitAnnexAdd repositoryPath filePath = do
+  let
+    pc
+      = proc "git" [ "annex", "add", filePath ]
+      & setWorkingDir repositoryPath
+
+  runProcess pc >>= \case
+    ExitSuccess -> pure ()
+    ExitFailure code -> undefined
+
+gitAnnexInit :: (MonadIO m) => FilePath -> m ()
+gitAnnexInit repositoryPath = do
+  let
+    pc
+      = proc "git" [ "annex", "init" ]
+      & setWorkingDir repositoryPath
+
+  runProcess pc >>= \case
+    ExitSuccess -> pure ()
+    ExitFailure code -> undefined

overlays/photo-hs/lib/MyLib.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module MyLib (libMain) where
+
+import Data.Text (Text)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import System.Process.Typed
+import Data.Function ((&))
+import System.FilePath ((</>))
+import Control.Exception (throw, SomeException)
+import Options.Applicative
+import Options.Applicative qualified as OA
+import Data.Functor ((<&>))
+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)
+import Database.Persist.Sqlite (withSqlitePool)
+import Data.Text qualified as T
+import Control.Monad.Logger (LoggingT, MonadLogger (..), runStdoutLoggingT)
+import UnliftIO (MonadUnliftIO, catch)
+import qualified System.Directory as D
+import qualified Constants
+import Control.Monad.Extra (findM)
+import Options (Command (..), Options (..), SomeCommand (..), parseOptions)
+import AppData (AppData (..), askStoreDir)
+import Commands (commandAddPhoto, commandInit, commandList, commandEditMeta)
+import Percept.Error (PhotoException(..))
+import Percept.Util (handleExitCode, (<$/>))
+import Database.Persist.Monad (SqlQueryT, runSqlQueryT, MonadSqlQuery, runMigration)
+import qualified Schema as S
+
+executeCommand :: (MonadIO m, MonadLogger m, MonadSqlQuery m, MonadReader AppData m) => Command a -> m ()
+executeCommand = \case
+  Init storeDir -> do
+    appData <- asks (\s -> s.options)
+    commandInit appData storeDir
+
+  AddPhoto filePath name tags creationTime description -> do
+    _ <- commandAddPhoto filePath name tags creationTime description
+    pure ()
+
+  List filter -> do
+    photos <- commandList filter
+    liftIO $ print photos
+
+  EditMeta hash editOp -> do
+    _ <- commandEditMeta hash editOp
+    pure ()
+
+  Debug -> do
+    commandDebug
+
+  Annex arguments -> do
+    commandAnnex arguments
+
+  Git arguments -> do
+    commandGit arguments
+
+commandDebug :: (MonadIO m, MonadReader AppData m) => m ()
+commandDebug = do
+  photoDir <- asks (\s -> s.photoDir)
+  liftIO $ putStrLn ("photo directory: " ++ photoDir)
+  pure ()
+
+commandPassthrough :: (MonadIO m, MonadReader AppData m) => Text -> [Text] -> [Text] -> m ()
+commandPassthrough command extraArgs arguments = do
+  storeDir <- askStoreDir
+  let
+    pc
+      = proc (T.unpack command) (map T.unpack extraArgs ++ map T.unpack arguments)
+      & setWorkingDir storeDir
+
+  runProcess pc >>= handleExitCode (throw . GitInitFailed . ExitFailure) ()
+
+commandAnnex :: (MonadIO m, MonadReader AppData m) => [Text] -> m ()
+commandAnnex = commandPassthrough "git" ["annex"]
+
+commandGit :: (MonadIO m, MonadReader AppData m) => [Text] -> m ()
+commandGit = commandPassthrough "git" []
+
+newtype AppM m a = AppM (SqlQueryT (ReaderT AppData (LoggingT m)) a)
+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadSqlQuery)
+
+unAppM :: AppM m a -> SqlQueryT (ReaderT AppData (LoggingT m)) a
+unAppM (AppM inner) = inner
+
+instance Monad m => MonadReader AppData (AppM m) where
+  ask = AppM ask
+  local f (AppM m) = AppM (local f m)
+
+instance (MonadIO m) => MonadLogger (AppM m) where
+  monadLoggerLog loc logSource logLevel msg = AppM $ monadLoggerLog loc logSource logLevel msg
+
+increments :: [FilePath] -> [[FilePath]]
+increments path = map reverse $ increments' (reverse path)
+
+increments' :: [FilePath] -> [[FilePath]]
+increments' [] = [[]]
+increments' path = path : increments' (tail path)
+
+split :: (Char -> Bool) -> String -> [String]
+split delim string = T.pack string & T.split delim & map T.unpack -- ugly hack
+
+join :: Char -> [String] -> String
+join _ [] = ""
+join _ [x] = x
+join delim (x:xs) = x ++ [delim] ++ join delim xs
+
+
+detectPhotoDirectory :: (MonadIO m) => m (Maybe FilePath)
+detectPhotoDirectory = do
+  cwd <- liftIO D.getCurrentDirectory <&> filter (/="") . split (=='/')
+  let parentDirectories = increments cwd & map (('/' :) . join '/')
+
+  flip findM parentDirectories \directory ->
+    liftIO $ D.doesDirectoryExist (directory </> T.unpack Constants.storeDirectory)
+
+runAppM :: (Monad m, MonadIO m, MonadUnliftIO m) => Options -> AppM m a -> m a
+runAppM opts appM = do
+  detectPhotoDirectory >>= \case
+    Just photoDir -> do
+      let
+        sqlPath = T.pack photoDir <$/> Constants.storeDirectory <$/> Constants.sqlFile
+        appData
+          = AppData
+          { options = opts
+          , photoDir = photoDir
+          }
+
+      runStdoutLoggingT $ withSqlitePool sqlPath 1 \pool -> flip runReaderT appData . runSqlQueryT pool. unAppM $ do
+        runMigration S.migrateAll
+        appM
+    Nothing -> throw PhotoDirNotFound
+
+libMain :: IO ()
+libMain = do
+  opts <- OA.execParser (info (parseOptions <**> helper)
+                         ( fullDesc
+                        <> progDesc "Photo management in Haskell"
+                        <> header "photo-hs - photo manager"
+                         )
+                        )
+  print opts
+
+  (\(SomeCommand cmd) ->
+     case cmd of
+       Init photoDir -> commandInit opts photoDir
+       _ -> runAppM opts $ executeCommand cmd >> pure ()) opts.command
+  pure ()

overlays/photo-hs/lib/Options.hs

@@ -0,0 +1,264 @@
+{-# LANGUAGE GADTs #-}
+
+module Options
+  ( Command(..)
+  , Filter(..)
+  , TagFilter(..)
+  , EditOperation(..)
+  , SomeCommand(..)
+  , Options(..)
+  , parseOptions
+  ) where
+import Data.Text (Text)
+import Data.Time (ZonedTime)
+import Crypto.Hash (Digest, SHA256)
+import Options.Applicative
+import Options.Applicative qualified as OA
+import Data.Functor ((<&>))
+import qualified Data.Text as T
+import qualified Photo as P
+
+data TagFilter
+  = TagsAll [P.Tag]
+  | TagsSome [P.Tag]
+  deriving Show
+
+data Filter
+  = Filter
+  { name :: Maybe Text
+  , tags :: Maybe TagFilter
+  , useRegex :: Bool
+  }
+  deriving Show
+
+data EditOperation
+  = AddTags [P.Tag]
+  | RemoveTags [P.Tag]
+  | ClearTags
+  | SetTags [P.Tag]
+  | SetName Text
+  | SetDescription Text
+  deriving Show
+
+data Command a where
+  Init ::
+    Text
+    -- ^ path to new directory to create and initialize
+    -> Command ()
+  AddPhoto
+    :: FilePath
+    -- ^ path to image file
+    -> Maybe Text
+    -- ^ overriding name
+    -> [P.Tag]
+    -- ^ list of tags
+    -> Maybe ZonedTime
+    -- ^ creation time
+    -> Maybe Text
+    -- ^ description
+    -> Command (Digest SHA256)
+  List
+    :: Filter
+    -- ^ filter for the listing
+    -> Command [P.Photo]
+  EditMeta
+    :: P.Hash
+    -- ^ photo which to edit
+    -> EditOperation
+    -- ^ operation to carry out
+    -> Command P.Photo
+  Annex
+    :: [Text]
+    -> Command ()
+  Git
+    :: [Text]
+    -> Command ()
+  Debug
+    :: Command ()
+
+makePrettyList :: [T.Text] -> T.Text
+makePrettyList list = T.intercalate ", " (map (\mid -> "\"" <> mid <> "\"") list)
+
+instance Show (Command a) where
+  show :: Command a -> String
+  show (Init photoDir) = "Init { storeDir = " ++ show photoDir ++ " }"
+  show (AddPhoto photoPath name tags creationTime description)
+    = "AddPhoto { "
+    ++ "photoPath = " ++ show photoPath
+    ++ ", name = " ++ show name
+    ++ ", tags = " ++ show tags
+    ++ ", creationTime = " ++ show creationTime
+    ++ ", description = " ++ show description
+    ++ " }"
+  show (List filter) = "Lift { filter = " ++ show filter ++ " }"
+  show (EditMeta hash operation) = "EditMeta { hash = " ++ show hash ++ ", operation = " ++ show operation ++ " }"
+  show (Annex commands) = "Annex { commands = [" ++ T.unpack (makePrettyList commands) ++ "] }"
+  show (Git commands) = "Git { commands = [" ++ T.unpack (makePrettyList commands) ++ "] }"
+  show Debug = "Debug"
+
+data SomeCommand where
+  SomeCommand :: forall a . Command a -> SomeCommand
+
+instance Show SomeCommand where
+  show :: SomeCommand -> String
+  show (SomeCommand cmd) = show cmd
+
+data Options
+  = Options
+  { dryRun :: Bool
+  , verbose :: Bool
+  , command :: SomeCommand
+  }
+  deriving Show
+
+parseCommandInit :: Parser (Command ())
+parseCommandInit = Init <$> argument str (metavar "STORE_DIR")
+
+parseCommandAddPhoto :: Parser (Command (Digest SHA256))
+parseCommandAddPhoto
+    = AddPhoto
+  <$> argument str (metavar "PHOTO")
+  <*> optional (option str
+      ( long "name"
+     <> short 'n'
+      ))
+  <*> many
+        (option str
+          ( long "tag"
+         <> short 't'
+          ))
+  <*> optional (option auto
+      ( long "creation-time"
+     <> short 'C'
+     <> help "Substitute creation time if missing, format: 2024-06-26 18:21:30 +0200"
+      ))
+  <*> optional (option str
+      ( long "description"
+     <> short 'D'
+      ))
+
+parseCommandList :: Parser (Command [P.Photo])
+parseCommandList
+  = List
+  <$> ( Filter
+    <$> optional (option str
+          ( long "name"
+         <> short 'n'
+          )
+        )
+    <*> optional (parseTagFilterAll <|> parseTagFilterSome)
+    <*> switch
+        ( long "regex"
+       <> short 'r'
+        )
+      )
+  where
+    parseTagFilterAll :: Parser TagFilter
+    parseTagFilterAll = flag' TagsAll
+      (  long "all"
+      <> help "All of the specified tags have to match" ) <*> many (option str ( long "tag" <> short 't'))
+
+
+    parseTagFilterSome :: Parser TagFilter
+    parseTagFilterSome = flag' TagsSome
+      (  long "some"
+      <> help "Only some of the specified tags have to match" ) <*> many (option str ( long "tag" <> short 't'))
+
+parseCommandEditMeta :: Parser (Command P.Photo)
+parseCommandEditMeta
+  = EditMeta
+  <$> argument str (metavar "HASH")
+  <*> ( parseAddTags
+    <|> parseRemoveTags
+    <|> parseClearTags
+    <|> parseSetTags
+    <|> parseSetName
+    <|> parseSetDescription
+      )
+  where
+    parseAddTags :: Parser EditOperation
+    parseAddTags
+        = flag' AddTags
+          (  long "add-tags"
+            <> help "Add the specified tags" )
+      <*> many (option str
+          ( long "tag"
+         <> short 't'
+          ) )
+    parseRemoveTags :: Parser EditOperation
+    parseRemoveTags
+        = flag' RemoveTags
+          (  long "remove-tags"
+            <> help "Removes the specified tags" )
+      <*> many (option str
+          ( long "tag"
+         <> short 't'
+          ) )
+    parseClearTags :: Parser EditOperation
+    parseClearTags
+        = flag' ClearTags
+          (  long "clear-tags"
+            <> help "Clears all existing tags" )
+    parseSetTags :: Parser EditOperation
+    parseSetTags
+        = flag' SetTags
+          (  long "set-tags"
+            <> help "Overrides existing tags with the specified tags" )
+      <*> many (option str
+          ( long "tag"
+         <> short 't'
+          ) )
+    parseSetName :: Parser EditOperation
+    parseSetName
+        = SetName
+       <$> option str
+          (  long "set-name"
+            <> help "Overrides the existing name withe the specified one" )
+    parseSetDescription :: Parser EditOperation
+    parseSetDescription
+        = SetDescription
+       <$> option str
+          (  long "set-description"
+            <> help "Overrides the existing description with the specified one" )
+
+parseCommandDebug :: Parser (Command ())
+parseCommandDebug = pure Debug
+
+parseCommandAnnex :: Parser (Command ())
+parseCommandAnnex = Annex <$> many (argument str (metavar "REST"))
+
+parseCommandGit :: Parser (Command ())
+parseCommandGit = Git <$> many (argument str (metavar "REST"))
+
+parseCommand :: Parser SomeCommand
+parseCommand =
+  subparser (
+      OA.command "init" (info (parseCommandInit <**> helper <&> SomeCommand) (progDesc descInit))
+   <> OA.command "addphoto" (info (parseCommandAddPhoto <**> helper <&> SomeCommand) (progDesc descAddPhoto))
+   <> OA.command "list" (info (parseCommandList <**> helper <&> SomeCommand) (progDesc descList))
+   <> OA.command "editmeta" (info (parseCommandEditMeta <**> helper <&> SomeCommand) (progDesc descEditMeta))
+   <> OA.command "debug" (info (parseCommandDebug <**> helper <&> SomeCommand) (progDesc descDebug))
+   <> OA.command "annex" (info (parseCommandAnnex <**> helper <&> SomeCommand) (progDesc descAnnex))
+   <> OA.command "git" (info (parseCommandGit <**> helper <&> SomeCommand) (progDesc descGit))
+  )
+
+  where
+    descInit = "Init a new photo repository"
+    descList = "List all photos in the store, optionally according to a filter"
+    descEditMeta = "Edit the metadata of an existing photo"
+    descAddPhoto = "Add a photo to the database"
+    descDebug = "Debug command"
+    descAnnex = "Passes through all arguments to `git annex` in the store directory"
+    descGit = "Passes through all arguments to `git` in the store directory"
+
+parseOptions :: Parser Options
+parseOptions = Options
+      <$> switch
+            ( long "dry-run"
+           <> short 'n'
+            )
+      <*> switch
+            ( long "verbose"
+           <> short 'v'
+            )
+      <*> parseCommand

overlays/photo-hs/lib/Percept/Error.hs

@@ -0,0 +1,28 @@
+module Percept.Error
+  ( PhotoException(..)
+  ) where
+
+import System.Process.Typed (ExitCode)
+import GHC.Exception (Exception(..))
+import Photo qualified as P 
+import qualified Toml
+
+data PhotoException where
+  GitInitFailed :: ExitCode -> PhotoException
+  PhotoDirNotFound :: PhotoException
+  UnknownCreationTime :: PhotoException
+  InconsistentDatabaseState :: PhotoException
+  PhotoAlreadyExists :: P.Photo -> PhotoException
+  CorruptMetadata :: P.Hash -> [Toml.TomlDecodeError] -> PhotoException
+  deriving (Show, Eq)
+
+
+instance Exception PhotoException where
+  backtraceDesired _ = False
+  displayException :: PhotoException -> String
+  displayException (GitInitFailed exitCode) = "Failed to initialize new percept store, git failed with exit code: " ++ show exitCode
+  displayException PhotoDirNotFound = "Couldn't find an initialize percept store"
+  displayException UnknownCreationTime = "Couldn't read a photos creation time, specify it with `--creation-time`"
+  displayException InconsistentDatabaseState = "The database has been found to be in an inconsistent state, recreate it using `rebuild-cache`"
+  displayException (PhotoAlreadyExists (P.Photo { hash, name })) = "Photo with hash " ++ show hash ++ " already exists with name: " ++ show name
+  displayException (CorruptMetadata hash errors) = "Failed to decode metadata file for hash " ++ show hash ++ ", got errors: " ++ show errors

overlays/photo-hs/lib/Percept/Operations.hs

@@ -0,0 +1,119 @@
+module Percept.Operations
+  ( calculateImageDigest
+  , readImageCreationUTCTime
+  , saveMetadataFile
+  , readMetadataFile
+  , inStorePathForMetadata
+  , inStorePathForPhoto
+  , savePhotoFile
+  , cachePhoto
+  ) where
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger (MonadLogger)
+import Crypto.Hash (SHA256, Digest, hash)
+import Data.Time (ZonedTime, parseTimeM, defaultTimeLocale)
+import Control.Monad.Reader.Class (MonadReader)
+import AppData (AppData, askPhotoDir, askStoreDir)
+import qualified Photo as P
+import qualified Data.ByteString as BS
+import Data.Functor ((<&>))
+import Exif.Tool (exiftoolRead)
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+import qualified Toml
+import qualified Data.Text.IO as T
+import qualified Constants
+import qualified System.Directory as D
+import Database.Persist.Monad.Class (MonadSqlQuery)
+import qualified Schema as S
+import Control.Monad.Extra (forM_)
+import Database.Esqueleto.Experimental.Monad (insertUnique, insert_, insertMany_, repsert, upsert, insert, delete, select, repsertMany)
+import Database.Esqueleto.Experimental (toSqlKey, keyFromValues, keyFromRecordM, Key, PersistEntity, notExists, where_, from, (^.), (==.), table, val)
+import Schema (EntityField(PhotoHash))
+import Data.Maybe (fromJust)
+import Percept.Error (PhotoException(CorruptMetadata))
+import Control.Exception (throw)
+
+calculateImageDigest :: (MonadIO m) => FilePath -> m (Digest SHA256)
+calculateImageDigest imagePath = liftIO $ BS.readFile imagePath <&> hash
+
+readImageCreationUTCTime :: (MonadLogger m, MonadIO m) => FilePath -> m (Maybe ZonedTime)
+readImageCreationUTCTime imagePath = do
+  hashmap <- exiftoolRead imagePath ["DateTimeOriginal", "OffsetTimeOriginal"]
+
+  case hashmap of
+    Nothing -> pure Nothing
+    Just hashmap' -> case (hashmap' HM.!? "DateTimeOriginal", hashmap' HM.!? "OffsetTimeOriginal") of
+      (Nothing, _) -> pure Nothing
+      (Just time, Just offset) ->
+        pure . parseTimeM True defaultTimeLocale "%Y:%m:%d %H:%M:%S%z" . T.unpack $ (time <> offset)
+      (Just time, Nothing) ->
+        pure . parseTimeM True defaultTimeLocale "%Y:%m:%d %H:%M:%S" . T.unpack $ time
+
+inStorePathForMetadata :: (MonadReader AppData m) => P.Hash -> m FilePath
+inStorePathForMetadata hash = askStoreDir <&> \storeDir ->
+  storeDir <> "/" <> T.unpack (P.unHash hash) <> ".meta.toml"
+
+saveMetadataFile :: (MonadReader AppData m, MonadIO m) => P.Photo -> m ()
+saveMetadataFile photo = do
+  let
+    content = Toml.encode P.photoCodec photo
+  metadataPath <- inStorePathForMetadata photo.hash
+
+  liftIO $ T.writeFile metadataPath content
+
+inStorePathForPhoto :: (MonadReader AppData m) => P.Photo -> m FilePath
+inStorePathForPhoto photo = askStoreDir <&> \storeDir ->
+  storeDir <> "/" <> T.unpack (P.unHash photo.hash) <> "." <>  T.unpack photo.imageType
+
+readMetadataFile :: (MonadReader AppData m, MonadIO m) => P.Hash -> m P.Photo
+readMetadataFile hash = do
+  metadataPath <- inStorePathForMetadata hash
+
+  Toml.decodeFileEither P.photoCodec metadataPath >>= \case
+    Left errors -> throw (CorruptMetadata hash errors)
+    Right photo -> pure photo
+
+savePhotoFile :: (MonadReader AppData m, MonadIO m) => FilePath -> P.Photo -> m ()
+savePhotoFile photoPath photo = do
+  inStorePhotoPath <- inStorePathForPhoto photo
+  liftIO $ D.copyFile photoPath inStorePhotoPath
+
+cachePhoto :: (MonadSqlQuery m) => P.Photo -> m ()
+cachePhoto photo = do
+  let
+    keyFromRecord :: (PersistEntity record) => record -> Key record
+    keyFromRecord = fromJust keyFromRecordM
+    schemaPhoto
+      = S.Photo
+      { hash = photo.hash
+      , name = photo.name
+      , date = photo.date
+      , imageType = photo.imageType
+      , description = photo.description
+      }
+
+  -- repsert all required tags
+  repsertMany $ flip map photo.tags \(P.Tag tag) ->
+    ((keyFromRecord (S.Tag tag)), (S.Tag tag))
+
+  -- repsert the photo itself
+  repsert (keyFromRecord schemaPhoto) schemaPhoto
+
+  -- delete all existing TaggedPhoto entities
+  delete do
+    taggedPhotos <- from $ table @S.TaggedPhoto
+    where_ (taggedPhotos ^. S.TaggedPhotoPhotoHash ==. val photo.hash)
+
+  -- insert only the ones that are supposed to be there
+  insertMany_ $ flip map photo.tags \(P.Tag tag) ->
+    S.TaggedPhoto { tagText = tag, photoHash = photo.hash }
+
+  -- delete any non-referenced tag entities
+  delete do
+    tags <- from $ table @S.Tag
+    where_ $ notExists $ do
+      taggedPhotos <- from $ table @S.TaggedPhoto
+      where_ (tags ^. S.TagText ==. taggedPhotos ^. S.TaggedPhotoTagText)
+      pure ()
+    pure ()

overlays/photo-hs/lib/Percept/Util.hs

@@ -0,0 +1,21 @@
+module Percept.Util
+  ( handleExitCode
+  , handleGitError
+  , (<$/>)
+  ) where
+
+import System.Process.Typed (ExitCode (..))
+import Data.Text (Text)
+import Control.Exception (throw)
+import Percept.Error (PhotoException(..))
+
+(<$/>) :: Text -> Text -> Text
+(<$/>) a b = a <> "/" <> b
+
+handleExitCode :: (Monad m) => (Int -> m a) -> a -> ExitCode -> m a
+handleExitCode failureM success = \case
+  ExitSuccess -> pure success
+  ExitFailure code -> failureM code
+
+handleGitError :: (Monad m) => ExitCode -> m ()
+handleGitError = handleExitCode (throw . GitInitFailed . ExitFailure) ()

overlays/photo-hs/lib/Photo.hs

@@ -0,0 +1,78 @@
+module Photo
+  ( Photo(..)
+  , photoCodec
+  , Tag(..)
+  , unTag
+  , Hash(..)
+  , unHash
+  , getPhotoExtension
+  ) where
+
+import Data.Functor ((<&>))
+import Data.Time (UTCTime, utc, utcToZonedTime, zonedTimeToUTC)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Toml qualified
+import System.FilePath (takeExtension)
+import GHC.Generics (Generic)
+import Data.Aeson qualified as A
+import Database.Esqueleto.Experimental (PersistField, PersistFieldSql)
+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)
+import Web.PathPieces (PathPiece)
+import Data.String (IsString)
+
+newtype Tag = Tag Text
+  deriving newtype (PersistField, Eq, Show, A.FromJSON, A.ToJSON, IsString, Toml.HasItemCodec)
+
+unTag :: Tag -> Text
+unTag (Tag text) = text
+
+newtype Hash = Hash Text
+  deriving newtype
+    ( PersistField
+    , PersistFieldSql
+    , FromHttpApiData
+    , PathPiece
+    , ToHttpApiData
+    , Read
+    , Ord
+    , Eq
+    , Show
+    , A.FromJSON
+    , A.ToJSON
+    , Toml.HasCodec
+    , IsString
+    )
+
+unHash :: Hash -> Text
+unHash (Hash hash) = hash
+
+data Photo
+  = Photo
+  { hash :: Hash
+  , name :: Text
+  , date :: UTCTime
+  , description :: Text
+  , imageType :: Text
+  , tags :: [Tag]
+  }
+  deriving (Show, Eq, A.FromJSON, A.ToJSON, Generic)
+
+matchUTCTime :: Toml.Value t -> Either Toml.MatchError UTCTime
+matchUTCTime v = Toml.matchZoned v <&> zonedTimeToUTC
+
+_UTCTimeToValue :: UTCTime -> Toml.Value 'Toml.TZoned
+_UTCTimeToValue utcTime = Toml.Zoned (utcToZonedTime utc utcTime)
+
+_UTCTime :: Toml.TomlBiMap UTCTime Toml.AnyValue
+_UTCTime = Toml.mkAnyValueBiMap matchUTCTime _UTCTimeToValue
+
+instance Toml.HasCodec UTCTime where
+  hasCodec = Toml.match _UTCTime
+
+photoCodec :: Toml.TomlCodec Photo
+photoCodec = Toml.genericCodec
+
+getPhotoExtension :: FilePath -> Text
+getPhotoExtension photoPath = T.pack $ takeExtension photoPath
+

overlays/photo-hs/lib/Schema.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Schema
+  ( Photo(..)
+  , EntityField(..)
+  , Tag(..)
+  , TaggedPhoto(..)
+  , entityDefListFormigrateAll
+  , migrateAll
+  ) where
+
+import Database.Persist.TH
+import TH (customSqlSettings)
+import Data.Text (Text)
+import Data.Time (UTCTime)
+
+import Photo qualified as P (Hash)
+import Database.Esqueleto.Experimental (EntityField, Key)
+
+share [mkPersist customSqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Photo
+    hash P.Hash
+    name Text
+    date UTCTime
+    description Text
+    imageType Text
+    Primary hash
+  deriving Show
+Tag
+    text Text
+    Primary text
+  deriving Show
+TaggedPhoto
+    photoHash P.Hash
+    tagText Text
+    Primary photoHash tagText
+    Foreign Photo fk_tagged_photo_photo photoHash References hash
+    Foreign Tag fk_tagged_photo_tag tagText References text
+  deriving Show
+|]
+

overlays/photo-hs/lib/TH.hs

@@ -0,0 +1,6 @@
+module TH(customSqlSettings) where
+
+import Database.Persist.TH (MkPersistSettings (..), sqlSettings)
+
+customSqlSettings :: MkPersistSettings
+customSqlSettings = sqlSettings { mpsFieldLabelModifier = \_ field -> field }

overlays/photo-hs/photo-hs.cabal

@@ -0,0 +1,184 @@
+cabal-version:      3.4
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'photo-hs' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               photo-hs
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- URL for the project homepage or repository.
+homepage:           redalder.org
+
+-- The license under which the package is released.
+license:            LGPL-3.0-or-later
+
+-- The file containing the license text.
+license-file:       LICENSE
+
+-- The package author(s).
+author:             magic_rb
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:         magic_rb@redalder.org
+
+-- A copyright notice.
+-- copyright:
+category:           Data
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Modules exported by the library.
+    exposed-modules:  MyLib
+
+    -- Modules included in this library but not exported.
+    other-modules:
+        Constants,
+        TH,
+        Git,
+        Git.Annex,
+        AppData,
+        Options,
+        Schema,
+        Commands,
+        Commands.Init,
+        Commands.Debug,
+        Commands.Annex,
+        Commands.Git,
+        Commands.AddPhoto,
+        Commands.List,
+        Commands.EditMeta,
+        Photo,
+        Exif.Tool,
+        Percept.Error,
+        Percept.Util,
+        Percept.Operations,
+        Database.Esqueleto.Experimental.Monad,
+
+    -- LANGUAGE extensions used by modules in this package.
+    default-extensions:
+        DerivingStrategies,
+        DataKinds,
+        DeriveAnyClass,
+        LambdaCase,
+        OverloadedStrings,
+        BlockArguments,
+        DuplicateRecordFields,
+        OverloadedRecordDot,
+        NoFieldSelectors,
+
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base,
+        persistent,
+        persistent-sqlite,
+        persistent-mtl,
+        esqueleto,
+        bytestring,
+        text,
+        time,
+        aeson,
+        http-api-data,
+        path-pieces,
+        typed-process,
+        filepath,
+        optparse-applicative,
+        mtl,
+        monad-logger,
+        unliftio,
+        directory,
+        extra,
+        crypton,
+        unordered-containers,
+        tomland,
+
+
+    -- Directories containing source files.
+    hs-source-dirs:   lib
+
+    -- Base language which the package is written in.
+    default-language: GHC2021
+
+executable photo-hs
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base,
+        photo-hs
+
+    -- Directories containing source files.
+    hs-source-dirs:   exe
+
+    -- Base language which the package is written in.
+    default-language: GHC2021
+
+test-suite photo-hs-test
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Base language which the package is written in.
+    default-language: GHC2021
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
+
+    -- Directories containing source files.
+    hs-source-dirs:   test
+
+    -- The entrypoint to the test suite.
+    main-is:          Main.hs
+
+    -- Test dependencies.
+    build-depends:
+        base ^>=4.17.2.0,
+        photo-hs

overlays/photo-hs/test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."