82 lines
2.3 KiB
Haskell
82 lines
2.3 KiB
Haskell
{-# language DataKinds #-}
|
|
|
|
module Fedi.Requests where
|
|
|
|
import Data.List (intercalate)
|
|
import Data.Aeson qualified as A
|
|
import Fedi.Helpers
|
|
import Fedi.UserDetails
|
|
import Fedi.Signature.Sign
|
|
import Network.HTTP.Req qualified as Req
|
|
import Data.ByteString.Lazy qualified as BSL
|
|
import Text.URI qualified as URI
|
|
import Data.Text qualified as T
|
|
|
|
sendPost
|
|
:: A.ToJSON input
|
|
=> UserDetails
|
|
-> String
|
|
-> input
|
|
-> IO ByteString
|
|
sendPost details url payload = do
|
|
uri <- URI.mkURI $ fromString url
|
|
let encoded = BSL.toStrict $ A.encode payload
|
|
httpSignature <- makeHttpSignature details uri encoded
|
|
(url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
|
|
Req.runReq Req.defaultHttpConfig do
|
|
r <-
|
|
Req.req
|
|
Req.POST
|
|
url'
|
|
(Req.ReqBodyBs encoded)
|
|
Req.bsResponse
|
|
( scheme
|
|
<> sigHeaders httpSignature
|
|
)
|
|
pure $ Req.responseBody r
|
|
|
|
makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature
|
|
makeHttpSignature details uri encoded = do
|
|
host <- case uri.uriAuthority of
|
|
Right u -> pure $ T.unpack $ URI.unRText u.authHost
|
|
_ -> throw "no host in uri"
|
|
-- We may want to add the uri path and uri query,
|
|
-- but maybe later.
|
|
let
|
|
path = case uri.uriPath of
|
|
Just (_, list) ->
|
|
"/" <> intercalate "/" (map (T.unpack . URI.unRText) $ toList list)
|
|
Nothing -> "/"
|
|
signSignature details host ("post " <> path) encoded
|
|
|
|
|
|
sigHeaders :: HttpSignature -> Req.Option scheme
|
|
sigHeaders =
|
|
foldMap (uncurry Req.header) . makeSigHeaders
|
|
|
|
makeSigHeaders :: HttpSignature -> [(ByteString, ByteString)]
|
|
makeSigHeaders httpSignature =
|
|
[ ("ContentType", "application/activity+json")
|
|
, ("Accept", "application/activity+json")
|
|
, ("Digest", httpSignature.digest)
|
|
, ("Host", fromString httpSignature.host)
|
|
, ("Date", fromString httpSignature.date)
|
|
, ("Signature", toSignature httpSignature.signatureHeader)
|
|
]
|
|
|
|
sendGet :: (A.FromJSON a) => String -> IO a
|
|
sendGet url = do
|
|
uri <- URI.mkURI $ fromString url
|
|
(url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
|
|
|
|
Req.runReq Req.defaultHttpConfig do
|
|
r <-
|
|
Req.req
|
|
Req.GET
|
|
url'
|
|
Req.NoReqBody
|
|
Req.jsonResponse
|
|
( scheme
|
|
<> Req.header "ContentType" "application/activity+json"
|
|
)
|
|
pure $ Req.responseBody r
|