diff --git a/overlays/photo-hs/.gitignore b/overlays/photo-hs/.gitignore new file mode 100644 index 0000000..e771b07 --- /dev/null +++ b/overlays/photo-hs/.gitignore @@ -0,0 +1 @@ +percept diff --git a/overlays/photo-hs/CHANGELOG.md b/overlays/photo-hs/CHANGELOG.md new file mode 100644 index 0000000..ad7927f --- /dev/null +++ b/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. diff --git a/overlays/photo-hs/LICENSE b/overlays/photo-hs/LICENSE new file mode 100644 index 0000000..31afd6d --- /dev/null +++ b/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. + 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. diff --git a/overlays/photo-hs/exe/Main.hs b/overlays/photo-hs/exe/Main.hs new file mode 100644 index 0000000..efcc88c --- /dev/null +++ b/overlays/photo-hs/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import MyLib (libMain) + +main :: IO () +main = libMain diff --git a/overlays/photo-hs/lib/.dir-locals.el b/overlays/photo-hs/lib/.dir-locals.el new file mode 100644 index 0000000..6ab4256 --- /dev/null +++ b/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)))) diff --git a/overlays/photo-hs/lib/AppData.hs b/overlays/photo-hs/lib/AppData.hs new file mode 100644 index 0000000..ca2bbd4 --- /dev/null +++ b/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) + + diff --git a/overlays/photo-hs/lib/Commands.hs b/overlays/photo-hs/lib/Commands.hs new file mode 100644 index 0000000..e4883c9 --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Commands/AddPhoto.hs b/overlays/photo-hs/lib/Commands/AddPhoto.hs new file mode 100644 index 0000000..2b5f251 --- /dev/null +++ b/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 + diff --git a/overlays/photo-hs/lib/Commands/Annex.hs b/overlays/photo-hs/lib/Commands/Annex.hs new file mode 100644 index 0000000..697af22 --- /dev/null +++ b/overlays/photo-hs/lib/Commands/Annex.hs @@ -0,0 +1,3 @@ +module Commands.Annex + ( + ) where diff --git a/overlays/photo-hs/lib/Commands/Debug.hs b/overlays/photo-hs/lib/Commands/Debug.hs new file mode 100644 index 0000000..f219700 --- /dev/null +++ b/overlays/photo-hs/lib/Commands/Debug.hs @@ -0,0 +1,4 @@ +module Commands.Debug + ( + ) where + diff --git a/overlays/photo-hs/lib/Commands/EditMeta.hs b/overlays/photo-hs/lib/Commands/EditMeta.hs new file mode 100644 index 0000000..b6e4a12 --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Commands/Git.hs b/overlays/photo-hs/lib/Commands/Git.hs new file mode 100644 index 0000000..fa3f9dc --- /dev/null +++ b/overlays/photo-hs/lib/Commands/Git.hs @@ -0,0 +1,3 @@ +module Commands.Git + ( + ) where diff --git a/overlays/photo-hs/lib/Commands/Init.hs b/overlays/photo-hs/lib/Commands/Init.hs new file mode 100644 index 0000000..29aeaad --- /dev/null +++ b/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) ++ "`" diff --git a/overlays/photo-hs/lib/Commands/List.hs b/overlays/photo-hs/lib/Commands/List.hs new file mode 100644 index 0000000..89a6b0c --- /dev/null +++ b/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 + } diff --git a/overlays/photo-hs/lib/Constants.hs b/overlays/photo-hs/lib/Constants.hs new file mode 100644 index 0000000..cfb3d95 --- /dev/null +++ b/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" + ] diff --git a/overlays/photo-hs/lib/Database/Esqueleto/Experimental/Monad.hs b/overlays/photo-hs/lib/Database/Esqueleto/Experimental/Monad.hs new file mode 100644 index 0000000..bb3d4d2 --- /dev/null +++ b/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) diff --git a/overlays/photo-hs/lib/Exif/Tool.hs b/overlays/photo-hs/lib/Exif/Tool.hs new file mode 100644 index 0000000..152b9d5 --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Git.hs b/overlays/photo-hs/lib/Git.hs new file mode 100644 index 0000000..15ebb92 --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Git/Annex.hs b/overlays/photo-hs/lib/Git/Annex.hs new file mode 100644 index 0000000..332399f --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/MyLib.hs b/overlays/photo-hs/lib/MyLib.hs new file mode 100644 index 0000000..454494e --- /dev/null +++ b/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 () diff --git a/overlays/photo-hs/lib/Options.hs b/overlays/photo-hs/lib/Options.hs new file mode 100644 index 0000000..9e1b9bb --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Percept/Error.hs b/overlays/photo-hs/lib/Percept/Error.hs new file mode 100644 index 0000000..0ac556f --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/lib/Percept/Operations.hs b/overlays/photo-hs/lib/Percept/Operations.hs new file mode 100644 index 0000000..db4c944 --- /dev/null +++ b/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 () diff --git a/overlays/photo-hs/lib/Percept/Util.hs b/overlays/photo-hs/lib/Percept/Util.hs new file mode 100644 index 0000000..5461f41 --- /dev/null +++ b/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) () diff --git a/overlays/photo-hs/lib/Photo.hs b/overlays/photo-hs/lib/Photo.hs new file mode 100644 index 0000000..8c39316 --- /dev/null +++ b/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 + diff --git a/overlays/photo-hs/lib/Schema.hs b/overlays/photo-hs/lib/Schema.hs new file mode 100644 index 0000000..45fcc89 --- /dev/null +++ b/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 +|] + diff --git a/overlays/photo-hs/lib/TH.hs b/overlays/photo-hs/lib/TH.hs new file mode 100644 index 0000000..58562e2 --- /dev/null +++ b/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 } diff --git a/overlays/photo-hs/photo-hs.cabal b/overlays/photo-hs/photo-hs.cabal new file mode 100644 index 0000000..0e2a57b --- /dev/null +++ b/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 diff --git a/overlays/photo-hs/test/Main.hs b/overlays/photo-hs/test/Main.hs new file mode 100644 index 0000000..3e2059e --- /dev/null +++ b/overlays/photo-hs/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."