image-backup/src/MyLib.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module MyLib  where

import Network.Wai.Metrics (metrics, registerWaiMetrics)
import System.Metrics
       (Store, newStore, registerGcMetrics)
import Servant.Metrics.Prometheus
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort)
import Servant
import GHC.Generics (Generic)
import Conduit (runConduit, (.|), MonadUnliftIO, liftIO, ConduitT, MonadResource)
import System.FilePath (isExtensionOf, takeBaseName)
import qualified Data.Conduit.Combinators as C
import Crypto.Hash (HashAlgorithm, Digest, SHA256)
import qualified Crypto.Hash as Crypto
import Amazonka (Env, runResourceT, send, chunkedFile, defaultChunkSize)
import qualified Amazonka.S3 as S3
import qualified Data.Text as T
import Control.Lens (view, set, (&), (^.))
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 Config.Watcher (Seconds)
import Control.Concurrent (threadDelay)
import UnliftIO (forConcurrently_)
import Data.Word (Word64)
import Image.Fingerprint (dhash)
import Data.Maybe (catMaybes)
import qualified S3.Interface

newtype Routes route
  = Routes { _getMetrics :: route :- MetricsRoute }
  deriving (Generic)

type API = NamedRoutes Routes

app :: Store -> Application
app store = serve (Proxy @API) Routes { _getMetrics = metricsServer store }

hash :: (HashAlgorithm a, MonadUnliftIO m) => FilePath -> m (Digest a)
hash path = C.withSourceFile path $ \source ->
  Crypto.hashFinalize <$> runConduit (source .| C.foldl Crypto.hashUpdate Crypto.hashInit)

data Image = Image
  { imagePath :: !FilePath
  , imageHash :: !(Digest SHA256)
  , imageFingerprint :: !(Maybe Word64)
  }
  deriving Show

imageToMetadata :: Image -> HashMap Text Text
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 #metadata mt & set #contentType (Just "image/jpeg")
        key = S3.ObjectKey (T.pack . takeBaseName . imagePath $ img)
        mt = imageToMetadata img
    send env putObj

scan :: (MonadResource m) => FilePath -> (FilePath -> Bool) -> ConduitT () FilePath m ()
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 <*> fingerprint p)
  where
    fingerprint = fmap (either (const Nothing) Just) . liftIO . dhash


watcher :: S3.Interface.S3Interface -> FilePath -> Seconds -> IO ()
watcher int path delay = forever $ do
  runResourceT $ runConduit $ scan path (isExtensionOf ".jpg")
        .| analyze
        .| C.iterM (liftIO . print)
        .| C.map (\img -> (imagePath img, imageToMetadata img))
        .| C.mapM_ (void . liftIO . uncurry (S3.Interface.putFile int))
  threadDelay (fromIntegral (view #seconds delay) * 100_000)

someFunc :: IO ()
someFunc = do
  confPath <- getEnv "CONFIG_PATH"
  conf <- Dhall.inputFile (Dhall.auto @Config) confPath
  s3Interface <- S3.Interface.buildInterface (conf ^. #s3)
  store <- newStore
  waiMetrics <- registerWaiMetrics store
  registerGcMetrics store
  let watchers = [watcher s3Interface 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 &
      setPort 8099
      -- setOnException onException