module API.Cargohold where

import API.Federator
import qualified Codec.MIME.Parse as MIME
import qualified Codec.MIME.Type as MIME
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import Data.ByteString.Builder
import Data.ByteString.Conversion
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.ByteString.Lazy.Char8 as Lazy8
import Data.CaseInsensitive
import Data.String.Conversions
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, decodeUtf8, encodeUtf8, encodeUtf8Builder)
import GHC.Stack
import Network.HTTP.Client (Request (redirectCount, requestHeaders))
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types.Header (HeaderName)
import Testlib.Prelude
import UnliftIO (catch)

type LByteString = LBS.ByteString

-- UPLOAD

uploadAsset :: (HasCallStack, MakesValue user) => user -> String -> App Response
uploadAsset :: forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
uploadAsset user
user String
payload = do
  String
uid <- user
user user -> (user -> App String) -> App String
forall a b. a -> (a -> b) -> b
& user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned String
"/assets"
  RequestBody
bdy <- HasCallStack => String -> App RequestBody
String -> App RequestBody
txtAsset String
payload
  String -> Request -> App Response
submit String
"POST"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zUser String
uid
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& RequestBody -> String -> Request -> Request
addBody RequestBody
bdy String
multipartMixedMime

uploadRaw :: (HasCallStack, MakesValue user) => user -> Lazy.ByteString -> App Response
uploadRaw :: forall user.
(HasCallStack, MakesValue user) =>
user -> ByteString -> App Response
uploadRaw user
user ByteString
bs = do
  String
uid <- user
user user -> (user -> App String) -> App String
forall a b. a -> (a -> b) -> b
& user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned String
"/assets"
  String -> Request -> App Response
submit String
"POST"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zUser String
uid
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Request -> Request
contentTypeMixed
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& (\Request
r -> Request
r {HTTP.requestBody = HTTP.RequestBodyLBS bs})

uploadAssetV3 :: (HasCallStack, MakesValue user, MakesValue assetRetention) => user -> Bool -> assetRetention -> MIME.MIMEType -> LByteString -> App Response
uploadAssetV3 :: forall user assetRetention.
(HasCallStack, MakesValue user, MakesValue assetRetention) =>
user
-> Bool -> assetRetention -> MIMEType -> ByteString -> App Response
uploadAssetV3 user
user Bool
isPublic assetRetention
retention MIMEType
mimeType ByteString
bdy = do
  String
uid <- user
user user -> (user -> App String) -> App String
forall a b. a -> (a -> b) -> b
& user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold (Int -> Versioned
ExplicitVersion Int
1) String
"/assets/v3"
  RequestBody
body <- Bool -> assetRetention -> ByteString -> MIMEType -> App RequestBody
forall assetRetention.
(HasCallStack, MakesValue assetRetention) =>
Bool -> assetRetention -> ByteString -> MIMEType -> App RequestBody
buildUploadAssetRequestBody Bool
isPublic assetRetention
retention ByteString
bdy MIMEType
mimeType
  String -> Request -> App Response
submit String
"POST"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zUser String
uid
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& RequestBody -> String -> Request -> Request
addBody RequestBody
body String
multipartMixedMime

uploadRawV3 ::
  (HasCallStack, MakesValue user) =>
  user ->
  Lazy.ByteString ->
  App Response
uploadRawV3 :: forall user.
(HasCallStack, MakesValue user) =>
user -> ByteString -> App Response
uploadRawV3 user
usr ByteString
bs = do
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
usr Service
Cargohold (Int -> Versioned
ExplicitVersion Int
1) String
"assets/v3"
  String -> Request -> App Response
submit String
"POST" (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Request -> Request
contentTypeMixed Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& (\Request
r -> Request
r {HTTP.requestBody = HTTP.RequestBodyLBS bs})

uploadProviderAsset :: (HasCallStack, MakesValue domain) => domain -> String -> String -> App Response
uploadProviderAsset :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> String -> String -> App Response
uploadProviderAsset domain
domain String
pid String
payload = do
  Request
req <- domain -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
rawBaseRequest domain
domain Service
Cargohold Versioned
Versioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinHttpPath [String
"provider", String
"assets"]
  RequestBody
bdy <- HasCallStack => String -> App RequestBody
String -> App RequestBody
txtAsset String
payload
  String -> Request -> App Response
submit String
"POST"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zProvider String
pid
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zType String
"provider"
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& RequestBody -> String -> Request -> Request
addBody RequestBody
bdy String
multipartMixedMime

-- DOWNLOAD

downloadAsset' ::
  (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetToken tok) =>
  user ->
  loc ->
  tok ->
  App Response
downloadAsset' :: forall user loc tok.
(HasCallStack, MakesValue user, IsAssetLocation loc,
 IsAssetToken tok) =>
user -> loc -> tok -> App Response
downloadAsset' user
user loc
loc tok
tok = do
  String
locPath <- loc -> App String
forall key. IsAssetLocation key => key -> App String
locationPathFragment loc
loc
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Unversioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
locPath
  String -> Request -> App Response
submit String
"GET" (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& tok -> Request -> Request
forall tok. IsAssetToken tok => tok -> Request -> Request
tokenParam tok
tok Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Request -> Request
noRedirect

downloadAsset ::
  (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) =>
  user ->
  assetDomain ->
  key ->
  String ->
  (HTTP.Request -> HTTP.Request) ->
  App Response
downloadAsset :: forall user key assetDomain.
(HasCallStack, MakesValue user, MakesValue key,
 MakesValue assetDomain) =>
user
-> assetDomain
-> key
-> String
-> (Request -> Request)
-> App Response
downloadAsset user
user assetDomain
assetDomain key
key String
zHostHeader Request -> Request
trans = do
  String
domain <- assetDomain -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain assetDomain
assetDomain
  String
key' <- key -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString key
key
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"/assets/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
domain String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key'
  String -> Request -> App Response
submit String
"GET"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zHost String
zHostHeader
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Request -> Request
trans

downloadAssetWithQualifiedAssetKey ::
  (HasCallStack, IsAssetToken tok, MakesValue key, MakesValue user) =>
  (HTTP.Request -> HTTP.Request) ->
  user ->
  key ->
  tok ->
  App Response
downloadAssetWithQualifiedAssetKey :: forall tok key user.
(HasCallStack, IsAssetToken tok, MakesValue key,
 MakesValue user) =>
(Request -> Request) -> user -> key -> tok -> App Response
downloadAssetWithQualifiedAssetKey Request -> Request
r user
user key
key tok
tok = do
  String
dom <- key
key key -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  String
keyId <- key
key key -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold (Int -> Versioned
ExplicitVersion Int
2) (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"assets/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dom String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
keyId
  String -> Request -> App Response
submit String
"GET"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& tok -> Request -> Request
forall tok. IsAssetToken tok => tok -> Request -> Request
tokenParam tok
tok
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& Request -> Request
r

-- DELETE

deleteAssetV3 :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response
deleteAssetV3 :: forall user key.
(HasCallStack, MakesValue user, MakesValue key) =>
user -> key -> App Response
deleteAssetV3 user
user key
key = do
  String
k <- key
key key -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold (Int -> Versioned
ExplicitVersion Int
1) (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"assets/v3/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k
  String -> Request -> App Response
submit String
"DELETE" Request
req

deleteAsset :: (HasCallStack, MakesValue user, MakesValue key) => user -> key -> App Response
deleteAsset :: forall user key.
(HasCallStack, MakesValue user, MakesValue key) =>
user -> key -> App Response
deleteAsset user
user key
key = do
  String
k <- key
key key -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  String
d <- key
key key -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"/assets/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
d String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k
  String -> Request -> App Response
submit String
"DELETE" Request
req

-- TOKEN

postToken :: (MakesValue user, HasCallStack) => user -> String -> App Response
postToken :: forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
postToken user
user String
key = do
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"assets/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/token"
  String -> Request -> App Response
submit String
"POST" Request
req

deleteToken :: (MakesValue user, HasCallStack) => user -> String -> App Response
deleteToken :: forall user.
(MakesValue user, HasCallStack) =>
user -> String -> App Response
deleteToken user
user String
key = do
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall user.
(HasCallStack, MakesValue user) =>
user -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
Cargohold Versioned
Versioned (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$ String
"assets/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/token"
  String -> Request -> App Response
submit String
"DELETE" Request
req

--------------------------------------------------------------------------------
-- FEDERATION

getFederationAsset :: (HasCallStack, MakesValue asset) => asset -> App Response
getFederationAsset :: forall asset.
(HasCallStack, MakesValue asset) =>
asset -> App Response
getFederationAsset asset
ga = do
  Request
req <- Domain -> (ServiceMap -> HostPort) -> String -> App Request
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> (ServiceMap -> HostPort) -> String -> App Request
rawBaseRequestF Domain
OwnDomain ServiceMap -> HostPort
cargohold String
"federation/get-asset"
  Value
bdy <- asset -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make asset
ga
  String -> Request -> App Response
submit String
"POST"
    (Request -> App Response) -> Request -> App Response
forall a b. (a -> b) -> a -> b
$ Request
req
    Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& RequestBody -> String -> Request -> Request
addBody (ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
bdy) String
"application/json"

--------------------------------------------------------------------------------
-- UTIL

uploadSomeAsset :: (HasCallStack, MakesValue user) => user -> App Response
uploadSomeAsset :: forall asset.
(HasCallStack, MakesValue asset) =>
asset -> App Response
uploadSomeAsset = (user -> String -> App Response) -> String -> user -> App Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip user -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> App Response
uploadAsset String
"Hello World!"

txtAsset :: (HasCallStack) => String -> App HTTP.RequestBody
txtAsset :: HasCallStack => String -> App RequestBody
txtAsset String
payload =
  Bool -> Maybe String -> ByteString -> MIMEType -> App RequestBody
forall assetRetention.
(HasCallStack, MakesValue assetRetention) =>
Bool -> assetRetention -> ByteString -> MIMEType -> App RequestBody
buildUploadAssetRequestBody
    Bool
True
    (Maybe String
forall a. Maybe a
Nothing :: Maybe String)
    (String -> ByteString
LBSC.pack String
payload)
    MIMEType
textPlainMime

textPlainMime :: MIME.MIMEType
textPlainMime :: MIMEType
textPlainMime = SubType -> MIMEType
MIME.Text (SubType -> MIMEType) -> SubType -> MIMEType
forall a b. (a -> b) -> a -> b
$ String -> SubType
T.pack String
"plain"

-- This case is a bit special and doesn't fit to MIMEType: We need to define
-- the boundary.
multipartMixedMime :: String
multipartMixedMime :: String
multipartMixedMime = String
"multipart/mixed; boundary=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
multipartBoundary

buildUploadAssetRequestBody ::
  (HasCallStack, MakesValue assetRetention) =>
  Bool ->
  assetRetention ->
  LByteString ->
  MIME.MIMEType ->
  App HTTP.RequestBody
buildUploadAssetRequestBody :: forall assetRetention.
(HasCallStack, MakesValue assetRetention) =>
Bool -> assetRetention -> ByteString -> MIMEType -> App RequestBody
buildUploadAssetRequestBody Bool
isPublic assetRetention
retention ByteString
body MIMEType
mimeType = do
  Value
mbRetention <- assetRetention -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make assetRetention
retention
  let header' :: Aeson.Value
      header' :: Value
header' =
        [Pair] -> Value
Aeson.object
          [ String
"public" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
isPublic,
            String
"retention" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
mbRetention
          ]
  ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> App ByteString -> App RequestBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> ByteString -> MIMEType -> App ByteString
forall header.
(HasCallStack, MakesValue header) =>
header -> ByteString -> MIMEType -> App ByteString
buildMultipartBody Value
header' ByteString
body MIMEType
mimeType

class IsAssetLocation key where
  locationPathFragment :: key -> App String

instance {-# OVERLAPS #-} IsAssetLocation String where
  locationPathFragment :: String -> App String
locationPathFragment = String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- Pick out a path from the value
instance (MakesValue loc) => IsAssetLocation loc where
  locationPathFragment :: loc -> App String
locationPathFragment loc
v =
    App String
qualifiedFrag App String -> (SomeException -> App String) -> App String
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
_e :: SomeException) -> App String
unqualifiedFrag)
    where
      qualifiedFrag :: App String
qualifiedFrag = do
        String
domain <- loc
v loc -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
        String
key <- loc
v loc -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"key" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
        String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ String
"v2/assets/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
domain String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
key
      unqualifiedFrag :: App String
unqualifiedFrag = do
        String
key <- loc -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString loc
v
        String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ String
"v1/asssets/v3/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
key

noRedirect :: Request -> Request
noRedirect :: Request -> Request
noRedirect Request
r = Request
r {redirectCount = 0}

uploadSimpleV3 ::
  (HasCallStack, MakesValue user, MakesValue settings) =>
  user ->
  settings ->
  (MIME.MIMEType, Lazy8.ByteString) ->
  App Response
uploadSimpleV3 :: forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimpleV3 user
usr settings
sts (MIMEType
ct, ByteString
bs) = do
  ByteString
body <- settings -> ByteString -> MIMEType -> App ByteString
forall header.
(HasCallStack, MakesValue header) =>
header -> ByteString -> MIMEType -> App ByteString
buildMultipartBody settings
sts ByteString
bs MIMEType
ct
  user -> ByteString -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ByteString -> App Response
uploadRawV3 user
usr ByteString
body

uploadSimple ::
  (HasCallStack, MakesValue user, MakesValue settings) =>
  user ->
  settings ->
  (MIME.MIMEType, Lazy8.ByteString) ->
  App Response
uploadSimple :: forall user settings.
(HasCallStack, MakesValue user, MakesValue settings) =>
user -> settings -> (MIMEType, ByteString) -> App Response
uploadSimple user
usr settings
sts (MIMEType
ct, ByteString
bs) = do
  ByteString
body <- settings -> ByteString -> MIMEType -> App ByteString
forall header.
(HasCallStack, MakesValue header) =>
header -> ByteString -> MIMEType -> App ByteString
buildMultipartBody settings
sts ByteString
bs MIMEType
ct
  user -> ByteString -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ByteString -> App Response
uploadRaw user
usr ByteString
body

decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response -> a
decodeHeaderOrFail :: forall a.
(HasCallStack, FromByteString a) =>
HeaderName -> Response -> a
decodeHeaderOrFail HeaderName
h =
  a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"decodeHeaderOrFail: missing or invalid header: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HeaderName -> String
forall a. Show a => a -> String
show HeaderName
h)
    (Maybe a -> a) -> (Response -> Maybe a) -> Response -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> Maybe a
forall a. FromByteString a => StrictByteString -> Maybe a
fromByteString
    (StrictByteString -> Maybe a)
-> (Response -> StrictByteString) -> Response -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Response -> StrictByteString
getHeader' HeaderName
h

-- | Like 'getHeader', but if no value exists for the given key, return the
-- static ByteString "NO_HEADER_VALUE".
getHeader' :: HeaderName -> Response -> ByteString
getHeader' :: HeaderName -> Response -> StrictByteString
getHeader' HeaderName
h = StrictByteString -> Maybe StrictByteString -> StrictByteString
forall a. a -> Maybe a -> a
fromMaybe (String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"NO_HEADER_VALUE") (Maybe StrictByteString -> StrictByteString)
-> (Response -> Maybe StrictByteString)
-> Response
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Response -> Maybe StrictByteString
getHeader HeaderName
h

getHeader :: HeaderName -> Response -> Maybe ByteString
getHeader :: HeaderName -> Response -> Maybe StrictByteString
getHeader HeaderName
h = ((HeaderName, StrictByteString) -> StrictByteString)
-> Maybe (HeaderName, StrictByteString) -> Maybe StrictByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HeaderName, StrictByteString) -> StrictByteString
forall a b. (a, b) -> b
snd (Maybe (HeaderName, StrictByteString) -> Maybe StrictByteString)
-> (Response -> Maybe (HeaderName, StrictByteString))
-> Response
-> Maybe StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, StrictByteString) -> Bool)
-> [(HeaderName, StrictByteString)]
-> Maybe (HeaderName, StrictByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName
h ==) (HeaderName -> Bool)
-> ((HeaderName, StrictByteString) -> HeaderName)
-> (HeaderName, StrictByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, StrictByteString) -> HeaderName
forall a b. (a, b) -> a
fst) ([(HeaderName, StrictByteString)]
 -> Maybe (HeaderName, StrictByteString))
-> (Response -> [(HeaderName, StrictByteString)])
-> Response
-> Maybe (HeaderName, StrictByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> [(HeaderName, StrictByteString)]
headers

getContentType :: Response -> Maybe MIME.Type
getContentType :: Response -> Maybe Type
getContentType = SubType -> Maybe Type
MIME.parseContentType (SubType -> Maybe Type)
-> (Response -> SubType) -> Response -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> SubType
decodeLatin1 (StrictByteString -> SubType)
-> (Response -> StrictByteString) -> Response -> SubType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Response -> StrictByteString
getHeader' (StrictByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (StrictByteString -> HeaderName) -> StrictByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"Content-Type")

applicationText :: MIME.MIMEType
applicationText :: MIMEType
applicationText = SubType -> MIMEType
MIME.Application (SubType -> MIMEType) -> SubType -> MIMEType
forall a b. (a -> b) -> a -> b
$ String -> SubType
forall a b. ConvertibleStrings a b => a -> b
cs String
"text"

applicationOctetStream :: MIME.MIMEType
applicationOctetStream :: MIMEType
applicationOctetStream = SubType -> MIMEType
MIME.Application (SubType -> MIMEType) -> SubType -> MIMEType
forall a b. (a -> b) -> a -> b
$ String -> SubType
forall a b. ConvertibleStrings a b => a -> b
cs String
"octet-stream"

applicationOctetStream' :: MIME.Type
applicationOctetStream' :: Type
applicationOctetStream' = MIMEType -> [MIMEParam] -> Type
MIME.Type MIMEType
applicationOctetStream []

header :: String -> String -> Request -> Request
header :: String -> String -> Request -> Request
header String
name String
value Request
req =
  Request
req {requestHeaders = (mk $ cs name, cs value) : requestHeaders req}

class IsAssetToken tok where
  tokenParam :: tok -> Request -> Request

instance IsAssetToken () where
  tokenParam :: () -> Request -> Request
tokenParam ()
_ = Request -> Request
forall a. a -> a
id

instance IsAssetToken String where
  tokenParam :: String -> Request -> Request
tokenParam = String -> String -> Request -> Request
header String
"Asset-Token"

instance (IsAssetToken a, IsAssetToken b) => IsAssetToken (Either a b) where
  tokenParam :: Either a b -> Request -> Request
tokenParam = (a -> Request -> Request)
-> (b -> Request -> Request) -> Either a b -> Request -> Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Request -> Request
forall tok. IsAssetToken tok => tok -> Request -> Request
tokenParam b -> Request -> Request
forall tok. IsAssetToken tok => tok -> Request -> Request
tokenParam

instance IsAssetToken Value where
  tokenParam :: Value -> Request -> Request
tokenParam Value
v =
    case Value
v of
      String SubType
s -> String -> String -> Request -> Request
header String
h (String -> Request -> Request) -> String -> Request -> Request
forall a b. (a -> b) -> a -> b
$ SubType -> String
forall a b. ConvertibleStrings a b => a -> b
cs SubType
s
      Object Object
o -> (Request -> Request)
-> (Value -> Request -> Request)
-> Maybe Value
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id Value -> Request -> Request
forall tok. IsAssetToken tok => tok -> Request -> Request
tokenParam (Maybe Value -> Request -> Request)
-> Maybe Value -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Aeson.lookup (String -> Key
forall a. IsString a => String -> a
fromString String
"token") Object
o
      Value
_ -> String -> Request -> Request
forall a. HasCallStack => String -> a
error String
"Non-matching Asset-Token value"
    where
      h :: String
h = String
"Asset-Token"

instance IsAssetToken (Request -> Request) where
  tokenParam :: (Request -> Request) -> Request -> Request
tokenParam = (Request -> Request) -> Request -> Request
forall a. a -> a
id

-- | Build a complete @multipart/mixed@ request body for a one-shot,
-- non-resumable asset upload.
buildMultipartBody :: (HasCallStack, MakesValue header) => header -> Lazy.ByteString -> MIME.MIMEType -> App Lazy.ByteString
buildMultipartBody :: forall header.
(HasCallStack, MakesValue header) =>
header -> ByteString -> MIMEType -> App ByteString
buildMultipartBody header
header' ByteString
body MIMEType
bodyMimeType = do
  Value
h <- header -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make header
header'
  let headerJson :: ByteString
headerJson = Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
h

      render :: Builder
      render :: Builder
render = Builder
renderBody Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
endMultipartBody

      endMultipartBody :: Builder
      endMultipartBody :: Builder
endMultipartBody = Builder
lineBreak Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
boundary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
"--" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak

      renderBody :: Builder
      renderBody :: Builder
renderBody = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ MIMEValue -> Builder
renderPart (MIMEValue -> Builder) -> [MIMEValue] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MIMEValue]
multipartContent

      renderPart :: MIME.MIMEValue -> Builder
      renderPart :: MIMEValue -> Builder
renderPart MIMEValue
v =
        Builder
boundary
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Type -> Builder
contentType (Type -> Builder) -> (MIMEValue -> Type) -> MIMEValue -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MIMEValue -> Type
MIME.mime_val_type) MIMEValue
v
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ([MIMEParam] -> Builder
headers ([MIMEParam] -> Builder)
-> (MIMEValue -> [MIMEParam]) -> MIMEValue -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MIMEValue -> [MIMEParam]
MIME.mime_val_headers) MIMEValue
v
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (MIMEContent -> Builder
content (MIMEContent -> Builder)
-> (MIMEValue -> MIMEContent) -> MIMEValue -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MIMEValue -> MIMEContent
MIME.mime_val_content) MIMEValue
v
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lineBreak

      boundary :: Builder
      boundary :: Builder
boundary = String -> Builder
stringUtf8 String
"--" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
multipartBoundary

      lineBreak :: Builder
      lineBreak :: Builder
lineBreak = String -> Builder
stringUtf8 String
"\r\n"

      contentType :: MIME.Type -> Builder
      contentType :: Type -> Builder
contentType Type
t = String -> Builder
stringUtf8 String
"Content-Type: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (SubType -> Builder
encodeUtf8Builder (SubType -> Builder) -> (Type -> SubType) -> Type -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> SubType
MIME.showType) Type
t

      headers :: [MIME.MIMEParam] -> Builder
      headers :: [MIMEParam] -> Builder
headers [] = Builder
forall a. Monoid a => a
mempty
      headers (MIMEParam
x : [MIMEParam]
xs) = MIMEParam -> Builder
renderHeader MIMEParam
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [MIMEParam] -> Builder
headers [MIMEParam]
xs

      renderHeader :: MIME.MIMEParam -> Builder
      renderHeader :: MIMEParam -> Builder
renderHeader MIMEParam
p =
        SubType -> Builder
encodeUtf8Builder (MIMEParam -> SubType
MIME.paramName MIMEParam
p)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
": "
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SubType -> Builder
encodeUtf8Builder (MIMEParam -> SubType
MIME.paramValue MIMEParam
p)

      content :: MIME.MIMEContent -> Builder
      content :: MIMEContent -> Builder
content (MIME.Single SubType
c) = SubType -> Builder
encodeUtf8Builder SubType
c
      content (MIME.Multi [MIMEValue]
_) = String -> Builder
forall a. HasCallStack => String -> a
error String
"Not implemented."

      multipartContent :: [MIME.MIMEValue]
      multipartContent :: [MIMEValue]
multipartContent =
        [ MIMEType -> ByteString -> MIMEValue
part (SubType -> MIMEType
MIME.Application (String -> SubType
T.pack String
"json")) ByteString
headerJson,
          MIMEType -> ByteString -> MIMEValue
part MIMEType
bodyMimeType ByteString
body
        ]

      part :: MIME.MIMEType -> Lazy.ByteString -> MIME.MIMEValue
      part :: MIMEType -> ByteString -> MIMEValue
part MIMEType
mtype ByteString
c =
        MIMEValue
MIME.nullMIMEValue
          { MIME.mime_val_type = MIME.Type mtype [],
            MIME.mime_val_headers = [MIME.MIMEParam (T.pack "Content-Length") ((T.pack . show . LBS.length) c)],
            MIME.mime_val_content = MIME.Single ((decodeUtf8 . LBS.toStrict) c)
          }

  ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> App ByteString) -> ByteString -> App ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
render

multipartBoundary :: String
multipartBoundary :: String
multipartBoundary = String
"frontier"

buildMultipartBody' :: Value -> MIME.Type -> LBS.ByteString -> Builder
buildMultipartBody' :: Value -> Type -> ByteString -> Builder
buildMultipartBody' Value
sets Type
typ ByteString
bs =
  Value -> Type -> Word -> Builder
beginMultipartBody Value
sets Type
typ (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> Int64 -> Word
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length ByteString
bs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
endMultipartBody'

-- | Begin building a @multipart/mixed@ request body for a non-resumable upload.
-- The returned 'Builder' can be immediately followed by the actual asset bytes.
beginMultipartBody :: Value -> MIME.Type -> Word -> Builder
beginMultipartBody :: Value -> Type -> Word -> Builder
beginMultipartBody Value
sets Type
t Word
l =
  StrictByteString -> Builder
byteString
    ( String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs
        String
"--frontier\r\n\
        \Content-Type: application/json\r\n\
        \Content-Length: "
    )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int64 -> Builder
int64Dec (ByteString -> Int64
LBS.length ByteString
settingsJson)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
byteString
      ( String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs
          String
"\r\n\
          \\r\n"
      )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
settingsJson
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
byteString
      ( String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs
          String
"\r\n\
          \--frontier\r\n\
          \Content-Type: "
      )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
byteString (SubType -> StrictByteString
encodeUtf8 (Type -> SubType
MIME.showType Type
t))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
byteString
      ( String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs
          String
"\r\n\
          \Content-Length: "
      )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Builder
wordDec Word
l
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
byteString
      ( String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs
          String
"\r\n\
          \\r\n"
      )
  where
    settingsJson :: ByteString
settingsJson = Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
sets

-- | The trailer of a non-resumable @multipart/mixed@ request body initiated
-- via 'beginMultipartBody'.
endMultipartBody' :: Builder
endMultipartBody' :: Builder
endMultipartBody' = StrictByteString -> Builder
byteString (StrictByteString -> Builder) -> StrictByteString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> StrictByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"\r\n--frontier--\r\n"