88 lines
3.2 KiB
Haskell
88 lines
3.2 KiB
Haskell
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
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 (newEnv, Region(..), Env, Env'(..), setEndpoint, runResourceT, send, chunkedFile, defaultChunkSize)
|
|
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 Data.HashMap.Strict (HashMap)
|
|
import Data.Text (Text)
|
|
import qualified Data.HashMap.Strict as HM
|
|
|
|
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)
|
|
}
|
|
deriving Show
|
|
|
|
imageToMetadata :: Image -> HashMap Text Text
|
|
imageToMetadata img = HM.fromList [("sha256", T.pack . show . imageHash $ 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")
|
|
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)
|
|
|
|
someFunc :: IO ()
|
|
someFunc = do
|
|
discoveredEnv <- newEnv discover
|
|
let env = discoveredEnv
|
|
{ region = Region' "fr-par"
|
|
, overrides = setEndpoint True "s3.fr-par.scw.cloud" 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"
|
|
store <- newStore
|
|
waiMetrics <- registerWaiMetrics store
|
|
registerGcMetrics store
|
|
runSettings settings (metrics waiMetrics $ app store)
|
|
where
|
|
settings =
|
|
defaultSettings &
|
|
setPort 8099
|
|
-- setOnException onException
|