Configurability

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 &