diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,16 @@ # Revision history for bluesky-tools +## 0.4.0.0 -- 2024-01-06 + +* Stop exporting Document constructor so I can continue to change it. +* getPds retrieves the PDS URI from a DID document. +* Add Handle.verifyHandle. +* Tweak Handle.resolveVerify so that failing to fetch DID document is a verification failure. + ## 0.2.2.0 -- 2024-01-05 -* Fix build error -* Export unintentionally-hidden BothFailed +* Fix build error. +* Export unintentionally-hidden BothFailed. ## 0.2.0.0 -- 2024-01-05 diff --git a/bluesky-tools.cabal b/bluesky-tools.cabal --- a/bluesky-tools.cabal +++ b/bluesky-tools.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 name: bluesky-tools -version: 0.2.2.0 +version: 0.4.0.0 synopsis: Tools for interacting with Bluesky / AT Protocol description: bluesky-tools provides tools that I've found useful while trying to integrate @@ -46,10 +46,12 @@ aeson ^>=2.1, async ^>=2.2, base ^>=4.18, + containers ^>=0.6, dns ^>=4.2, http-api-data ^>=0.6, http-client ^>=0.7, http-types ^>=0.12, + network-uri ^>=2.6, text ^>=2.0, transformers ^>=0.6, diff --git a/src/Bluesky/Did.hs b/src/Bluesky/Did.hs --- a/src/Bluesky/Did.hs +++ b/src/Bluesky/Did.hs @@ -1,10 +1,15 @@ module Bluesky.Did ( Did(Did), rawDid - , Document(Document, alsoKnownAs) + , Document(alsoKnownAs), getPds , getDocument ) where import qualified Data.Aeson as Aeson +import Data.Aeson ((.:)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid (First(First, getFirst)) import qualified Data.Text as Text import Data.Text (Text) import GHC.Generics @@ -12,8 +17,10 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.URI as URI -- | https://atproto.com/specs/did +-- -- A DID is a Decentralized Identifier. They're codified by various W3C -- standards. This type only aims to capture how they are used in atproto. -- @@ -36,14 +43,55 @@ | "did:plc:" `Text.isPrefixOf` rawDid = Just Plc | otherwise = Nothing --- | Currently this is only used for ensuring a handle that has been resolved to --- a DID is referenced by the DID document (so it is the correct handle for this --- DID). The other fields are ignored. +data Service = Service + { serviceId :: Text + , serviceType :: Text + , serviceEndpoint :: URI.URI + } deriving stock (Eq, Ord, Show, Generic) + +instance Aeson.FromJSON Service where + parseJSON = Aeson.withObject "Service" $ \o -> do + serviceId <- o .: "id" + serviceType <- o .: "type" + serviceEndpointString <- o .: "serviceEndpoint" -- [sic] + serviceEndpoint <- + maybe + (fail $ "Couldn't parse serviceEndpoint URI: " <> show serviceEndpointString) + pure + $ URI.parseURI serviceEndpointString + pure Service{ serviceId, serviceType, serviceEndpoint } + +-- | Fields that the library currently doesn't understand are ignored. data Document = Document - { id :: Did + { documentId :: Did , alsoKnownAs :: [Text] + , service :: [Service] } deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (Aeson.FromJSON) + +getPds :: Document -> Maybe URI.URI +getPds Document{ service } = + getFirst $ foldMap (First . get) service + where + get Service{ serviceId, serviceType, serviceEndpoint } + | "#atproto_pds" `Text.isSuffixOf` serviceId + && serviceType == "AtprotoPersonalDataServer" + = Just serviceEndpoint + | otherwise = Nothing + +genericParseJSONMapFields + :: (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) + => [(String, String)] -> Aeson.Value -> Aeson.Parser a +genericParseJSONMapFields fields = + Aeson.genericParseJSON + Aeson.defaultOptions{ Aeson.fieldLabelModifier = mapFields } + where + mapFields field = fromMaybe field (Map.lookup field fieldsMap) + fieldsMap = Map.fromList fields + +instance Aeson.FromJSON Document where + parseJSON = + genericParseJSONMapFields + [("documentId", "id")] -- | This is currently only implemented for did:plc: DIDs. getDocument :: HasCallStack => HTTP.Manager -> Did -> IO (Maybe Document) diff --git a/src/Bluesky/Handle.hs b/src/Bluesky/Handle.hs --- a/src/Bluesky/Handle.hs +++ b/src/Bluesky/Handle.hs @@ -1,12 +1,12 @@ module Bluesky.Handle ( Handle, rawHandle, makeHandle, HandleError(..), validTld , resolveViaDns, resolveViaHttp, resolveViaBoth, BothFailed(..) - , resolveVerify + , verifyHandle, resolveVerify ) where import qualified Control.Concurrent.Async as Async import qualified Control.Exception as Except -import Control.Monad +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) @@ -155,12 +155,21 @@ fromE (Right (Just dnsException, Just httpException)) = Except.throwIO BothFailed{ dnsException, httpException } --- | Also fetches the DID document and checks that the handle is listed there. --- Raises an error if not. +-- | 'Just True' if this 'Handle' appears in the DID 'Document' for the 'Did'. +-- 'Just False' if the document is available and doesn't affirm the handle. +-- 'Nothing' if the document can't be fetched. +verifyHandle :: HTTP.Manager -> Handle -> Did -> IO (Maybe Bool) +verifyHandle httpManager (Handle rawHandle) did = runMaybeT $ do + doc <- MaybeT $ getDocument httpManager did + pure $ ("at://" <> rawHandle) `elem` alsoKnownAs doc + +-- | Combines 'resolveViaBoth' and 'verifyHandle'. Raises an error if +-- verification fails. resolveVerify :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did) -resolveVerify httpManager handle@(Handle rawHandle) = runMaybeT $ do +resolveVerify httpManager handle = runMaybeT $ do did <- MaybeT $ resolveViaBoth httpManager handle - Document{ alsoKnownAs } <- MaybeT $ getDocument httpManager did - unless (("at://" <> rawHandle) `elem` alsoKnownAs) $ - error "Handle isn't in alsoKnownAs for its DID document" - pure did + verified <- lift $ verifyHandle httpManager handle did + case verified of + Nothing -> error "Can't get DID document to verify handle" + Just False -> error "Handle failed verification: not in DID document" + Just True -> pure did