Configurability

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";
 }

dhall/Config/Type.dhall

@@ -0,0 +1,3 @@
+{ s3 : ../S3/Type.dhall
+, watcher : ../Watcher/Type.dhall
+}

dhall/Config/default.dhall

@@ -0,0 +1 @@
+{=}

dhall/Config/package.dhall

@@ -0,0 +1 @@
+{ Type = ./Type.dhall, default = ./default.dhall }

dhall/S3/Type.dhall

@@ -0,0 +1,4 @@
+{ region : Text
+, endpoint : Text
+, bucket : Text
+}

dhall/S3/default.dhall

@@ -0,0 +1 @@
+{=}

dhall/S3/package.dhall

@@ -0,0 +1 @@
+{ Type = ./Type.dhall, default = ./default.dhall }

dhall/Watcher/Type.dhall

@@ -0,0 +1,3 @@
+{ directories : List Text
+, period : Natural
+}

dhall/Watcher/default.dhall

@@ -0,0 +1 @@
+{ period = 300 }

dhall/Watcher/package.dhall

@@ -0,0 +1 @@
+{ Type = ./Type.dhall, default = ./default.dhall }

dhall/package.dhall

@@ -0,0 +1,2 @@
+    ./Config/package.dhall
+/\  { S3 = ./S3/package.dhall, Watcher = ./Watcher/package.dhall }

flake.nix

@@ -43,6 +43,8 @@
           sops
 
           hp.eventlog2html
+
+          dhall-lsp-server
         ];
       };
     }

hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

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

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"] }
+    }

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

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

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

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

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 &

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

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
+