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
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
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
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
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
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"
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"
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
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
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
getHeader' :: HeaderName -> Response -> ByteString
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
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
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
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'
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
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"