When GETing the keyId, set Accept header to JSON-LD/AS2

This commit is contained in:
fr33domlover 2019-01-19 02:57:58 +00:00
parent 93def0dfc8
commit 393cce0ede

View file

@ -40,7 +40,7 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit) import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second) import Data.Time.Units (Second)
import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.URI (URI (uriFragment), parseURI) import Network.URI (URI (uriFragment), parseURI)
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import UnliftIO.Exception (try) import UnliftIO.Exception (try)
@ -156,7 +156,14 @@ postInboxR = do
Nothing -> Left "keyId in Sig header isn't a valid absolute URI" Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
Just uri -> Right uri Just uri -> Right uri
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
response <- ExceptT $ first (displayException :: HttpException -> String) <$> (try $ httpJSONEither . setRequestManager manager =<< requestFromURI u) response <-
ExceptT $ first (displayException :: HttpException -> String) <$>
(try $
httpJSONEither .
addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
setRequestManager manager
=<< requestFromURI u
)
liftE $ do liftE $ do
actor <- first displayException $ getResponseBody response actor <- first displayException $ getResponseBody response
let uActor = u { uriFragment = "" } let uActor = u { uriFragment = "" }