From dffc26233421225f891b8e24d912b0a8e89e5a73 Mon Sep 17 00:00:00 2001 From: magic_rb Date: Thu, 25 Jul 2024 15:01:00 +0200 Subject: [PATCH] Extract `percept` to https://codeberg.org/magic_rb/percept Signed-off-by: magic_rb --- flake.lock | 18 + flake.nix | 4 +- overlays/photo-hs/.gitignore | 1 - overlays/photo-hs/CHANGELOG.md | 2 - overlays/photo-hs/LICENSE | 165 --------- overlays/photo-hs/default.nix | 18 - overlays/photo-hs/exe/Main.hs | 6 - overlays/photo-hs/lib/.dir-locals.el | 4 - overlays/photo-hs/lib/AppData.hs | 33 -- overlays/photo-hs/lib/Commands.hs | 13 - overlays/photo-hs/lib/Commands/AddPhoto.hs | 80 ----- overlays/photo-hs/lib/Commands/Annex.hs | 3 - overlays/photo-hs/lib/Commands/Debug.hs | 4 - overlays/photo-hs/lib/Commands/EditMeta.hs | 106 ------ overlays/photo-hs/lib/Commands/Git.hs | 3 - overlays/photo-hs/lib/Commands/Init.hs | 39 --- overlays/photo-hs/lib/Commands/List.hs | 112 ------ overlays/photo-hs/lib/Commands/Serve.hs | 73 ---- overlays/photo-hs/lib/Constants.hs | 30 -- .../Database/Esqueleto/Experimental/Monad.hs | 93 ----- overlays/photo-hs/lib/Exif/Tool.hs | 41 --- overlays/photo-hs/lib/Git.hs | 102 ------ overlays/photo-hs/lib/Git/Annex.hs | 30 -- overlays/photo-hs/lib/MyLib.hs | 150 -------- overlays/photo-hs/lib/Options.hs | 319 ------------------ overlays/photo-hs/lib/Percept/Editor.hs | 39 --- overlays/photo-hs/lib/Percept/Error.hs | 54 --- overlays/photo-hs/lib/Percept/Operations.hs | 127 ------- overlays/photo-hs/lib/Percept/Util.hs | 27 -- overlays/photo-hs/lib/Photo.hs | 86 ----- overlays/photo-hs/lib/Schema.hs | 46 --- overlays/photo-hs/lib/TH.hs | 6 - overlays/photo-hs/package.nix | 66 ---- overlays/photo-hs/photo-hs.cabal | 194 ----------- overlays/photo-hs/test/Main.hs | 4 - 35 files changed, 21 insertions(+), 2077 deletions(-) delete mode 100644 overlays/photo-hs/.gitignore delete mode 100644 overlays/photo-hs/CHANGELOG.md delete mode 100644 overlays/photo-hs/LICENSE delete mode 100644 overlays/photo-hs/default.nix delete mode 100644 overlays/photo-hs/exe/Main.hs delete mode 100644 overlays/photo-hs/lib/.dir-locals.el delete mode 100644 overlays/photo-hs/lib/AppData.hs delete mode 100644 overlays/photo-hs/lib/Commands.hs delete mode 100644 overlays/photo-hs/lib/Commands/AddPhoto.hs delete mode 100644 overlays/photo-hs/lib/Commands/Annex.hs delete mode 100644 overlays/photo-hs/lib/Commands/Debug.hs delete mode 100644 overlays/photo-hs/lib/Commands/EditMeta.hs delete mode 100644 overlays/photo-hs/lib/Commands/Git.hs delete mode 100644 overlays/photo-hs/lib/Commands/Init.hs delete mode 100644 overlays/photo-hs/lib/Commands/List.hs delete mode 100644 overlays/photo-hs/lib/Commands/Serve.hs delete mode 100644 overlays/photo-hs/lib/Constants.hs delete mode 100644 overlays/photo-hs/lib/Database/Esqueleto/Experimental/Monad.hs delete mode 100644 overlays/photo-hs/lib/Exif/Tool.hs delete mode 100644 overlays/photo-hs/lib/Git.hs delete mode 100644 overlays/photo-hs/lib/Git/Annex.hs delete mode 100644 overlays/photo-hs/lib/MyLib.hs delete mode 100644 overlays/photo-hs/lib/Options.hs delete mode 100644 overlays/photo-hs/lib/Percept/Editor.hs delete mode 100644 overlays/photo-hs/lib/Percept/Error.hs delete mode 100644 overlays/photo-hs/lib/Percept/Operations.hs delete mode 100644 overlays/photo-hs/lib/Percept/Util.hs delete mode 100644 overlays/photo-hs/lib/Photo.hs delete mode 100644 overlays/photo-hs/lib/Schema.hs delete mode 100644 overlays/photo-hs/lib/TH.hs delete mode 100644 overlays/photo-hs/package.nix delete mode 100644 overlays/photo-hs/photo-hs.cabal delete mode 100644 overlays/photo-hs/test/Main.hs diff --git a/flake.lock b/flake.lock index 3433b6a..8f4327d 100644 --- a/flake.lock +++ b/flake.lock @@ -1876,6 +1876,23 @@ "type": "github" } }, + "percept": { + "flake": false, + "locked": { + "lastModified": 1721911937, + "narHash": "sha256-x7jcM1RhgywTmKDqkSlgaD4B7Xd+6I6TzHi2MnY2EiE=", + "ref": "master", + "rev": "ba2d59db1bcdea6f85fd80a9e8d256c66a990911", + "revCount": 6, + "type": "git", + "url": "https://codeberg.org/magic_rb/percept" + }, + "original": { + "ref": "master", + "type": "git", + "url": "https://codeberg.org/magic_rb/percept" + } + }, "pre-commit-hooks": { "inputs": { "flake-compat": [ @@ -2041,6 +2058,7 @@ "nixpkgs-stable": "nixpkgs-stable", "nixpkgs-unstable": "nixpkgs-unstable", "notnft": "notnft", + "percept": "percept", "pre-commit-hooks": "pre-commit-hooks_3", "secret": "secret", "thingiverse-downloader": "thingiverse-downloader", diff --git a/flake.nix b/flake.nix index c28f5ca..62b0b86 100644 --- a/flake.nix +++ b/flake.nix @@ -39,6 +39,8 @@ url = "github:nix-community/haumea/v0.2.2"; inputs.nixpkgs.follows = "nixpkgs"; }; + percept.url = "git+https://codeberg.org/magic_rb/percept?ref=master"; + percept.flake = false; yafas.url = "github:UbiqueLambda/yafas"; yafas.inputs.flake-schemas.follows = "nix-empty-flake"; @@ -158,7 +160,7 @@ overlays/kobo-firmware-extractor overlays/ip-search overlays/perl.nix - overlays/photo-hs + inputs.percept.outPath dev-shells/default.nix diff --git a/overlays/photo-hs/.gitignore b/overlays/photo-hs/.gitignore deleted file mode 100644 index e771b07..0000000 --- a/overlays/photo-hs/.gitignore +++ /dev/null @@ -1 +0,0 @@ -percept diff --git a/overlays/photo-hs/CHANGELOG.md b/overlays/photo-hs/CHANGELOG.md deleted file mode 100644 index f240101..0000000 --- a/overlays/photo-hs/CHANGELOG.md +++ /dev/null @@ -1,2 +0,0 @@ -# Revision history for photo-hs - diff --git a/overlays/photo-hs/LICENSE b/overlays/photo-hs/LICENSE deleted file mode 100644 index 31afd6d..0000000 --- a/overlays/photo-hs/LICENSE +++ /dev/null @@ -1,165 +0,0 @@ - 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/default.nix b/overlays/photo-hs/default.nix deleted file mode 100644 index 43faad7..0000000 --- a/overlays/photo-hs/default.nix +++ /dev/null @@ -1,18 +0,0 @@ -{...}: { - flake.overlays.percept = final: prev: let - inherit - (final.haskell.lib) - markUnbroken - ; - inherit - (final.haskell.lib.compose) - overrideCabal - ; - in { - percept = final.haskellPackages.callPackage ./package.nix { - persistent-mtl = overrideCabal (old: { - doCheck = false; - }) (markUnbroken final.haskellPackages.persistent-mtl); - }; - }; -} diff --git a/overlays/photo-hs/exe/Main.hs b/overlays/photo-hs/exe/Main.hs deleted file mode 100644 index efcc88c..0000000 --- a/overlays/photo-hs/exe/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 6ab4256..0000000 --- a/overlays/photo-hs/lib/.dir-locals.el +++ /dev/null @@ -1,4 +0,0 @@ -;;; 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 deleted file mode 100644 index ca2bbd4..0000000 --- a/overlays/photo-hs/lib/AppData.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# 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 deleted file mode 100644 index bc4692d..0000000 --- a/overlays/photo-hs/lib/Commands.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Commands - ( module Commands.AddPhoto - , module Commands.Init - , module Commands.List - , module Commands.EditMeta - , module Commands.Serve - ) where - -import Commands.AddPhoto -import Commands.Init -import Commands.List -import Commands.EditMeta -import Commands.Serve diff --git a/overlays/photo-hs/lib/Commands/AddPhoto.hs b/overlays/photo-hs/lib/Commands/AddPhoto.hs deleted file mode 100644 index ff204b2..0000000 --- a/overlays/photo-hs/lib/Commands/AddPhoto.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# 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, gitCheckClean, gitAdd) -import qualified Photo as P -import Percept.Operations (calculateImageDigest, readImageCreationUTCTime, inStorePathForPhoto, savePhotoFile, saveMetadataFile, cachePhoto, inStorePathForMetadata) -import Database.Esqueleto.Experimental.Monad -import Percept.Util (guard) - -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 - storeDir <- askStoreDir <&> T.pack - guard (gitCheckClean storeDir) UncleanStore - - 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 - } - photoStorePath <- inStorePathForPhoto photo - metadataPath <- inStorePathForMetadata photo.hash - - whenM (liftIO $ D.doesFileExist photoStorePath) (throw (PhotoAlreadyExists photo)) - - savePhotoFile filePath photo - saveMetadataFile photo - - cachePhoto photo - - gitAnnexAdd (T.unpack storeDir) photoStorePath - gitAdd storeDir [T.pack metadataPath] - _ <- gitCommit 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 deleted file mode 100644 index 697af22..0000000 --- a/overlays/photo-hs/lib/Commands/Annex.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Commands.Annex - ( - ) where diff --git a/overlays/photo-hs/lib/Commands/Debug.hs b/overlays/photo-hs/lib/Commands/Debug.hs deleted file mode 100644 index f219700..0000000 --- a/overlays/photo-hs/lib/Commands/Debug.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Commands.Debug - ( - ) where - diff --git a/overlays/photo-hs/lib/Commands/EditMeta.hs b/overlays/photo-hs/lib/Commands/EditMeta.hs deleted file mode 100644 index 9b1ac67..0000000 --- a/overlays/photo-hs/lib/Commands/EditMeta.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Commands.EditMeta - ( commandEditMeta - ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Database.Persist.Monad.Class (MonadSqlQuery) -import qualified Options as O -import qualified Photo as P -import Percept.Operations (readMetadataFile, saveMetadataFile, cachePhoto, inStorePathForPhoto, inStorePathForMetadata, savePhotoFile) -import AppData (AppData, askStoreDir) -import Control.Monad.Reader.Class (MonadReader) -import qualified Data.List as L -import Git (gitAdd, gitCommit, gitCheckClean, gitAddCommitExpected, GitStatus (GitMerged)) -import qualified Data.Text as T -import Data.Functor ((<&>)) -import Percept.Util (handleGitError, guard) -import Control.Monad (when, void, (>=>), forM) -import Percept.Editor (editWait) -import UnliftIO (MonadUnliftIO) -import Control.Monad.Logger (MonadLogger) -import Toml qualified -import Percept.Error (PhotoException(CorruptMetadata, EditorExitedWithError, UncleanStore)) -import Control.Exception (throw) -import System.Process.Typed (ExitCode(ExitSuccess)) -import qualified Data.HashSet as HS -import System.FilePath (makeRelative) -import Commands.List (commandList) -import Data.Maybe (isJust) - -commandEditMeta - :: forall m - . ( MonadUnliftIO m - , MonadLogger m - , MonadIO m - , MonadReader AppData m - , MonadSqlQuery m - ) - => O.Filter - -> Maybe O.EditOperation - -> Maybe O.InteractiveEdit - -> m [P.Photo] -commandEditMeta filter editOp interactive = do - storeDir <- askStoreDir <&> T.pack - guard (gitCheckClean storeDir) UncleanStore - - photos <- - if editWithFeh then - -- with feh - commandList filter >>= mapM (editPhoto Nothing) - else - commandList filter >>= mapM (editPhoto Nothing) - - metadataPaths <- forM photos \photo -> inStorePathForMetadata photo.hash - - gitAdd storeDir (map T.pack metadataPaths) - gitCommit storeDir "Edit metadata" - - pure photos - - where - editInteractively :: Bool - editInteractively = isJust interactive - editWithFeh :: Bool - editWithFeh = - case interactive of - Just O.InteractiveEditor -> False - Just O.InteractiveEditorFeh -> True - Nothing -> False - editPhoto - :: Maybe FilePath - -- ^ maybe a path to feh preview link - -> P.Photo - -- ^ photo to edit - -> m P.Photo - editPhoto feh photo = do - let - newPhoto = - case editOp of - Just (O.AddTags tags) -> photo { P.tags = photo.tags `L.union` tags } - Just (O.RemoveTags tags) -> photo { P.tags = photo.tags L.\\ tags } - Just O.ClearTags -> photo { P.tags = [] } - Just (O.SetTags tags) -> photo { P.tags = tags } - Just (O.SetName name) -> photo { P.name = name } - Just (O.SetDescription description) -> photo { P.description = description } - Nothing -> photo - - saveMetadataFile newPhoto - - metadataPath <- inStorePathForMetadata photo.hash - - newPhoto' <- if editInteractively then - let - decodePhoto path = Toml.decodeFileEither P.photoCodec path >>= \case - Left errors -> throw (CorruptMetadata photo.hash errors) - Right photo -> pure photo - in - editWait metadataPath decodePhoto >>= (\case - Just photo -> do - saveMetadataFile photo - pure photo - Nothing -> throw (EditorExitedWithError "TODO" "TODO" ExitSuccess)) . snd - else - pure newPhoto - - - cachePhoto newPhoto' - pure newPhoto' diff --git a/overlays/photo-hs/lib/Commands/Git.hs b/overlays/photo-hs/lib/Commands/Git.hs deleted file mode 100644 index fa3f9dc..0000000 --- a/overlays/photo-hs/lib/Commands/Git.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Commands.Git - ( - ) where diff --git a/overlays/photo-hs/lib/Commands/Init.hs b/overlays/photo-hs/lib/Commands/Init.hs deleted file mode 100644 index 7bf460a..0000000 --- a/overlays/photo-hs/lib/Commands/Init.hs +++ /dev/null @@ -1,39 +0,0 @@ -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 deleted file mode 100644 index 5d121de..0000000 --- a/overlays/photo-hs/lib/Commands/List.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -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, ToSqlSetOperation, PersistField, (||.)) -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) -import Database.Esqueleto.Experimental.From.SqlSetOperation (SqlSetOperation) -import qualified Data.Foldable1 as F -import Data.List (partition) -import Options (NameHashFilter(..)) - --- | @REGEXP@ operator. -regexp :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) -regexp a b = unsafeSqlFunctionParens "REGEXP" (a, b) - -sqliteValueSet :: (PersistField s) => [s] -> SqlSetOperation (SqlExpr (Value s)) -sqliteValueSet list = if - | length list == 1 -> valToSet $ head list - | null list -> error "`sqliteValueSet` is a partial function, not implemented for `[]`" - | otherwise -> foldr (union_ . valToSet) (valToSet $ head list) (tail list) - where - valToSet = toSqlSetOperation . pure @SqlQuery . val - -partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) --- ^ Uses a function to determine which of two output lists an input element should join -partitionWith _ [] = ([],[]) -partitionWith f (x:xs) = case f x of - Left b -> (b:bs, cs) - Right c -> (bs, c:cs) - where (bs,cs) = partitionWith f xs - -commandList :: (MonadIO m, MonadSqlQuery m) => O.Filter -> m [P.Photo] -commandList filter = do - photos <- select do - photos <- from $ table @S.Photo - case filter.nameHash of - [] -> pure () - nameHash -> - let - (names, hashes) = flip partitionWith nameHash \case - NameFilter { name } -> Left name - HashFilter { hash } -> Right hash - in - -- if filter.useRegex then - -- where_ (photos ^. S.PhotoName `regexp` val name) - -- else - -- where_ (photos ^. S.PhotoName ==. val name) - where_ (photos ^. S.PhotoName `in_` valList names ||. (photos ^. S.PhotoHash `in_` valList hashes)) - - case filter.tags of - Just (O.TagsAll (tag:tags)) -> - where_ $ notExists $ void $ from $ - sqliteValueSet (map P.unTag (tag: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 () - Just O.TagsNone -> - where_ $ notExists $ void $ from $ - do - taggedPhotos <- from $ table @S.TaggedPhoto - - where_ ( taggedPhotos ^. S.TaggedPhotoPhotoHash ==. photos ^. S.PhotoHash ) - - pure (val (1 :: Int)) - 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/Commands/Serve.hs b/overlays/photo-hs/lib/Commands/Serve.hs deleted file mode 100644 index 46b1f7e..0000000 --- a/overlays/photo-hs/lib/Commands/Serve.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Commands.Serve - ( commandServe - ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) -import Database.Persist.Monad.Class (MonadSqlQuery) -import qualified Options as O -import qualified Photo as P -import Servant ((:>), Get, JSON, Server, Application, serve, ServerT, hoistServer, Handler, (:<|>)(..)) -import Network.Wai.Handler.Warp (run) -import Servant.API (Accept(..), MimeRender (..), Capture) -import Network.HTTP.Media.MediaType ((//)) -import Data.Proxy (Proxy(..)) -import Data.ByteString.Lazy (ByteString) -import AppData (AppData) -import Control.Monad.Reader.Class (MonadReader) -import Percept.Operations (inStorePathForPhoto) -import Data.Functor ((<&>)) -import qualified Data.ByteString.Lazy as BSL -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy.Encoding as TL -import Commands.List (commandList) -import qualified Data.Text.Lazy as TL - -newtype PhotoData - = PhotoData - { _data :: ByteString - } - -data Image -instance Accept Image where - contentType _ = "image" // "jxl" -instance MimeRender Image PhotoData where - mimeRender _ photoData = photoData._data - -data HTML -instance Accept HTML where - contentType _ = "text" // "html" -instance MimeRender HTML Text where - mimeRender _ = TL.encodeUtf8 - - -type PerceptServeAPI - = "photo" :> Capture "hash" P.Hash :> Get '[Image] PhotoData - :<|> "index" :> Get '[HTML] Text - -servePhoto :: (MonadIO m, MonadReader AppData m) => P.Hash -> m PhotoData -servePhoto hash = do - photoStorePath <- inStorePathForPhoto (P.Photo { hash = hash, imageType = "jxl" }) - liftIO $ BSL.readFile photoStorePath <&> PhotoData - -serveIndex :: (MonadIO m, MonadReader AppData m) => [P.Photo] -> m Text -serveIndex photos = - pure . TL.unlines $ map (TL.fromStrict . \photo -> - let - photoUrl = "/photo/" <> P.unHash photo.hash - in - "" <> photo.name <> " " <> "
" - ) photos - -perceptServer :: (MonadIO m, MonadReader AppData m) => [P.Photo] -> ServerT PerceptServeAPI m -perceptServer photos - = servePhoto - :<|> serveIndex photos - -commandServe :: (MonadIO m, MonadUnliftIO m, MonadSqlQuery m, MonadReader AppData m) => O.Filter -> m () -commandServe filter = do - photos <- commandList filter - - withRunInIO \unlift -> - run 8081 . serve (Proxy @PerceptServeAPI) $ hoistServer (Proxy @PerceptServeAPI) (liftIO . unlift) (perceptServer photos) - - pure () diff --git a/overlays/photo-hs/lib/Constants.hs b/overlays/photo-hs/lib/Constants.hs deleted file mode 100644 index cfb3d95..0000000 --- a/overlays/photo-hs/lib/Constants.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# 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 deleted file mode 100644 index bb3d4d2..0000000 --- a/overlays/photo-hs/lib/Database/Esqueleto/Experimental/Monad.hs +++ /dev/null @@ -1,93 +0,0 @@ -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 deleted file mode 100644 index d799c2c..0000000 --- a/overlays/photo-hs/lib/Exif/Tool.hs +++ /dev/null @@ -1,41 +0,0 @@ -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 "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 "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 deleted file mode 100644 index bdca993..0000000 --- a/overlays/photo-hs/lib/Git.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Git (GitStatus(..), gitCommit, gitInit, gitAdd, gitStatus, gitCheckClean, gitAddCommitExpected) where - -import Data.Text (Text) -import Control.Monad.IO.Class (MonadIO, liftIO) -import System.Process.Typed (proc, runProcess, ExitCode, setWorkingDir, readProcess, readProcess_, readProcessStdout_) -import qualified Data.Text as T -import Data.Function ((&)) -import qualified System.Directory as D -import Data.Functor ((<&>)) -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Data.Text.Encoding as T -import Data.HashSet (HashSet) -import qualified Data.HashSet as HS -import Data.Hashable (Hashable) -import GHC.Generics (Generic) -import Control.Monad (forM_) - -data GitStatus - = GitMerged - { name :: Text } - deriving (Show, Eq, Generic, Hashable) - - -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 filePaths = do - let - pc = proc "git" ("add" : map T.unpack filePaths) - & setWorkingDir (T.unpack repoPath) - - runProcess pc - -gitStatus - :: ( MonadIO m - ) - => Text - -> m (HashSet GitStatus) -gitStatus repoPath = do - let - pc = proc "git" ["status", "--porcelain=v1"] - & setWorkingDir (T.unpack repoPath) - - readProcessStdout_ pc <&> HS.fromList . map (GitMerged . T.drop 3 . T.decodeUtf8 . BS.toStrict) . BS.lines - --- | checks whether the repo is in a clean state, return `True` if it is -gitCheckClean - :: ( MonadIO m - ) - => Text - -- ^ repo path - -> m Bool -gitCheckClean repoPath = gitStatus repoPath <&> (==) HS.empty - - --- | Checks that the changed files in the git repo, match the expected set of changed files. --- | Catches accidental changes early. -gitAddCommitExpected - :: ( MonadIO m - ) - => Text - -- ^ repo path - -> HashSet GitStatus - -- ^ expected changes - -> Text - -- ^ commit message - -> m (Either (HashSet GitStatus) ExitCode) -gitAddCommitExpected repoPath changes message = do - currentChanges <- gitStatus repoPath - - if changes == currentChanges then do - gitAdd repoPath (map (\(GitMerged file) -> file) $ HS.toList changes) - Right <$> gitCommit repoPath message - else - pure $ Left currentChanges - diff --git a/overlays/photo-hs/lib/Git/Annex.hs b/overlays/photo-hs/lib/Git/Annex.hs deleted file mode 100644 index 332399f..0000000 --- a/overlays/photo-hs/lib/Git/Annex.hs +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100644 index 41914b9..0000000 --- a/overlays/photo-hs/lib/MyLib.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# 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, forM_) -import Options (Command (..), Options (..), SomeCommand (..), parseOptions) -import AppData (AppData (..), askStoreDir) -import Commands (commandAddPhoto, commandInit, commandList, commandEditMeta, commandServe) -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, MonadUnliftIO 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 - forM_ photos (liftIO . print) - - EditMeta filter editOp interactive -> do - _ <- commandEditMeta filter editOp interactive - pure () - - Serve filter -> commandServe filter - - 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, MonadUnliftIO) - -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 deleted file mode 100644 index 043dfed..0000000 --- a/overlays/photo-hs/lib/Options.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Options - ( Command(..) - , NameHashFilter(..) - , Filter(..) - , TagFilter(..) - , InteractiveEdit(..) - , 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] - | TagsNone - deriving Show - -data NameHashFilter - = NameFilter - { name :: Text - } - | HashFilter - { hash :: P.Hash - } - deriving Show - -data Filter - = Filter - { nameHash :: [NameHashFilter] - , 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 InteractiveEdit - = InteractiveEditor - | InteractiveEditorFeh - 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 - :: Filter - -- ^ photo which to edit - -> Maybe EditOperation - -- ^ operation to carry out - -> Maybe InteractiveEdit - -- ^ interactive - -> Command P.Photo - Serve - :: Filter - -- ^ photos to serve - -> Command () - 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 filter operation interactive) = "EditMeta { hash = " ++ show filter ++ ", operation = " ++ show operation ++ ", interactive = " ++ show interactive ++ " }" - show (Serve filter) = "Serve { filter = " ++ show filter ++ " }" - 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' - )) - -parseFilter :: Parser Filter -parseFilter - = Filter - <$> many (argument (parseHash <|> parseName) (metavar "HASH | NAME")) - <*> optional (parseTagFilterAll <|> parseTagFilterSome <|> parseTagFilterNone) - <*> switch - ( long "regex" - <> short 'r' - ) - where - parseName :: ReadM NameHashFilter - parseName = str <&> NameFilter - - parseHash :: ReadM NameHashFilter - parseHash = maybeReader ((<&> HashFilter) . P.mkHash . T.pack) - - 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')) - - - parseTagFilterNone :: Parser TagFilter - parseTagFilterNone = flag' TagsNone - ( long "none" - <> help "The entry must have no tags" - ) - - -parseCommandList :: Parser (Command [P.Photo]) -parseCommandList - = List - <$> parseFilter - -parseCommandEditMeta :: Parser (Command P.Photo) -parseCommandEditMeta - = EditMeta - <$> parseFilter - <*> optional ( parseAddTags - <|> parseRemoveTags - <|> parseClearTags - <|> parseSetTags - <|> parseSetName - <|> parseSetDescription - ) - <*> optional - ( flag' InteractiveEditor - ( long "interactive" - <> short 'i' - <> help "Edit interactively using a text editor." - ) - <|> flag' InteractiveEditorFeh - ( long "feh" - <> short 'f' - <> help "Edit interactively using a text editor and feh." - ) - ) - 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" ) - -parseCommandServe :: Parser (Command ()) -parseCommandServe = - Serve <$> parseFilter - -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 "serve" (info (parseCommandServe <**> helper <&> SomeCommand) (progDesc descServe)) - <> 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" - descServe = "Serve the photo store, optionally with a filter" - 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/Editor.hs b/overlays/photo-hs/lib/Percept/Editor.hs deleted file mode 100644 index f42b580..0000000 --- a/overlays/photo-hs/lib/Percept/Editor.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Percept.Editor - ( editWait - ) where -import System.Process.Typed (ExitCode (..), proc, runProcess) -import qualified System.Directory as D -import Control.Monad.Extra (unlessM) -import System.Environment.Blank (getEnv) -import Control.Monad.Logger (logWarnN, MonadLogger) -import Control.Monad.IO.Class (liftIO, MonadIO) -import System.FilePath (takeBaseName, takeExtension) -import UnliftIO.Temporary (withSystemTempFile) -import System.IO (hClose) -import UnliftIO (MonadUnliftIO) - -editWait :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => FilePath -> (FilePath -> m a) -> m (ExitCode, Maybe a) -editWait fileToEdit onSuccess = do - unlessM (liftIO $ D.doesFileExist fileToEdit) undefined - - let - basename = takeBaseName fileToEdit - ext = takeExtension fileToEdit - - withSystemTempFile (basename <> "." <> ext) \tempFile handle -> do - liftIO $ hClose handle >> D.copyFile fileToEdit tempFile - - let - defaultToNano :: (Monad m, MonadLogger m) => Maybe String -> m String - defaultToNano (Just editor) = pure editor - defaultToNano Nothing = - logWarnN "Defaulting text editor to `nano`, use the `EDITOR` environment variable to override." >> - pure "nano" - editor <- liftIO (getEnv "EDITOR") >>= defaultToNano - - let - pc = proc editor [tempFile] - - runProcess pc >>= \case - ExitSuccess -> onSuccess tempFile >>= \a -> pure (ExitSuccess, Just a) - ExitFailure code -> pure (ExitFailure code, Nothing) diff --git a/overlays/photo-hs/lib/Percept/Error.hs b/overlays/photo-hs/lib/Percept/Error.hs deleted file mode 100644 index 0a7210f..0000000 --- a/overlays/photo-hs/lib/Percept/Error.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Percept.Error - ( PhotoException(..) - ) where - -import System.Process.Typed (ExitCode) -import GHC.Exception (Exception(..)) -import Photo qualified as P -import qualified Toml -import Data.Text (Text) -import qualified Data.Text as T - -data PhotoException where - GitInitFailed :: ExitCode -> PhotoException - PhotoDirNotFound :: PhotoException - UnknownCreationTime :: PhotoException - InconsistentDatabaseState :: PhotoException - PhotoAlreadyExists :: P.Photo -> PhotoException - CorruptMetadata :: P.Hash -> [Toml.TomlDecodeError] -> PhotoException - -- | indicates that upon an interacitve edit of photo metadata, - -- | the editor used existed with a non 0 exit code - EditorExitedWithError - :: Text - -- ^ editor - -> Text - -- ^ error - -> ExitCode - -- ^ exit code - -> PhotoException - -- | the store directory (backing git annex repository) was in a an unclean state, - -- | manual intervention is needed - UncleanStore - :: 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 - displayException (EditorExitedWithError editor error exitcode) = - "Editor `" <> T.unpack editor <> "` exited with exitcode `" <> show exitcode <> "`, full message follows:" <> T.unpack error - displayException UncleanStore = - "The store directory is in an unclean state, use `percept git` to clean it" diff --git a/overlays/photo-hs/lib/Percept/Operations.hs b/overlays/photo-hs/lib/Percept/Operations.hs deleted file mode 100644 index 2dda25b..0000000 --- a/overlays/photo-hs/lib/Percept/Operations.hs +++ /dev/null @@ -1,127 +0,0 @@ -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", "Date/Time Original"] - - let - parseTime :: Monad m => String -> T.Text -> m (Maybe ZonedTime) - parseTime format = pure . parseTimeM True defaultTimeLocale format . T.unpack - - liftIO $ print hashmap - - case hashmap of - Nothing -> pure Nothing - Just hashmap' -> - case (hashmap' HM.!? "DateTimeOriginal", hashmap' HM.!? "OffsetTimeOriginal") of - (Nothing, _) -> - case hashmap' HM.!? "Date/Time Original" of - Just time -> parseTime "%Y:%m:%d %H:%M:%S" time - Nothing -> pure Nothing - (Just time, Just offset) -> parseTime "%Y:%m:%d %H:%M:%S%z" (time <> offset) - (Just time, Nothing) -> parseTime "%Y:%m:%d %H:%M:%S" 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 deleted file mode 100644 index 3537b8e..0000000 --- a/overlays/photo-hs/lib/Percept/Util.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Percept.Util - ( handleExitCode - , handleGitError - , guard - , (<$/>) - ) where - -import System.Process.Typed (ExitCode (..)) -import Data.Text (Text) -import Control.Exception (throw, Exception) -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) () - -guard :: (Monad m, Exception e) => m Bool -> e -> m () -guard pred exception = pred >>= \case - True -> pure () - False -> throw exception diff --git a/overlays/photo-hs/lib/Photo.hs b/overlays/photo-hs/lib/Photo.hs deleted file mode 100644 index f9d2510..0000000 --- a/overlays/photo-hs/lib/Photo.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Photo - ( Photo(..) - , photoCodec - , Tag(..) - , unTag - , Hash(..) - , mkHash - , 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 - ) - -mkHash :: Text -> Maybe Hash -mkHash text = - if T.length text == 64 then - Just $ Hash text - else - Nothing - -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 deleted file mode 100644 index 45fcc89..0000000 --- a/overlays/photo-hs/lib/Schema.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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 deleted file mode 100644 index 58562e2..0000000 --- a/overlays/photo-hs/lib/TH.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TH(customSqlSettings) where - -import Database.Persist.TH (MkPersistSettings (..), sqlSettings) - -customSqlSettings :: MkPersistSettings -customSqlSettings = sqlSettings { mpsFieldLabelModifier = \_ field -> field } diff --git a/overlays/photo-hs/package.nix b/overlays/photo-hs/package.nix deleted file mode 100644 index 5c81811..0000000 --- a/overlays/photo-hs/package.nix +++ /dev/null @@ -1,66 +0,0 @@ -{ - mkDerivation, - aeson, - base, - bytestring, - crypton, - directory, - esqueleto, - extra, - filepath, - hashable, - http-api-data, - lib, - monad-logger, - mtl, - optparse-applicative, - path-pieces, - persistent, - persistent-mtl, - persistent-sqlite, - temporary, - text, - time, - tomland, - typed-process, - unliftio, - unordered-containers, -}: -mkDerivation { - pname = "photo-hs"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson - base - bytestring - crypton - directory - esqueleto - extra - filepath - hashable - http-api-data - monad-logger - mtl - optparse-applicative - path-pieces - persistent - persistent-mtl - persistent-sqlite - temporary - text - time - tomland - typed-process - unliftio - unordered-containers - ]; - executableHaskellDepends = [base]; - testHaskellDepends = [base]; - homepage = "redalder.org"; - license = lib.licenses.lgpl3Plus; - mainProgram = "photo-hs"; -} diff --git a/overlays/photo-hs/photo-hs.cabal b/overlays/photo-hs/photo-hs.cabal deleted file mode 100644 index 2356995..0000000 --- a/overlays/photo-hs/photo-hs.cabal +++ /dev/null @@ -1,194 +0,0 @@ -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, - Commands.Serve, - Photo, - Exif.Tool, - Percept.Error, - Percept.Util, - Percept.Operations, - Percept.Editor, - 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, - unliftio-core, - directory, - extra, - crypton, - unordered-containers, - tomland, - temporary, - hashable, - servant, - servant-server, - wai, - warp, - http-media, - - - -- 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, - photo-hs diff --git a/overlays/photo-hs/test/Main.hs b/overlays/photo-hs/test/Main.hs deleted file mode 100644 index 3e2059e..0000000 --- a/overlays/photo-hs/test/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main (main) where - -main :: IO () -main = putStrLn "Test suite not yet implemented." -- 2.45.2