Harden mutation admission and storage observation
This commit is contained in:
parent
435d4fea4c
commit
1b1d8b06c7
4 changed files with 969 additions and 461 deletions
|
|
@ -27,7 +27,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.Encoding as TE
|
||||
import Data.UUID (toText)
|
||||
import Data.UUID.V4 (nextRandom)
|
||||
import Database.PostgreSQL.Simple (Connection, Only (..))
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import Network.HTTP.Types
|
||||
( hContentType
|
||||
, hLocation
|
||||
|
|
@ -53,6 +53,7 @@ import Nuthatch.S3
|
|||
, headObject
|
||||
, listObjects
|
||||
, putObject
|
||||
, renderS3Error
|
||||
)
|
||||
import Nuthatch.Session
|
||||
import Nuthatch.Types
|
||||
|
|
@ -252,7 +253,7 @@ handleDownloadRequest env session root path = do
|
|||
metadata <- liftIO (headObject (envS3 env) key)
|
||||
info <- case metadata of
|
||||
Left message -> throwOperationError status502Error
|
||||
(DownloadObjectStoreFailed message)
|
||||
(DownloadObjectStoreFailed (renderS3Error message))
|
||||
Right Nothing -> throwOperationError err404 DownloadNotFound
|
||||
Right (Just value) -> pure value
|
||||
throttle <- liftIO $
|
||||
|
|
@ -263,7 +264,7 @@ handleDownloadRequest env session root path = do
|
|||
Right True -> pure ()
|
||||
result <- liftIO (getObjectBytes (envS3 env) key)
|
||||
body <- either
|
||||
(throwOperationError status502Error . DownloadObjectStoreFailed)
|
||||
(throwOperationError status502Error . DownloadObjectStoreFailed . renderS3Error)
|
||||
pure
|
||||
result
|
||||
liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
|
||||
|
|
@ -445,7 +446,7 @@ runPut env user root rel op size sha body = do
|
|||
AdmitReplay MutationPending _ -> pure (Right MutationPending)
|
||||
AdmitReplay result _ -> pure (Right result)
|
||||
AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
|
||||
_ <- putObject (envS3 env) key size sha body
|
||||
_ <- putObject (envS3 env) key size (Just sha) body
|
||||
pure ()
|
||||
|
||||
runDelete
|
||||
|
|
@ -516,7 +517,7 @@ collectKeys s3 prefix = go Nothing []
|
|||
go continuation accumulated = do
|
||||
page <- listObjects s3 prefix Nothing continuation 1000
|
||||
case page of
|
||||
Left message -> pure (Left message)
|
||||
Left message -> pure (Left (renderS3Error message))
|
||||
Right result -> do
|
||||
let accumulated' = accumulated <> map fst (lpObjects result)
|
||||
if lpIsTruncated result
|
||||
|
|
@ -559,35 +560,17 @@ dispatchAndFinalize env user root rec dispatch = do
|
|||
observeObject :: S3 -> ObjectKey -> IO ObjectObservation
|
||||
observeObject s3 key = do
|
||||
result <- headObject s3 key
|
||||
pure $ case result of
|
||||
Right (Just info) -> ObjectPresent (oiSize info) (oiSha256 info)
|
||||
Right Nothing -> ObjectAbsent
|
||||
Left err -> ObjectUnavailable err
|
||||
|
||||
finalizeFromObservation
|
||||
:: Connection
|
||||
-> MutationRecord
|
||||
-> ObjectObservation
|
||||
-> IO (Maybe MutationResult)
|
||||
finalizeFromObservation conn rec observed =
|
||||
case observed of
|
||||
ObjectUnavailable _ -> pure Nothing
|
||||
_ | desiredMatches rec observed -> do
|
||||
let (finalSize, finalSha) =
|
||||
case mrKind rec of
|
||||
Put ->
|
||||
( mrDeclaredSize rec
|
||||
, mrContentSha256 rec
|
||||
)
|
||||
Delete -> (0, Nothing)
|
||||
ok <- finalizeSuccess conn rec finalSize finalSha
|
||||
pure $ if ok then Just MutationSucceeded else Nothing
|
||||
_ | priorMatches rec observed -> do
|
||||
ok <- finalizeFailure conn rec
|
||||
pure $ if ok then Just MutationFailed else Nothing
|
||||
_ -> do
|
||||
ok <- finalizeFailure conn rec
|
||||
pure $ if ok then Just MutationFailed else Nothing
|
||||
case result of
|
||||
Right (Just info@ObjectInfo { oiSha256 = Just _ }) ->
|
||||
pure (ObjectPresent (oiSize info) (oiSha256 info))
|
||||
Right (Just _) -> do
|
||||
body <- getObjectBytes s3 key
|
||||
pure $ case body of
|
||||
Right bytes ->
|
||||
ObjectPresent (toInteger (BL.length bytes)) (Just (contentSha256 bytes))
|
||||
Left err -> ObjectUnavailable (renderS3Error err)
|
||||
Right Nothing -> pure ObjectAbsent
|
||||
Left err -> pure (ObjectUnavailable (renderS3Error err))
|
||||
|
||||
listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
|
||||
listEntries env user root prefix = do
|
||||
|
|
@ -613,7 +596,7 @@ listEntries env user root prefix = do
|
|||
Nothing -> do
|
||||
page <- listObjects (envS3 env) s3Prefix (Just "/") Nothing 1000
|
||||
case page of
|
||||
Left err -> pure (Left err)
|
||||
Left err -> pure (Left (renderS3Error err))
|
||||
Right lp -> do
|
||||
let rootPrefix =
|
||||
case root of
|
||||
|
|
@ -680,7 +663,7 @@ collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
|
|||
| otherwise = do
|
||||
page <- listObjects s3 prefix Nothing mTok (min 1000 (maxKeys - n))
|
||||
case page of
|
||||
Left err -> pure (Left err)
|
||||
Left err -> pure (Left (renderS3Error err))
|
||||
Right lp -> do
|
||||
let acc' = acc <> lpObjects lp
|
||||
n' = length acc'
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ module Nuthatch.Db
|
|||
, withDb
|
||||
, migrate
|
||||
, ensurePersonalPool
|
||||
, configurePoolLimit
|
||||
, withTransaction
|
||||
, query
|
||||
, query_
|
||||
|
|
@ -11,7 +12,7 @@ module Nuthatch.Db
|
|||
, executeMany
|
||||
) where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
import Control.Exception (bracket, throwIO)
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import Data.Pool
|
||||
( Pool
|
||||
|
|
@ -23,11 +24,15 @@ import Data.Pool
|
|||
)
|
||||
import Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
|
||||
import qualified Database.PostgreSQL.Simple as PG
|
||||
import Database.PostgreSQL.Simple.Migration
|
||||
( MigrationCommand (..)
|
||||
, MigrationResult (..)
|
||||
, defaultOptions
|
||||
, runMigration
|
||||
)
|
||||
import qualified Database.PostgreSQL.Simple.Transaction as PGT
|
||||
import Database.PostgreSQL.Simple.Types (Query (..))
|
||||
import Nuthatch.Config (Config (..))
|
||||
import Nuthatch.Types
|
||||
import System.Directory (doesFileExist)
|
||||
|
||||
type Db = Pool Connection
|
||||
|
||||
|
|
@ -40,43 +45,39 @@ withDb cfg action = do
|
|||
bracket (newPool poolCfg) destroyAllResources action
|
||||
|
||||
migrate :: Db -> FilePath -> Config -> IO ()
|
||||
migrate db schemaPath cfg = withResource db $ \conn -> do
|
||||
exists <- doesFileExist schemaPath
|
||||
sql <- if exists then readFile schemaPath else pure builtinSchema
|
||||
mapM_ (runStatement conn) (splitStatements sql)
|
||||
_ <- PG.execute conn
|
||||
"INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes) \
|
||||
\VALUES (?, ?, 0, 0) ON CONFLICT (pool_id) DO UPDATE SET limit_bytes = EXCLUDED.limit_bytes"
|
||||
(unPoolId sharedPool, cfgSharedQuotaBytes cfg)
|
||||
pure ()
|
||||
|
||||
runStatement :: Connection -> String -> IO ()
|
||||
runStatement conn stmt =
|
||||
let trimmed = dropWhile (`elem` (" \t\r\n" :: String)) stmt
|
||||
in if null trimmed
|
||||
then pure ()
|
||||
else do
|
||||
_ <- PG.execute_ conn (Query (BS8.pack trimmed))
|
||||
pure ()
|
||||
|
||||
splitStatements :: String -> [String]
|
||||
splitStatements = filter (not . null . trim) . splitOn ';'
|
||||
where
|
||||
trim = dropWhile (`elem` (" \t\r\n" :: String))
|
||||
splitOn _ [] = []
|
||||
splitOn c xs =
|
||||
let (h, t) = break (== c) xs
|
||||
in h : case t of
|
||||
[] -> []
|
||||
(_:rest) -> splitOn c rest
|
||||
migrate db migrationDirectory cfg = withResource db $ \conn -> do
|
||||
result <- runMigration conn defaultOptions $
|
||||
MigrationInitialization
|
||||
<> MigrationDirectory migrationDirectory
|
||||
<> MigrationValidation (MigrationDirectory migrationDirectory)
|
||||
case result of
|
||||
MigrationSuccess ->
|
||||
PGT.withTransaction conn $
|
||||
configurePoolLimitConnection conn sharedPool (cfgSharedQuotaBytes cfg)
|
||||
MigrationError name -> throwIO (userError ("migration failed: " <> name))
|
||||
|
||||
ensurePersonalPool :: Db -> Config -> UserId -> IO ()
|
||||
ensurePersonalPool db cfg uid = withResource db $ \conn -> do
|
||||
ensurePersonalPool db cfg uid =
|
||||
configurePoolLimit db (personalPool uid) (cfgPersonalQuotaBytes cfg)
|
||||
|
||||
configurePoolLimit :: Db -> PoolId -> Integer -> IO ()
|
||||
configurePoolLimit db pool limitBytes =
|
||||
withResource db $ \conn ->
|
||||
PGT.withTransaction conn (configurePoolLimitConnection conn pool limitBytes)
|
||||
|
||||
configurePoolLimitConnection :: Connection -> PoolId -> Integer -> IO ()
|
||||
configurePoolLimitConnection conn pool limitBytes = do
|
||||
_ <- PG.execute conn
|
||||
"INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes) \
|
||||
\VALUES (?, ?, 0, 0) ON CONFLICT (pool_id) DO NOTHING"
|
||||
(unPoolId (personalPool uid), cfgPersonalQuotaBytes cfg)
|
||||
pure ()
|
||||
(unPoolId pool, limitBytes)
|
||||
changed <- PG.execute conn
|
||||
"UPDATE pools SET limit_bytes = ? \
|
||||
\WHERE pool_id = ? AND used_bytes + reserved_bytes <= ?"
|
||||
(limitBytes, unPoolId pool, limitBytes)
|
||||
if changed == 1
|
||||
then pure ()
|
||||
else throwIO (userError "pool limit is below live usage and reservations")
|
||||
|
||||
query :: (PG.ToRow q, PG.FromRow r) => Db -> PG.Query -> q -> IO [r]
|
||||
query db q params = withResource db $ \conn -> PG.query conn q params
|
||||
|
|
@ -96,45 +97,3 @@ executeMany db q rows = withResource db $ \conn -> fromIntegral <$> PG.executeMa
|
|||
withTransaction :: Db -> (Connection -> IO a) -> IO a
|
||||
withTransaction db action =
|
||||
withResource db $ \conn -> PGT.withTransaction conn (action conn)
|
||||
|
||||
builtinSchema :: String
|
||||
builtinSchema =
|
||||
unlines
|
||||
[ "CREATE TABLE IF NOT EXISTS pools ("
|
||||
, " pool_id TEXT PRIMARY KEY,"
|
||||
, " limit_bytes BIGINT NOT NULL CHECK (limit_bytes > 0),"
|
||||
, " used_bytes BIGINT NOT NULL DEFAULT 0 CHECK (used_bytes >= 0),"
|
||||
, " reserved_bytes BIGINT NOT NULL DEFAULT 0 CHECK (reserved_bytes >= 0)"
|
||||
, ");"
|
||||
, "CREATE TABLE IF NOT EXISTS mutations ("
|
||||
, " user_id TEXT NOT NULL,"
|
||||
, " kind TEXT NOT NULL,"
|
||||
, " operation_id TEXT NOT NULL,"
|
||||
, " pool_id TEXT NOT NULL REFERENCES pools (pool_id),"
|
||||
, " object_key TEXT NOT NULL,"
|
||||
, " relative_path TEXT NOT NULL,"
|
||||
, " declared_size BIGINT NOT NULL,"
|
||||
, " content_sha256 TEXT,"
|
||||
, " prior_size BIGINT NOT NULL,"
|
||||
, " prior_sha256 TEXT,"
|
||||
, " growth_bytes BIGINT NOT NULL,"
|
||||
, " state TEXT NOT NULL,"
|
||||
, " external_state TEXT NOT NULL DEFAULT 'idle',"
|
||||
, " created_at TIMESTAMPTZ NOT NULL DEFAULT now(),"
|
||||
, " updated_at TIMESTAMPTZ NOT NULL DEFAULT now(),"
|
||||
, " PRIMARY KEY (user_id, kind, operation_id)"
|
||||
, ");"
|
||||
, "CREATE TABLE IF NOT EXISTS key_locks ("
|
||||
, " object_key TEXT PRIMARY KEY,"
|
||||
, " user_id TEXT NOT NULL,"
|
||||
, " kind TEXT NOT NULL,"
|
||||
, " operation_id TEXT NOT NULL"
|
||||
, ");"
|
||||
, "CREATE TABLE IF NOT EXISTS objects_meta ("
|
||||
, " object_key TEXT PRIMARY KEY,"
|
||||
, " pool_id TEXT NOT NULL REFERENCES pools (pool_id),"
|
||||
, " size_bytes BIGINT NOT NULL,"
|
||||
, " content_sha256 TEXT NOT NULL,"
|
||||
, " updated_at TIMESTAMPTZ NOT NULL DEFAULT now()"
|
||||
, ");"
|
||||
]
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ module Nuthatch.Protocol
|
|||
, recoveryEligible
|
||||
, desiredMatches
|
||||
, priorMatches
|
||||
, finalizeFromObservation
|
||||
) where
|
||||
|
||||
import Data.Maybe (listToMaybe, mapMaybe)
|
||||
|
|
@ -138,6 +139,11 @@ admitMutation
|
|||
-> Integer
|
||||
-> IO AdmitOutcome
|
||||
admitMutation conn uid kind op pool key rel size msha maxObject = do
|
||||
let identity =
|
||||
unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
|
||||
_ <- query conn
|
||||
"SELECT pg_advisory_xact_lock(hashtextextended(?, 0))"
|
||||
(Only identity) :: IO [Only ()]
|
||||
existing <- lookupMutation conn uid kind op
|
||||
case existing of
|
||||
Just rec
|
||||
|
|
@ -169,11 +175,13 @@ admitMutation conn uid kind op pool key rel size msha maxObject = do
|
|||
, mrExternal = ExtIdle
|
||||
}
|
||||
|
||||
_ <- query conn
|
||||
poolRows <- query conn
|
||||
"SELECT 1 FROM pools WHERE pool_id = ? FOR UPDATE"
|
||||
(Only (unPoolId pool)) :: IO [Only Int]
|
||||
|
||||
if kind == Put && (size <= 0 || size > maxObject)
|
||||
if null poolRows
|
||||
then pure AdmitConflict
|
||||
else if kind == Put && (size <= 0 || size > maxObject)
|
||||
then do
|
||||
rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
|
||||
pure (AdmitRejected "invalid object size" rec)
|
||||
|
|
@ -458,3 +466,26 @@ priorMatches rec obs =
|
|||
(Just _, Nothing) -> False
|
||||
(Nothing, Just _) -> mrPriorSize rec == sz
|
||||
)
|
||||
|
||||
finalizeFromObservation
|
||||
:: Connection
|
||||
-> MutationRecord
|
||||
-> ObjectObservation
|
||||
-> IO (Maybe MutationResult)
|
||||
finalizeFromObservation conn rec observed =
|
||||
case observed of
|
||||
ObjectUnavailable _ -> pure Nothing
|
||||
_ | desiredMatches rec observed -> do
|
||||
let (finalSize, finalSha) =
|
||||
case mrKind rec of
|
||||
Put ->
|
||||
( mrDeclaredSize rec
|
||||
, mrContentSha256 rec
|
||||
)
|
||||
Delete -> (0, Nothing)
|
||||
ok <- finalizeSuccess conn rec finalSize finalSha
|
||||
pure $ if ok then Just MutationSucceeded else Nothing
|
||||
_ | priorMatches rec observed -> do
|
||||
ok <- finalizeFailure conn rec
|
||||
pure $ if ok then Just MutationFailed else Nothing
|
||||
_ -> pure Nothing
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
module Nuthatch.S3
|
||||
( S3
|
||||
, S3Error (..)
|
||||
, ObjectInfo (..)
|
||||
, ListPage (..)
|
||||
, newS3
|
||||
|
|
@ -8,57 +9,59 @@ module Nuthatch.S3
|
|||
, headObject
|
||||
, deleteObject
|
||||
, listObjects
|
||||
, renderS3Error
|
||||
) where
|
||||
|
||||
import Crypto.Hash (Digest, SHA256, hash, hashlazy)
|
||||
import Crypto.MAC.HMAC (HMAC, hmac)
|
||||
import Data.ByteArray (convert)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Aws
|
||||
import qualified Aws.Aws as AwsRun
|
||||
import qualified Aws.Core as AwsCore
|
||||
import qualified Aws.S3 as S3
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Exception (SomeException, fromException, try)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Crypto.Hash
|
||||
( Context
|
||||
, SHA256
|
||||
, hashFinalize
|
||||
, hashInit
|
||||
, hashUpdate
|
||||
)
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (mk, original)
|
||||
import Data.Char (toLower)
|
||||
import Data.List (sort)
|
||||
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Network.HTTP.Client
|
||||
( Manager
|
||||
, Request (..)
|
||||
, RequestBody (..)
|
||||
, Response (..)
|
||||
, httpLbs
|
||||
, newManager
|
||||
, parseRequest
|
||||
, responseTimeoutNone
|
||||
, setQueryString
|
||||
)
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import Network.HTTP.Types (Header, RequestHeaders, statusCode)
|
||||
import Network.HTTP.Types.URI (parseQuery)
|
||||
import Network.HTTP.Types.Status (statusCode)
|
||||
import Network.URI (URI (..), URIAuth (..), parseURI)
|
||||
import Nuthatch.Config (Config (..))
|
||||
import Nuthatch.Types
|
||||
import qualified Text.XML as XML
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
data S3 = S3
|
||||
{ s3Manager :: Manager
|
||||
, s3Endpoint :: Text
|
||||
, s3Region :: Text
|
||||
, s3Bucket :: Text
|
||||
, s3AccessKey :: Text
|
||||
, s3SecretKey :: Text
|
||||
, s3PathStyle :: Bool
|
||||
{ s3Configuration :: Aws.Configuration
|
||||
, s3Service :: S3.S3Configuration Aws.NormalQuery
|
||||
, s3Manager :: HTTP.Manager
|
||||
, s3Bucket :: Text
|
||||
}
|
||||
|
||||
data S3Error
|
||||
= S3NotFound
|
||||
| S3ServiceError Int
|
||||
| S3TransportError
|
||||
| S3ResponseError
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data ObjectInfo = ObjectInfo
|
||||
{ oiSize :: Integer
|
||||
, oiSha256 :: Maybe ContentSha256
|
||||
}
|
||||
deriving stock (Show)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data ListPage = ListPage
|
||||
{ lpPrefixes :: [Text]
|
||||
|
|
@ -66,86 +69,112 @@ data ListPage = ListPage
|
|||
, lpContinuationToken :: Maybe Text
|
||||
, lpIsTruncated :: Bool
|
||||
}
|
||||
deriving stock (Show)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
newS3 :: Config -> IO S3
|
||||
newS3 cfg = do
|
||||
mgr <- newManager tlsManagerSettings
|
||||
(protocol, endpointHost, endpointPort) <- parseEndpoint (cfgS3Endpoint cfg)
|
||||
credentials <- Aws.makeCredentials
|
||||
(TE.encodeUtf8 (cfgS3AccessKey cfg))
|
||||
(TE.encodeUtf8 (cfgS3SecretKey cfg))
|
||||
let defaultPort = case protocol of
|
||||
AwsCore.HTTP -> 80
|
||||
AwsCore.HTTPS -> 443
|
||||
signedHost =
|
||||
if endpointPort == defaultPort
|
||||
then endpointHost
|
||||
else endpointHost <> ":" <> BS8.pack (show endpointPort)
|
||||
managerSettings =
|
||||
tlsManagerSettings
|
||||
{ HTTP.managerResponseTimeout =
|
||||
HTTP.responseTimeoutMicro (30 * 1000000)
|
||||
-- The SDK signs the authority verbatim; http-client resolves only its host.
|
||||
, HTTP.managerModifyRequest = \request ->
|
||||
let requestHost = HTTP.host request
|
||||
portSuffix = ":" <> BS8.pack (show endpointPort)
|
||||
(networkHost, authority) =
|
||||
if endpointPort == defaultPort
|
||||
then (requestHost, requestHost)
|
||||
else case BS8.stripSuffix portSuffix requestHost of
|
||||
Just hostWithoutPort -> (hostWithoutPort, requestHost)
|
||||
Nothing -> (requestHost, requestHost <> portSuffix)
|
||||
in pure request
|
||||
{ HTTP.host = networkHost
|
||||
, HTTP.requestHeaders =
|
||||
("Host", authority)
|
||||
: filter ((/= "Host") . fst) (HTTP.requestHeaders request)
|
||||
}
|
||||
}
|
||||
manager <- HTTP.newManager managerSettings
|
||||
let configuration = Aws.Configuration
|
||||
{ Aws.timeInfo = Aws.Timestamp
|
||||
, Aws.credentials = credentials
|
||||
, Aws.logger = \_ _ -> pure ()
|
||||
, Aws.proxy = Nothing
|
||||
}
|
||||
requestStyle =
|
||||
if cfgS3PathStyle cfg then S3.PathStyle else S3.BucketStyle
|
||||
service =
|
||||
(S3.s3v4 protocol signedHost False S3.SignWithEffort)
|
||||
{ S3.s3Region = Just (TE.encodeUtf8 (cfgS3Region cfg))
|
||||
, S3.s3RequestStyle = requestStyle
|
||||
, S3.s3Port = endpointPort
|
||||
}
|
||||
pure S3
|
||||
{ s3Manager = mgr
|
||||
, s3Endpoint = cfgS3Endpoint cfg
|
||||
, s3Region = cfgS3Region cfg
|
||||
{ s3Configuration = configuration
|
||||
, s3Service = service
|
||||
, s3Manager = manager
|
||||
, s3Bucket = cfgS3Bucket cfg
|
||||
, s3AccessKey = cfgS3AccessKey cfg
|
||||
, s3SecretKey = cfgS3SecretKey cfg
|
||||
, s3PathStyle = cfgS3PathStyle cfg
|
||||
}
|
||||
|
||||
putObject :: S3 -> ObjectKey -> Integer -> ContentSha256 -> BL.ByteString -> IO (Either Text ())
|
||||
putObject s3 key size sha body
|
||||
| toInteger (BL.length body) /= size = pure (Left "body size mismatch")
|
||||
| ContentSha256 (TE.decodeUtf8 (hexSha256Lazy body)) /= sha =
|
||||
pure (Left "content sha256 mismatch")
|
||||
putObject
|
||||
:: S3
|
||||
-> ObjectKey
|
||||
-> Integer
|
||||
-> Maybe ContentSha256
|
||||
-> BL.ByteString
|
||||
-> IO (Either S3Error ())
|
||||
putObject store (ObjectKey key) size sha body
|
||||
| toInteger (BL.length body) /= size = pure (Left S3ResponseError)
|
||||
| otherwise = do
|
||||
now <- getCurrentTime
|
||||
req0 <- mkObjectRequest s3 "PUT" key [] now
|
||||
let payloadHash = hexSha256Lazy body
|
||||
req = signRequest s3 now payloadHash req0
|
||||
{ requestBody = RequestBodyLBS body
|
||||
, requestHeaders =
|
||||
[ (mk "content-length", BS8.pack (show size))
|
||||
, (mk "content-type", "application/octet-stream")
|
||||
, (mk "x-amz-meta-nuthatch-sha256", TE.encodeUtf8 (unContentSha256 sha))
|
||||
]
|
||||
<> requestHeaders req0
|
||||
}
|
||||
resp <- httpLbs req (s3Manager s3)
|
||||
let code = statusCode (responseStatus resp)
|
||||
pure $ if code >= 200 && code < 300
|
||||
then Right ()
|
||||
else Left ("s3 put failed: HTTP " <> T.pack (show code)
|
||||
<> " " <> TE.decodeUtf8 (BL.toStrict (responseBody resp)))
|
||||
let request =
|
||||
(S3.putObject (s3Bucket store) key (HTTP.RequestBodyLBS body))
|
||||
{ S3.poContentType = Just "application/octet-stream"
|
||||
, S3.poMetadata = maybe []
|
||||
(\identity ->
|
||||
[("nuthatch-sha256", unContentSha256 identity)])
|
||||
sha
|
||||
}
|
||||
result <- try (runMemory store request)
|
||||
:: IO (Either SomeException S3.PutObjectResponse)
|
||||
pure (either (Left . classifyException) (const (Right ())) result)
|
||||
|
||||
getObjectBytes :: S3 -> ObjectKey -> IO (Either Text BL.ByteString)
|
||||
getObjectBytes s3 key = do
|
||||
now <- getCurrentTime
|
||||
req0 <- mkObjectRequest s3 "GET" key [] now
|
||||
let req = signRequest s3 now (hexSha256Lazy "") req0
|
||||
resp <- httpLbs req (s3Manager s3)
|
||||
let code = statusCode (responseStatus resp)
|
||||
pure $ if code == 200
|
||||
then Right (responseBody resp)
|
||||
else Left ("s3 get failed: HTTP " <> T.pack (show code))
|
||||
getObjectBytes :: S3 -> ObjectKey -> IO (Either S3Error BL.ByteString)
|
||||
getObjectBytes store (ObjectKey key) = do
|
||||
result <- getObjectMemory store key
|
||||
pure $ result >>= \(_, body) -> Right body
|
||||
|
||||
headObject :: S3 -> ObjectKey -> IO (Either Text (Maybe ObjectInfo))
|
||||
headObject s3 key = do
|
||||
now <- getCurrentTime
|
||||
req0 <- mkObjectRequest s3 "HEAD" key [] now
|
||||
let req = signRequest s3 now (hexSha256Lazy "") req0
|
||||
resp <- httpLbs req (s3Manager s3)
|
||||
let code = statusCode (responseStatus resp)
|
||||
pure $ case code of
|
||||
200 ->
|
||||
let headers = responseHeaders resp
|
||||
size = lookupHeader "content-length" headers >>= readInteger
|
||||
sha = ContentSha256 . TE.decodeUtf8
|
||||
<$> lookupHeader "x-amz-meta-nuthatch-sha256" headers
|
||||
in case size of
|
||||
Just sz -> Right (Just ObjectInfo { oiSize = sz, oiSha256 = sha })
|
||||
Nothing -> Left "s3 head missing content-length"
|
||||
404 -> Right Nothing
|
||||
_ -> Left ("s3 head failed: HTTP " <> T.pack (show code))
|
||||
headObject :: S3 -> ObjectKey -> IO (Either S3Error (Maybe ObjectInfo))
|
||||
headObject store (ObjectKey key) = do
|
||||
result <- try (runMemory store (S3.headObject (s3Bucket store) key))
|
||||
:: IO (Either SomeException S3.HeadObjectMemoryResponse)
|
||||
case result of
|
||||
Left err -> pure (Left (classifyException err))
|
||||
Right (S3.HeadObjectMemoryResponse Nothing) -> pure (Right Nothing)
|
||||
Right (S3.HeadObjectMemoryResponse (Just _)) -> do
|
||||
object <- observeObjectStream store key
|
||||
pure (Just <$> object)
|
||||
|
||||
deleteObject :: S3 -> ObjectKey -> IO (Either Text ())
|
||||
deleteObject s3 key = do
|
||||
now <- getCurrentTime
|
||||
req0 <- mkObjectRequest s3 "DELETE" key [] now
|
||||
let req = signRequest s3 now (hexSha256Lazy "") req0
|
||||
resp <- httpLbs req (s3Manager s3)
|
||||
let code = statusCode (responseStatus resp)
|
||||
pure $ if code == 204 || code == 200 || code == 404
|
||||
then Right ()
|
||||
else Left ("s3 delete failed: HTTP " <> T.pack (show code))
|
||||
deleteObject :: S3 -> ObjectKey -> IO (Either S3Error ())
|
||||
deleteObject store (ObjectKey key) = do
|
||||
result <- try (runMemory store (S3.DeleteObject key (s3Bucket store)))
|
||||
:: IO (Either SomeException S3.DeleteObjectResponse)
|
||||
pure $ case result of
|
||||
Left err ->
|
||||
case classifyException err of
|
||||
S3NotFound -> Right ()
|
||||
other -> Left other
|
||||
Right _ -> Right ()
|
||||
|
||||
listObjects
|
||||
:: S3
|
||||
|
|
@ -153,249 +182,160 @@ listObjects
|
|||
-> Maybe Text
|
||||
-> Maybe Text
|
||||
-> Int
|
||||
-> IO (Either Text ListPage)
|
||||
listObjects s3 prefix delimiter continuation maxKeys = do
|
||||
now <- getCurrentTime
|
||||
let qs =
|
||||
[ ("list-type", Just "2")
|
||||
, ("prefix", Just (TE.encodeUtf8 prefix))
|
||||
, ("max-keys", Just (BS8.pack (show maxKeys)))
|
||||
]
|
||||
<> maybe [] (\d -> [("delimiter", Just (TE.encodeUtf8 d))]) delimiter
|
||||
<> maybe [] (\t -> [("continuation-token", Just (TE.encodeUtf8 t))]) continuation
|
||||
req0 <- mkBucketRequest s3 "GET" qs now
|
||||
let req = signRequest s3 now (hexSha256Lazy "") req0
|
||||
resp <- httpLbs req (s3Manager s3)
|
||||
let code = statusCode (responseStatus resp)
|
||||
body = responseBody resp
|
||||
if code /= 200
|
||||
then pure (Left ("s3 list failed: HTTP " <> T.pack (show code)
|
||||
<> " " <> TE.decodeUtf8 (BL.toStrict body)))
|
||||
else pure (parseListXml body)
|
||||
|
||||
parseListXml :: BL.ByteString -> Either Text ListPage
|
||||
parseListXml body =
|
||||
case XML.parseLBS XML.def body of
|
||||
Left err -> Left (T.pack (show err))
|
||||
Right (XML.Document _ root _) ->
|
||||
let elems = descendantElements root
|
||||
textUnder localName =
|
||||
[ t
|
||||
| e <- elems
|
||||
, elementLocal e == localName
|
||||
, t <- elementTexts e
|
||||
]
|
||||
objects =
|
||||
mapMaybe objectFrom
|
||||
[ e | e <- elems, elementLocal e == "Contents" ]
|
||||
prefixes =
|
||||
concatMap elementTexts
|
||||
[ e | e <- elems, elementLocal e == "Prefix"
|
||||
-- List Prefix also names the request prefix; common prefixes end with '/'.
|
||||
, any (T.isSuffixOf "/") (elementTexts e)
|
||||
]
|
||||
truncated =
|
||||
case textUnder "IsTruncated" of
|
||||
(t : _) -> T.toLower t == "true"
|
||||
_ -> False
|
||||
token =
|
||||
case textUnder "NextContinuationToken" of
|
||||
(t : _) | not (T.null t) -> Just t
|
||||
_ -> Nothing
|
||||
in Right ListPage
|
||||
{ lpPrefixes = prefixes
|
||||
, lpObjects = objects
|
||||
, lpContinuationToken = token
|
||||
, lpIsTruncated = truncated
|
||||
}
|
||||
-> IO (Either S3Error ListPage)
|
||||
listObjects store prefix delimiter continuation maxKeys = do
|
||||
let request =
|
||||
(S3.getBucket (s3Bucket store))
|
||||
{ S3.gbPrefix = Just prefix
|
||||
, S3.gbDelimiter = delimiter
|
||||
, S3.gbMarker = continuation
|
||||
, S3.gbMaxKeys = Just maxKeys
|
||||
}
|
||||
result <- try (runMemory store request)
|
||||
:: IO (Either SomeException S3.GetBucketResponse)
|
||||
pure $ case result of
|
||||
Left err -> Left (classifyException err)
|
||||
Right response ->
|
||||
Right ListPage
|
||||
{ lpPrefixes = S3.gbrCommonPrefixes response
|
||||
, lpObjects =
|
||||
map (\object -> (S3.objectKey object, S3.objectSize object))
|
||||
(S3.gbrContents response)
|
||||
, lpContinuationToken =
|
||||
S3.gbrNextMarker response
|
||||
<|> fallbackMarker response
|
||||
, lpIsTruncated = S3.gbrIsTruncated response
|
||||
}
|
||||
where
|
||||
elementLocal e = XML.nameLocalName (XML.elementName e)
|
||||
elementTexts e =
|
||||
[ t
|
||||
| XML.NodeContent t <- XML.elementNodes e
|
||||
]
|
||||
descendantElements e =
|
||||
e :
|
||||
concat
|
||||
[ descendantElements child
|
||||
| XML.NodeElement child <- XML.elementNodes e
|
||||
]
|
||||
objectFrom e = do
|
||||
let children = [ c | XML.NodeElement c <- XML.elementNodes e ]
|
||||
childText name =
|
||||
listToMaybe
|
||||
[ t
|
||||
| c <- children
|
||||
, elementLocal c == name
|
||||
, t <- elementTexts c
|
||||
]
|
||||
key <- childText "Key"
|
||||
sizeText <- childText "Size"
|
||||
size <- case reads (T.unpack sizeText) of
|
||||
[(n, "")] -> Just n
|
||||
_ -> Nothing
|
||||
pure (key, size)
|
||||
fallbackMarker response =
|
||||
if S3.gbrIsTruncated response
|
||||
then S3.objectKey <$> lastMaybe (S3.gbrContents response)
|
||||
else Nothing
|
||||
|
||||
mkObjectRequest :: S3 -> BS.ByteString -> ObjectKey -> [Header] -> UTCTime -> IO Request
|
||||
mkObjectRequest s3 method (ObjectKey key) headers _now = do
|
||||
let path = objectUrlPath s3 key
|
||||
base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
|
||||
pure base
|
||||
{ method = method
|
||||
, requestHeaders = headers
|
||||
, responseTimeout = responseTimeoutNone
|
||||
}
|
||||
renderS3Error :: S3Error -> Text
|
||||
renderS3Error S3NotFound = "object not found"
|
||||
renderS3Error (S3ServiceError code) =
|
||||
"object store returned HTTP " <> T.pack (show code)
|
||||
renderS3Error S3TransportError = "object store transport failed"
|
||||
renderS3Error S3ResponseError = "object store response was invalid"
|
||||
|
||||
mkBucketRequest :: S3 -> BS.ByteString -> [(BS.ByteString, Maybe BS.ByteString)] -> UTCTime -> IO Request
|
||||
mkBucketRequest s3 method qs _now = do
|
||||
let path = bucketUrlPath s3
|
||||
base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
|
||||
pure $ setQueryString qs base
|
||||
{ method = method
|
||||
, responseTimeout = responseTimeoutNone
|
||||
}
|
||||
runMemory
|
||||
:: ( Aws.Transaction request response
|
||||
, Aws.AsMemoryResponse response
|
||||
, Aws.MemoryResponse response ~ memoryResponse
|
||||
, Aws.ServiceConfiguration request Aws.NormalQuery
|
||||
~ S3.S3Configuration Aws.NormalQuery
|
||||
)
|
||||
=> S3
|
||||
-> request
|
||||
-> IO memoryResponse
|
||||
runMemory store =
|
||||
AwsRun.memoryAws
|
||||
(s3Configuration store)
|
||||
(s3Service store)
|
||||
(s3Manager store)
|
||||
|
||||
objectUrlPath :: S3 -> Text -> String
|
||||
objectUrlPath s3 key =
|
||||
let bucket = T.unpack (s3Bucket s3)
|
||||
encodedKey = escapePath (T.unpack key)
|
||||
in if s3PathStyle s3
|
||||
then "/" <> bucket <> "/" <> encodedKey
|
||||
else "/" <> encodedKey
|
||||
getObjectMemory
|
||||
:: S3
|
||||
-> Text
|
||||
-> IO (Either S3Error (S3.ObjectMetadata, BL.ByteString))
|
||||
getObjectMemory store key = do
|
||||
result <- try (runMemory store (S3.getObject (s3Bucket store) key))
|
||||
:: IO (Either SomeException S3.GetObjectMemoryResponse)
|
||||
pure $ case result of
|
||||
Left err -> Left (classifyException err)
|
||||
Right (S3.GetObjectMemoryResponse metadata response) ->
|
||||
Right (metadata, HTTP.responseBody response)
|
||||
|
||||
bucketUrlPath :: S3 -> String
|
||||
bucketUrlPath s3 =
|
||||
let bucket = T.unpack (s3Bucket s3)
|
||||
in if s3PathStyle s3 then "/" <> bucket else "/"
|
||||
|
||||
escapePath :: String -> String
|
||||
escapePath = concatMap escapeChar
|
||||
observeObjectStream :: S3 -> Text -> IO (Either S3Error ObjectInfo)
|
||||
observeObjectStream store key = do
|
||||
result <- try (runResourceT getInfo)
|
||||
:: IO (Either SomeException ObjectInfo)
|
||||
pure (either (Left . classifyException) Right result)
|
||||
where
|
||||
escapeChar c
|
||||
| c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~/" :: String) = [c]
|
||||
| otherwise =
|
||||
let (q, r) = fromEnum c `divMod` 16
|
||||
hex = "0123456789ABCDEF"
|
||||
in ['%', hex !! q, hex !! r]
|
||||
getInfo = do
|
||||
response <- AwsRun.pureAws
|
||||
(s3Configuration store)
|
||||
(s3Service store)
|
||||
(s3Manager store)
|
||||
(S3.getObject (s3Bucket store) key)
|
||||
let metadata = S3.gorMetadata response
|
||||
httpResponse = S3.gorResponse response
|
||||
knownSize =
|
||||
lookup "Content-Length" (HTTP.responseHeaders httpResponse)
|
||||
>>= readMaybe . BS8.unpack
|
||||
knownIdentity =
|
||||
lookup "nuthatch-sha256" (S3.omUserMetadata metadata)
|
||||
>>= either (const Nothing) Just . validateContentSha256
|
||||
case (knownSize, knownIdentity) of
|
||||
(Just size, Just identity) ->
|
||||
pure ObjectInfo
|
||||
{ oiSize = size
|
||||
, oiSha256 = Just identity
|
||||
}
|
||||
_ -> do
|
||||
(size, context) <- C.runConduit $
|
||||
HTTP.responseBody httpResponse
|
||||
C..| CL.fold updateDigest (0, hashInit)
|
||||
pure ObjectInfo
|
||||
{ oiSize = size
|
||||
, oiSha256 = Just (contextIdentity context)
|
||||
}
|
||||
updateDigest (size, context) chunk =
|
||||
(size + toInteger (BS8.length chunk), hashUpdate context chunk)
|
||||
|
||||
signRequest :: S3 -> UTCTime -> BS.ByteString -> Request -> Request
|
||||
signRequest s3 now payloadHash req =
|
||||
let amzDate = BS8.pack (formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" now)
|
||||
dateStamp = BS8.take 8 amzDate
|
||||
region = TE.encodeUtf8 (s3Region s3)
|
||||
service = "s3" :: BS.ByteString
|
||||
credentialScope =
|
||||
dateStamp <> "/" <> region <> "/" <> service <> "/aws4_request"
|
||||
headers0 :: RequestHeaders
|
||||
headers0 =
|
||||
filter (\(n, _) -> n /= mk "authorization") (requestHeaders req)
|
||||
<> [ (mk "x-amz-content-sha256", payloadHash)
|
||||
, (mk "x-amz-date", amzDate)
|
||||
, (mk "host", hostHeader req)
|
||||
]
|
||||
sortedHeaders = sortOnHeader headers0
|
||||
signedHeaderNames = map (BS8.map toLower . original . fst) sortedHeaders
|
||||
signedHeaders = BS8.intercalate ";" signedHeaderNames
|
||||
canonicalHeaders =
|
||||
BS8.concat
|
||||
[ BS8.map toLower (original name) <> ":" <> BS8.dropWhile (== ' ') value <> "\n"
|
||||
| (name, value) <- sortedHeaders
|
||||
]
|
||||
canonicalQuery = canonicalQueryString req
|
||||
canonicalUri = BS8.pack (pathURL req)
|
||||
canonicalRequest =
|
||||
method req <> "\n"
|
||||
<> canonicalUri <> "\n"
|
||||
<> canonicalQuery <> "\n"
|
||||
<> canonicalHeaders <> "\n"
|
||||
<> signedHeaders <> "\n"
|
||||
<> payloadHash
|
||||
stringToSign =
|
||||
"AWS4-HMAC-SHA256\n"
|
||||
<> amzDate <> "\n"
|
||||
<> credentialScope <> "\n"
|
||||
<> hexSha256 canonicalRequest
|
||||
signingKey =
|
||||
hmacSHA256
|
||||
(hmacSHA256
|
||||
(hmacSHA256
|
||||
(hmacSHA256 (TE.encodeUtf8 ("AWS4" <> s3SecretKey s3)) dateStamp)
|
||||
region)
|
||||
service)
|
||||
"aws4_request"
|
||||
signature = hexEncode (hmacSHA256 signingKey stringToSign)
|
||||
auth =
|
||||
"AWS4-HMAC-SHA256 Credential="
|
||||
<> TE.encodeUtf8 (s3AccessKey s3)
|
||||
<> "/"
|
||||
<> credentialScope
|
||||
<> ", SignedHeaders="
|
||||
<> signedHeaders
|
||||
<> ", Signature="
|
||||
<> signature
|
||||
in req { requestHeaders = (mk "authorization", auth) : headers0 }
|
||||
contextIdentity :: Context SHA256 -> ContentSha256
|
||||
contextIdentity =
|
||||
ContentSha256
|
||||
. TE.decodeUtf8
|
||||
. B16.encode
|
||||
. BA.convert
|
||||
. hashFinalize
|
||||
|
||||
sortOnHeader :: RequestHeaders -> RequestHeaders
|
||||
sortOnHeader = sortOn (\(n, _) -> BS8.map toLower (original n))
|
||||
where
|
||||
sortOn f = map snd . sort . map (\x -> (f x, x))
|
||||
|
||||
hostHeader :: Request -> BS.ByteString
|
||||
hostHeader req =
|
||||
case lookup (mk "Host") (requestHeaders req) of
|
||||
Just h -> h
|
||||
classifyException :: SomeException -> S3Error
|
||||
classifyException exception =
|
||||
case fromException exception of
|
||||
Just serviceError
|
||||
| statusCode (S3.s3StatusCode serviceError) == 404 -> S3NotFound
|
||||
| otherwise ->
|
||||
S3ServiceError (statusCode (S3.s3StatusCode serviceError))
|
||||
Nothing ->
|
||||
let h = host req
|
||||
p = port req
|
||||
in if p == 80 || p == 443
|
||||
then h
|
||||
else h <> ":" <> BS8.pack (show p)
|
||||
case fromException exception :: Maybe HTTP.HttpException of
|
||||
Just (HTTP.HttpExceptionRequest _ content) ->
|
||||
case content of
|
||||
HTTP.StatusCodeException response _
|
||||
| statusCode (HTTP.responseStatus response) == 404 -> S3NotFound
|
||||
| otherwise ->
|
||||
S3ServiceError (statusCode (HTTP.responseStatus response))
|
||||
_ -> S3TransportError
|
||||
Just (HTTP.InvalidUrlException _ _) -> S3ResponseError
|
||||
Nothing -> S3ResponseError
|
||||
|
||||
pathURL :: Request -> String
|
||||
pathURL req =
|
||||
case BS8.unpack (path req) of
|
||||
"" -> "/"
|
||||
p -> p
|
||||
lastMaybe :: [a] -> Maybe a
|
||||
lastMaybe [] = Nothing
|
||||
lastMaybe values = Just (last values)
|
||||
|
||||
canonicalQueryString :: Request -> BS.ByteString
|
||||
canonicalQueryString req =
|
||||
let pairs = parseQuery (queryString req)
|
||||
enc = escapeQuery
|
||||
encoded =
|
||||
sort
|
||||
[ enc k <> "=" <> enc (fromMaybe "" v)
|
||||
| (k, v) <- pairs
|
||||
]
|
||||
in BS8.intercalate "&" encoded
|
||||
|
||||
escapeQuery :: BS.ByteString -> BS.ByteString
|
||||
escapeQuery = BS8.concatMap escape1
|
||||
where
|
||||
escape1 c
|
||||
| c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~" :: String)
|
||||
= BS8.singleton c
|
||||
| otherwise =
|
||||
let (q, r) = fromEnum c `divMod` 16
|
||||
hex = "0123456789ABCDEF"
|
||||
in BS8.pack ['%', hex !! q, hex !! r]
|
||||
|
||||
hmacSHA256 :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
hmacSHA256 key msg = convert (hmac key msg :: HMAC SHA256)
|
||||
|
||||
hexSha256 :: BS.ByteString -> BS.ByteString
|
||||
hexSha256 = hexEncode . convert . (hash :: BS.ByteString -> Digest SHA256)
|
||||
|
||||
hexSha256Lazy :: BL.ByteString -> BS.ByteString
|
||||
hexSha256Lazy = hexEncode . convert . (hashlazy :: BL.ByteString -> Digest SHA256)
|
||||
|
||||
hexEncode :: BS.ByteString -> BS.ByteString
|
||||
hexEncode = B16.encode
|
||||
|
||||
lookupHeader :: BS.ByteString -> RequestHeaders -> Maybe BS.ByteString
|
||||
lookupHeader name headers = lookup (mk name) headers
|
||||
|
||||
readInteger :: BS.ByteString -> Maybe Integer
|
||||
readInteger bs =
|
||||
case reads (BS8.unpack bs) of
|
||||
[(n, "")] -> Just n
|
||||
_ -> Nothing
|
||||
parseEndpoint :: Text -> IO (AwsCore.Protocol, BS8.ByteString, Int)
|
||||
parseEndpoint raw =
|
||||
case parseURI (T.unpack raw) of
|
||||
Just URI
|
||||
{ uriScheme
|
||||
, uriAuthority = Just URIAuth
|
||||
{ uriUserInfo = ""
|
||||
, uriRegName
|
||||
, uriPort
|
||||
}
|
||||
, uriPath = ""
|
||||
, uriQuery = ""
|
||||
, uriFragment = ""
|
||||
}
|
||||
| uriScheme == "http:" || uriScheme == "https:" -> do
|
||||
port <- case uriPort of
|
||||
"" -> pure (if uriScheme == "https:" then 443 else 80)
|
||||
':' : value ->
|
||||
maybe (fail "invalid S3 endpoint port") pure (readMaybe value)
|
||||
_ -> fail "invalid S3 endpoint port"
|
||||
let protocol =
|
||||
if uriScheme == "https:" then AwsCore.HTTPS else AwsCore.HTTP
|
||||
pure (protocol, BS8.pack uriRegName, port)
|
||||
_ -> fail "NUTHATCH_S3_ENDPOINT must be an absolute HTTP(S) origin"
|
||||
|
|
|
|||
Loading…
Reference in a new issue