Basic backup functionality

.gitignore

@@ -1,3 +1,5 @@
 .direnv
 .envrc
 dist-newstyle
+*.eventlog*
+*.hp

.sops.yaml

@@ -0,0 +1,3 @@
+creation_rules:
+  - path_regex: "secrets.yaml$"
+    pgp: "95DBE64C2EA64D6B0E0C8C2F9DE6E04ED1918118"

default.nix

@@ -1,7 +1,7 @@
 { mkDerivation, amazonka, amazonka-s3, base, bytestring, conduit
-, cryptonite, directory, ekg-core, filepath, lib, mtl, servant
+, cryptonite, directory, ekg-core, filepath, generic-lens, lens
-, servant-server, sqlite-simple, text, unordered-containers, wai
+, lib, mtl, servant, servant-server, sqlite-simple, text, unliftio
-, wai-middleware-metrics, warp
+, unordered-containers, wai, wai-middleware-metrics, warp
 }:
 mkDerivation {
   pname = "image-backup";
@@ -11,8 +11,9 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     amazonka amazonka-s3 base bytestring conduit cryptonite directory
-    ekg-core filepath mtl servant servant-server sqlite-simple text
+    ekg-core filepath generic-lens lens mtl servant servant-server
-    unordered-containers wai wai-middleware-metrics warp
+    sqlite-simple text unliftio unordered-containers wai
+    wai-middleware-metrics warp
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [ base ];

flake.nix

@@ -27,7 +27,7 @@
     in {
       devShell = hp.shellFor {
         packages = h: [h.image-backup];
-        withHoogle = false;
+        withHoogle = true; # Enabling hoogle because of amazonka-2
         buildInputs = with pkgs; [
           cabal-install
           hp.hlint
@@ -39,6 +39,10 @@
           hp.graphmod
 
           hp.haskell-language-server
+
+          sops
+
+          hp.eventlog2html
         ];
       };
     }

image-backup.cabal

@@ -87,6 +87,9 @@ library
                     , unordered-containers
                     , wai
                     , warp
+                    , unliftio
+                    , lens
+                    , generic-lens
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -117,7 +120,7 @@ executable image-backup
 
     -- Base language which the package is written in.
     default-language: Haskell2010
-    ghc-options:       -threaded -with-rtsopts=-T
+    ghc-options:       -threaded -with-rtsopts=-T -eventlog -finfo-table-map -fdistinct-constructor-tables -rtsopts
 
 test-suite image-backup-test
     -- Import common warning flags.

secrets.yaml

@@ -0,0 +1,33 @@
+AWS_ACCESS_KEY_ID: ENC[AES256_GCM,data:Kh5orSwK+1IKUkxqL918wXnDTVo=,iv:s5CV/q4KibAFqAtawPe+6usZ9wqlkxhArPRJFXCd3r4=,tag:3dGqerYkWVS9kQQUsm8Vnw==,type:str]
+AWS_SECRET_KEY: ENC[AES256_GCM,data:vTSTYgksBPgVwQU/KLmLrrU47FhJoR93KbZqsDEKOJuOPzV6,iv:z2z169DxFa7wx/7AbSdgSCeZpUi+dqv9Co1WM01Ija4=,tag:TshCQPq1e+ym6k7XCWOf9A==,type:str]
+sops:
+    kms: []
+    gcp_kms: []
+    azure_kv: []
+    hc_vault: []
+    age: []
+    lastmodified: "2023-02-13T07:31:42Z"
+    mac: ENC[AES256_GCM,data:Uh4fyZmTOMMp1LKEajUJMiOFn2dnnRiODCqoTsvYkK9CjJJ040yx4RpxD3mVlIuJPs/lH0XsQTJN2lI4mFCaxc5M2rVQPADYIuvBThjp8A2stvkMPBQ9YaZphHM7rBl2+E+hsepqo5TbecPYWIQXAs2L4X7e+Dab6CH4OTmqiwI=,iv:3YyqIcZP3Fakadk3FqbAr7sdsXb+kl0J/Oc/un1K/es=,tag:Zwvh+AJC7XgHTdAQvnHdrg==,type:str]
+    pgp:
+        - created_at: "2023-02-13T07:31:04Z"
+          enc: |-
+            -----BEGIN PGP MESSAGE-----
+
+            wcFMA4gPJmmgK0uyARAAhiVs6F2+MkmY124mkUB+d2sxj1ZHpYqJjn4yo2dMnocm
+            A/VYHpXfxO+BuUBQ+yxu2wYk3Um+gVunXOLUkCIH4dKYszkU7lj5gSqzKcytvT8X
+            BQY3jSGeb1/kPBDKvx/3ntNwUS/2n3JyLIn7InVm33mnJgraoAL03pDxCUG/9jw3
+            LgtYyx7pr0WKCXTWqpzhRfisG7QzlxPzPV1YlbC2SRGufYrvTkfmu5jSyb33WDNP
+            wRWB+U8Aw1soeEMNEP4RlvK8sWr2imEno0+HLYlMbL5Omg3N5DRarNse/LQfDLhb
+            L/Rd7IvM/BJ010iqNTMnQyfNVktd5+/GHP4BghHH3a8Yn5og9mxVNhWz+cOOZH+/
+            NW5Go7c2xiXvkzOFBe4DoRicXjXxzc5KewcatX+QTBiM2A9SChv2fZkj+khYn5Qe
+            P7c/ymlCHF9up4t+ThPuzeLyjQzMBkrnSgvyQ7JT0LeEfvM9Zwo8/oXc9DB8Rknu
+            Pt7wCaKLWWsrisdGyrSdIJ8n8MrM+4k0+VSA69IofH+q9R2anEOcSQUyhjq0G8Lt
+            lYZC4DqgiPTTz5rdYf9RNhsD9wrkFVjqeU4zAOkVx89DcmanTIX65udrCoZKLANW
+            2h1vT+Vccs8BcMNXtqSlAqmx1eEY95T8ugVtacZMBeQQVN/XYfXynJFJGn5pSPHS
+            UQGN5x/W2RMnOPHtWKp5Cyg3/do6Kttza4EFH5jtQd23eSLFJCpkO9+rjTB5y3mL
+            H5bncvN3D4DZx//WwxZNSeRNnI9DokwlGAuZ9C/+2cn5wA==
+            =N/j1
+            -----END PGP MESSAGE-----
+          fp: 95DBE64C2EA64D6B0E0C8C2F9DE6E04ED1918118
+    unencrypted_suffix: _unencrypted
+    version: 3.7.3

src/MyLib.hs

@@ -1,16 +1,33 @@
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE DeriveGeneric #-}
-module MyLib (someFunc) where
+{-# 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 Data.Function ((&))
 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 }
@@ -21,8 +38,44 @@ 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