66 lines
2.3 KiB
Haskell
66 lines
2.3 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module S3.Interface where
|
|
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.Text (Text)
|
|
import Config.S3 (ConfigS3)
|
|
import Amazonka (newEnv, Region(..), Env, Env'(..), setEndpoint, runResourceT, send, chunkedFile, defaultChunkSize, discover, sinkBody, hashedFile, RequestBody (..))
|
|
import qualified Amazonka.S3 as S3
|
|
import Control.Lens (view, re, (&), set)
|
|
import Data.Text.Strict.Lens (utf8)
|
|
import Data.Generics.Labels ()
|
|
import qualified Data.Text as T
|
|
import System.FilePath (takeBaseName, (</>))
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
type Metadata = HashMap Text Text
|
|
type Key = Text
|
|
|
|
data S3Interface = S3Interface
|
|
{ putFile :: FilePath -> Metadata -> IO Key
|
|
-- ^ Upload a file from path
|
|
, getFile :: Key -> FilePath -> IO FilePath
|
|
-- ^ Download a file to a given root
|
|
, getMetadata :: Key -> IO Metadata
|
|
-- ^ Fetch the metadata
|
|
}
|
|
|
|
buildInterface :: ConfigS3 -> IO S3Interface
|
|
buildInterface s3Conf = do
|
|
discoveredEnv <- newEnv discover
|
|
let env = discoveredEnv
|
|
{ region = Region' $ view #region s3Conf
|
|
, overrides = setEndpoint True (view (#endpoint . re utf8) s3Conf) 443
|
|
}
|
|
bucket = S3.BucketName (view #bucket s3Conf)
|
|
pure S3Interface
|
|
{ putFile = uploadFile env bucket
|
|
, getFile = downloadFile env bucket
|
|
, getMetadata = fetchMeta env bucket
|
|
}
|
|
where
|
|
uploadFile :: Env -> S3.BucketName -> FilePath -> Metadata -> IO Key
|
|
uploadFile env bucket path metadata = do
|
|
obj <- Hashed <$> hashedFile path
|
|
runResourceT $ do
|
|
let putObj = S3.newPutObject bucket (S3.ObjectKey key) obj & set #metadata metadata
|
|
key = T.pack . takeBaseName $ path
|
|
_ <- send env putObj
|
|
pure key
|
|
fetchMeta :: Env -> S3.BucketName -> Key -> IO Metadata
|
|
fetchMeta env bucket key = do
|
|
runResourceT $ do
|
|
let getObjHead = S3.newHeadObject bucket (S3.ObjectKey key)
|
|
view #metadata <$> send env getObjHead
|
|
downloadFile :: Env -> S3.BucketName -> Key -> FilePath -> IO FilePath
|
|
downloadFile env bucket key root = do
|
|
let getObj = S3.newGetObject bucket (S3.ObjectKey key)
|
|
runResourceT $ do
|
|
x <- view #body <$> send env getObj
|
|
let path = root </> T.unpack key
|
|
_ <- sinkBody x (C.sinkFileBS path)
|
|
pure path
|