From e3807b3adea8dffd7e1239e5338d4be811274ac1 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 15 Feb 2023 20:34:05 +0200 Subject: [PATCH] Configurability --- default.nix | 21 ++++++++------ dhall/Config/Type.dhall | 3 ++ dhall/Config/default.dhall | 1 + dhall/Config/package.dhall | 1 + dhall/S3/Type.dhall | 4 +++ dhall/S3/default.dhall | 1 + dhall/S3/package.dhall | 1 + dhall/Watcher/Type.dhall | 3 ++ dhall/Watcher/default.dhall | 1 + dhall/Watcher/package.dhall | 1 + dhall/package.dhall | 2 ++ flake.nix | 2 ++ hie.yaml | 2 ++ image-backup.cabal | 22 +++++++++++--- sample_config.dhall | 6 ++++ src/Config.hs | 19 +++++++++++++ src/Config/S3.hs | 18 ++++++++++++ src/Config/Watcher.hs | 20 +++++++++++++ src/Image/Fingerprint.hs | 42 +++++++++++++++++++++++++++ src/MyLib.hs | 57 ++++++++++++++++++++++++++++--------- test/Main.hs | 6 +++- test/Test/Config.hs | 29 +++++++++++++++++++ 22 files changed, 236 insertions(+), 26 deletions(-) create mode 100644 dhall/Config/Type.dhall create mode 100644 dhall/Config/default.dhall create mode 100644 dhall/Config/package.dhall create mode 100644 dhall/S3/Type.dhall create mode 100644 dhall/S3/default.dhall create mode 100644 dhall/S3/package.dhall create mode 100644 dhall/Watcher/Type.dhall create mode 100644 dhall/Watcher/default.dhall create mode 100644 dhall/Watcher/package.dhall create mode 100644 dhall/package.dhall create mode 100644 hie.yaml create mode 100644 sample_config.dhall create mode 100644 src/Config.hs create mode 100644 src/Config/S3.hs create mode 100644 src/Config/Watcher.hs create mode 100644 src/Image/Fingerprint.hs create mode 100644 test/Test/Config.hs diff --git a/default.nix b/default.nix index 58066a1..3177a6c 100644 --- a/default.nix +++ b/default.nix @@ -1,7 +1,9 @@ -{ mkDerivation, amazonka, amazonka-s3, base, bytestring, conduit -, cryptonite, directory, ekg-core, filepath, generic-lens, lens -, lib, mtl, servant, servant-server, sqlite-simple, text, unliftio -, unordered-containers, wai, wai-middleware-metrics, warp +{ mkDerivation, aeson, amazonka, amazonka-s3, base, bytestring +, conduit, cryptonite, dhall, directory, either, ekg-core, filepath +, generic-lens, hedgehog, hspec, hspec-hedgehog, JuicyPixels +, JuicyPixels-extra, lens, lib, mtl, servant, servant-server +, sqlite-simple, text, unliftio, unordered-containers, vector, wai +, wai-middleware-metrics, warp }: mkDerivation { pname = "image-backup"; @@ -10,13 +12,16 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - amazonka amazonka-s3 base bytestring conduit cryptonite directory - ekg-core filepath generic-lens lens mtl servant servant-server - sqlite-simple text unliftio unordered-containers wai + amazonka amazonka-s3 base bytestring conduit cryptonite dhall + directory either ekg-core filepath generic-lens JuicyPixels + JuicyPixels-extra lens mtl servant servant-server sqlite-simple + text unliftio unordered-containers vector wai wai-middleware-metrics warp ]; executableHaskellDepends = [ base ]; - testHaskellDepends = [ base ]; + testHaskellDepends = [ + aeson base dhall either hedgehog hspec hspec-hedgehog + ]; license = lib.licenses.bsd3; mainProgram = "image-backup"; } diff --git a/dhall/Config/Type.dhall b/dhall/Config/Type.dhall new file mode 100644 index 0000000..bd253a7 --- /dev/null +++ b/dhall/Config/Type.dhall @@ -0,0 +1,3 @@ +{ s3 : ../S3/Type.dhall +, watcher : ../Watcher/Type.dhall +} diff --git a/dhall/Config/default.dhall b/dhall/Config/default.dhall new file mode 100644 index 0000000..339130f --- /dev/null +++ b/dhall/Config/default.dhall @@ -0,0 +1 @@ +{=} diff --git a/dhall/Config/package.dhall b/dhall/Config/package.dhall new file mode 100644 index 0000000..3cfe62e --- /dev/null +++ b/dhall/Config/package.dhall @@ -0,0 +1 @@ +{ Type = ./Type.dhall, default = ./default.dhall } diff --git a/dhall/S3/Type.dhall b/dhall/S3/Type.dhall new file mode 100644 index 0000000..10f755c --- /dev/null +++ b/dhall/S3/Type.dhall @@ -0,0 +1,4 @@ +{ region : Text +, endpoint : Text +, bucket : Text +} diff --git a/dhall/S3/default.dhall b/dhall/S3/default.dhall new file mode 100644 index 0000000..339130f --- /dev/null +++ b/dhall/S3/default.dhall @@ -0,0 +1 @@ +{=} diff --git a/dhall/S3/package.dhall b/dhall/S3/package.dhall new file mode 100644 index 0000000..3cfe62e --- /dev/null +++ b/dhall/S3/package.dhall @@ -0,0 +1 @@ +{ Type = ./Type.dhall, default = ./default.dhall } diff --git a/dhall/Watcher/Type.dhall b/dhall/Watcher/Type.dhall new file mode 100644 index 0000000..a66e48c --- /dev/null +++ b/dhall/Watcher/Type.dhall @@ -0,0 +1,3 @@ +{ directories : List Text +, period : Natural +} diff --git a/dhall/Watcher/default.dhall b/dhall/Watcher/default.dhall new file mode 100644 index 0000000..3a6ff5e --- /dev/null +++ b/dhall/Watcher/default.dhall @@ -0,0 +1 @@ +{ period = 300 } diff --git a/dhall/Watcher/package.dhall b/dhall/Watcher/package.dhall new file mode 100644 index 0000000..3cfe62e --- /dev/null +++ b/dhall/Watcher/package.dhall @@ -0,0 +1 @@ +{ Type = ./Type.dhall, default = ./default.dhall } diff --git a/dhall/package.dhall b/dhall/package.dhall new file mode 100644 index 0000000..49525ba --- /dev/null +++ b/dhall/package.dhall @@ -0,0 +1,2 @@ + ./Config/package.dhall +/\ { S3 = ./S3/package.dhall, Watcher = ./Watcher/package.dhall } diff --git a/flake.nix b/flake.nix index c5dfb47..1d8a724 100644 --- a/flake.nix +++ b/flake.nix @@ -43,6 +43,8 @@ sops hp.eventlog2html + + dhall-lsp-server ]; }; } diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..04cd243 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/image-backup.cabal b/image-backup.cabal index 7cba69e..7009cfd 100644 --- a/image-backup.cabal +++ b/image-backup.cabal @@ -61,6 +61,10 @@ library -- Modules exported by the library. exposed-modules: MyLib Servant.Metrics.Prometheus + Config + Config.S3 + Config.Watcher + Image.Fingerprint -- Modules included in this library but not exported. -- other-modules: @@ -76,6 +80,7 @@ library , ekg-core , servant , servant-server + , vector , cryptonite , conduit , filepath @@ -86,10 +91,14 @@ library , wai-middleware-metrics , unordered-containers , wai + , JuicyPixels + , JuicyPixels-extra , warp , unliftio , lens , generic-lens + , dhall + , either -- Directories containing source files. hs-source-dirs: src @@ -130,7 +139,7 @@ test-suite image-backup-test default-language: Haskell2010 -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: Test.Config -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -145,6 +154,11 @@ test-suite image-backup-test main-is: Main.hs -- Test dependencies. - build-depends: - base ^>=4.16.3.0, - image-backup + build-depends: base ^>=4.16.3.0 + , image-backup + , hspec + , hedgehog + , hspec-hedgehog + , dhall + , aeson + , either diff --git a/sample_config.dhall b/sample_config.dhall new file mode 100644 index 0000000..366d193 --- /dev/null +++ b/sample_config.dhall @@ -0,0 +1,6 @@ +let Config = ./dhall/package.dhall + +in Config::{ + , s3 = Config.S3::{ bucket = "example", region = "fr-par", endpoint = "example.com" } + , watcher = Config.Watcher::{ directories = ["/tmp/foo"] } + } diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..17ca7b4 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StrictData #-} +module Config where + +import Dhall.Deriving +import Dhall +import Config.S3 (ConfigS3) +import Config.Watcher (ConfigWatcher) + + +data Config = Config + { s3 :: ConfigS3 + , watcher :: ConfigWatcher + } + deriving (Show, Generic, Eq) + deriving (FromDhall, ToDhall) via Codec (Field AsIs) Config diff --git a/src/Config/S3.hs b/src/Config/S3.hs new file mode 100644 index 0000000..dace23c --- /dev/null +++ b/src/Config/S3.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StrictData #-} +module Config.S3 where + +import Dhall.Deriving +import Dhall + +-- The S3 credentials provided by environment variables +data ConfigS3 = ConfigS3 + { region :: Text + , endpoint :: Text + , bucket :: Text + } + deriving (Show, Generic, Eq) + deriving (FromDhall, ToDhall) via Codec (Field AsIs) ConfigS3 diff --git a/src/Config/Watcher.hs b/src/Config/Watcher.hs new file mode 100644 index 0000000..3d9e986 --- /dev/null +++ b/src/Config/Watcher.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StrictData #-} +module Config.Watcher where + +import Dhall.Deriving +import Dhall + +newtype Seconds = Seconds { seconds :: Natural } + deriving (Show, Generic, Eq) + deriving (FromDhall, ToDhall) via Codec (SetSingletonConstructors Bare) Seconds + +data ConfigWatcher = ConfigWatcher + { directories :: [FilePath] + , period :: Seconds + } + deriving (Show, Generic, Eq) + deriving (FromDhall, ToDhall) via Codec AsIs ConfigWatcher diff --git a/src/Image/Fingerprint.hs b/src/Image/Fingerprint.hs new file mode 100644 index 0000000..a7f9505 --- /dev/null +++ b/src/Image/Fingerprint.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +module Image.Fingerprint where +import Data.Word (Word64) +import Codec.Picture.Types +import qualified Data.Foldable as F +import qualified Data.Vector as V +import Data.Bits (Bits(..)) +import Data.Bool (bool) +import Codec.Picture.Extra (scaleBilinear) +import Data.Maybe (fromMaybe) +import Codec.Picture (convertRGB16, readImage) + +dhash :: FilePath -> IO (Either String Word64) +dhash path = fmap (dynamicMap' process) <$> readImage path + +process :: (LumaPlaneExtractable a, Pixel a, Bounded (PixelBaseComponent a), Integral (PixelBaseComponent a)) => Image a -> Word64 +process img = hash + where + hash = F.foldl' (\acc x -> (acc `shiftL` 1) .|. bool 0 1 x) 0 bits + bits = V.concat [V.generate 8 (\x -> pixelAt scaled x y < pixelAt scaled (x+1) y) | y <- [0..7]] + scaled = extractLumaPlane . scaleBilinear 9 8 $ img + +dynamicMap' :: (forall x. (Bounded (PixelBaseComponent x), Integral (PixelBaseComponent x), LumaPlaneExtractable x) => Image x -> a) -> DynamicImage -> a +dynamicMap' f d = fromMaybe (f (convertRGB16 d)) (go d) + where + go = \case + ImageY8 i -> Just $ f i + ImageY16 i -> Just $ f i + ImageY32 i -> Just $ f i + ImageYF _ -> Nothing + ImageYA8 i -> Just $ f i + ImageYA16 _ -> Nothing + ImageRGB8 i -> Just $ f i + ImageRGB16 i -> Just $ f i + ImageRGBF _ -> Nothing + ImageRGBA8 i -> Just $ f i + ImageRGBA16 _ -> Nothing + ImageYCbCr8 i -> Just $ f i + ImageCMYK8 _ -> Nothing + ImageCMYK16 _ -> Nothing diff --git a/src/MyLib.hs b/src/MyLib.hs index 02c168c..8bab55d 100644 --- a/src/MyLib.hs +++ b/src/MyLib.hs @@ -1,9 +1,12 @@ {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} module MyLib where import Network.Wai.Metrics (metrics, registerWaiMetrics) @@ -22,12 +25,22 @@ import Amazonka (newEnv, Region(..), Env, Env'(..), setEndpoint, runResourceT, s import Amazonka.Auth (discover) import qualified Amazonka.S3 as S3 import qualified Data.Text as T -import Control.Lens (set, (&)) -import Data.Generics.Product (field) -import Control.Monad (void) +import Control.Lens (view, set, (&), re) +import Data.Generics.Labels () +import Control.Monad (void, forever) import Data.HashMap.Strict (HashMap) import Data.Text (Text) import qualified Data.HashMap.Strict as HM +import System.Environment (getEnv) +import qualified Dhall +import Config (Config) +import Data.Text.Strict.Lens (utf8) +import Config.Watcher (Seconds) +import Control.Concurrent (threadDelay) +import UnliftIO (forConcurrently_) +import Data.Word (Word64) +import Image.Fingerprint (dhash) +import Data.Maybe (catMaybes) newtype Routes route = Routes { _getMetrics :: route :- MetricsRoute } @@ -45,17 +58,21 @@ hash path = C.withSourceFile path $ \source -> data Image = Image { imagePath :: !FilePath , imageHash :: !(Digest SHA256) + , imageFingerprint :: !(Maybe Word64) } deriving Show imageToMetadata :: Image -> HashMap Text Text -imageToMetadata img = HM.fromList [("sha256", T.pack . show . imageHash $ img)] +imageToMetadata img = HM.fromList $ catMaybes + [ Just ("sha256", T.pack . show . imageHash $ img) + , ("fingerprint", ) . T.pack . show <$> imageFingerprint img + ] uploadImage :: Env -> S3.BucketName -> Image -> IO S3.PutObjectResponse uploadImage env bucket img = do obj <- chunkedFile defaultChunkSize (imagePath img) runResourceT $ do - let putObj = S3.newPutObject bucket key obj & set (field @"metadata") mt & set (field @"contentType") (Just "image/jpeg") + let putObj = S3.newPutObject bucket key obj & set #metadata mt & set #contentType (Just "image/jpeg") key = S3.ObjectKey (T.pack . takeBaseName . imagePath $ img) mt = imageToMetadata img send env putObj @@ -64,22 +81,36 @@ scan :: (MonadResource m) => FilePath -> (FilePath -> Bool) -> ConduitT () FileP scan root predicate = C.sourceDirectoryDeep False root .| C.filter predicate analyze :: (MonadUnliftIO m) => ConduitT FilePath Image m () -analyze = C.mapM (\p -> Image p <$> hash p) +analyze = C.mapM (\p -> Image p <$> hash p <*> fingerprint p) + where + fingerprint = fmap (either (const Nothing) Just) . liftIO . dhash + + +watcher :: Env -> S3.BucketName -> FilePath -> Seconds -> IO () +watcher env bucket path delay = forever $ do + runResourceT $ runConduit $ scan path (isExtensionOf ".jpg") + .| analyze + .| C.iterM (liftIO . print) + .| C.mapM_ (void . liftIO . uploadImage env bucket) + threadDelay (fromIntegral (view #seconds delay) * 100_000) someFunc :: IO () someFunc = do + confPath <- getEnv "CONFIG_PATH" + conf <- Dhall.inputFile (Dhall.auto @Config) confPath discoveredEnv <- newEnv discover let env = discoveredEnv - { region = Region' "fr-par" - , overrides = setEndpoint True "s3.fr-par.scw.cloud" 443 + { region = Region' $ view (#s3 . #region) conf + , overrides = setEndpoint True (view (#s3 . #endpoint . re utf8) conf) 443 } - bucket = S3.BucketName "introitu-photoprism" - _ <- runResourceT $ runConduit $ scan "/home/masse/wikidata/" (isExtensionOf ".jpg") .| analyze .| C.iterM (liftIO . print) .| C.mapM_ (void . liftIO . uploadImage env bucket) - putStrLn "done" + bucket = S3.BucketName (view (#s3 . #bucket) conf) store <- newStore waiMetrics <- registerWaiMetrics store registerGcMetrics store - runSettings settings (metrics waiMetrics $ app store) + let watchers = [watcher env bucket path (view (#watcher . #period) conf) | path <- view (#watcher . #directories) conf] + actions = ( runSettings settings (metrics waiMetrics $ app store) ) : watchers + forConcurrently_ actions id + -- runSettings settings (metrics waiMetrics $ app store) where settings = defaultSettings & diff --git a/test/Main.hs b/test/Main.hs index 3e2059e..990c4de 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,8 @@ module Main (main) where +import qualified Test.Config +import Test.Hspec (hspec) + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = hspec $ do + Test.Config.spec diff --git a/test/Test/Config.hs b/test/Test/Config.hs new file mode 100644 index 0000000..645b20b --- /dev/null +++ b/test/Test/Config.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.Config where + +import Test.Hspec + +import Config +import Config.Watcher +import Config.S3 +import Dhall (inputFile, auto) +import Control.Monad.IO.Class (MonadIO(..)) + + +spec :: Spec +spec = describe "Reading configuration" $ do + it "Can read the sample configuration" $ do + conf <- liftIO $ inputFile auto "./sample_config.dhall" + let wanted = Config + { watcher = ConfigWatcher + { directories = ["/tmp/foo"] + , period = Seconds 300 + } + , s3 = ConfigS3 + { region = "fr-par" + , endpoint = "example.com" + , bucket = "example" + } + } + conf `shouldBe` wanted +