bluesky-tools 0.4.0.0 → 0.6.0.0

raw patch · 7 files changed

+125/−17 lines, 7 filesdep ~http-api-dataPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: http-api-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• bluesky-tools.cabal +3/−2
• src/Bluesky/Did.hs +46/−8
• src/Bluesky/Handle.hs +19/−7
• test/Did.hs +47/−0
• test/Handle.hs +1/−0
• test/Main.hs +2/−0

@@ -1,5 +1,12 @@ # Revision history for bluesky-tools +## 0.6.0.0 -- 2024-01-11++* Support older versions of `http-api-data`.+* Add `ToJSON Did`, and both `FromJSON`, `ToJSON` for `Handle`.+* Implement DID syntax validating `makeHandle`, and enforce it by removing the+  export of the `Did` constructor.+ ## 0.4.0.0 -- 2024-01-06  * Stop exporting Document constructor so I can continue to change it.

@@ -1,7 +1,7 @@ cabal-version:      3.4  name:               bluesky-tools-version:            0.4.0.0+version:            0.6.0.0 synopsis:           Tools for interacting with Bluesky / AT Protocol description:   bluesky-tools provides tools that I've found useful while trying to integrate@@ -48,7 +48,7 @@     base ^>=4.18,     containers ^>=0.6,     dns ^>=4.2,-    http-api-data ^>=0.6,+    http-api-data >= 0.5 && < 0.6,     http-client ^>=0.7,     http-types ^>=0.12,     network-uri ^>=2.6,@@ -62,6 +62,7 @@   hs-source-dirs: test   main-is: Main.hs   other-modules:+    Did     Handle   build-depends:     base ^>=4.18,

@@ -1,5 +1,5 @@ module Bluesky.Did-  ( Did(Did), rawDid+  ( Did, rawDid, makeDid, DidError(..)   , Document(alsoKnownAs), getPds   , getDocument   ) where@@ -7,6 +7,7 @@ import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) import qualified Data.Aeson.Types as Aeson+import qualified Data.Char as Char import qualified Data.Map as Map import Data.Maybe import Data.Monoid (First(First, getFirst))@@ -23,12 +24,49 @@ -- -- 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.------ Currently we do not implement DID validation. newtype Did = Did { rawDid :: Text }   deriving stock (Eq, Ord, Show)-  deriving newtype (Aeson.FromJSON)+  deriving newtype (Aeson.ToJSON) +data DidError+  = NoDidPrefix+  | NoMethodSeparator+    -- ^ after "did:", there must be another colon to delimit method from+    -- identifier+  | BadMethod+    -- ^ method must match the regex @[a-z]+@; this does not check if the method+    -- is supported by atproto+  | BadIdentifierCharacters+    -- ^ identifier section must match @[a-zA-Z0-9._:%-]@+    -- (nb. that general DID URIs may also have query and fragment components,+    -- i.e. @?@ and @#@ characters, but atproto DID identifiers may not)+  | EndsWithColon+  | BadPercentEncoding+    -- ^ the spec says implementations don't need to validate percent encoding,+    -- but we validate that every % is followed by two hex digits+  deriving stock (Show, Eq, Ord)++makeDid :: Text -> Either DidError Did+makeDid raw+  | not ("did:" `Text.isPrefixOf` raw) = Left NoDidPrefix+  | Text.null method+    || Text.any (not . isMethodChar) method = Left BadMethod+  | Text.any (not . isIdentifierChar) colonBody = Left BadIdentifierCharacters+  | Text.takeEnd 1 raw == ":" = Left EndsWithColon+  | any (not . Text.all Char.isHexDigit) percentEncodes = Left BadPercentEncoding+  | otherwise = Right (Did raw)+  where+    afterPrefix = Text.drop 4 raw+    (method, colonBody) = Text.breakOn ":" afterPrefix+    isMethodChar c = Char.isAscii c && Char.isLower c+    isIdentifierChar c =+      Char.isAscii c+      && (Char.isAlphaNum c || elem c ("._:%-" :: [Char]))+    percentEncodes = map (Text.take 2) . drop 1 $ Text.splitOn "%" colonBody++instance Aeson.FromJSON Did where+  parseJSON = Aeson.withText "Bluesky.Did.Did" $ either (fail . show) pure . makeDid+ -- | The DID methods supported by atproto. Note that DIDs are used outside of -- atproto and there are many more methods in those contexts, but we don't -- support them here.@@ -37,8 +75,8 @@   | Plc -- ^ https://github.com/did-method-plc/did-method-plc   deriving stock (Eq, Ord, Show) -method :: Did -> Maybe Method-method Did{ rawDid }+getMethod :: Did -> Maybe Method+getMethod Did{ rawDid }   | "did:web:" `Text.isPrefixOf` rawDid = Just Web   | "did:plc:" `Text.isPrefixOf` rawDid = Just Plc   | otherwise = Nothing@@ -50,7 +88,7 @@   } deriving stock (Eq, Ord, Show, Generic)  instance Aeson.FromJSON Service where-  parseJSON = Aeson.withObject "Service" $ \o -> do+  parseJSON = Aeson.withObject "Bluesky.Did.Service" $ \o -> do     serviceId <- o .: "id"     serviceType <- o .: "type"     serviceEndpointString <- o .: "serviceEndpoint" -- [sic]@@ -96,7 +134,7 @@ -- | This is currently only implemented for did:plc: DIDs. getDocument :: HasCallStack => HTTP.Manager -> Did -> IO (Maybe Document) getDocument httpManager did@(Did rawDid) =-  case method did of+  case getMethod did of     Nothing -> error "Unknown DID method"     Just Web -> error "Support for did:web: is not yet implemented"     Just Plc -> do

@@ -16,6 +16,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text (Text)+import GHC.Generics import GHC.Stack (HasCallStack)  import qualified Network.DNS as DNS@@ -27,7 +28,8 @@  -- | https://atproto.com/specs/handle newtype Handle = Handle { rawHandle :: Text }-  deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show, Generic)+  deriving newtype (Aeson.ToJSON)  data HandleError   = TooLong@@ -78,10 +80,17 @@ instance FromHttpApiData Handle where   parseUrlPiece = Bifunctor.first (Text.pack . show) . makeHandle +instance Aeson.FromJSON Handle where+  parseJSON =+    Aeson.withText "Bluesky.Handle.Handle" $ either (fail . show) pure . makeHandle+ -- | Returns 'Nothing' in ordinary cases where this handle can't be resolved by--- DNS. May raise an exception if either the handle has an invalid TLD or--- something goes wrong with DNS resolution.+-- DNS. May raise an exception if: --+-- * the handle has an invalid TLD,+-- * something goes wrong with DNS resolution,+-- * the DID returned is syntactically invalid.+-- -- Note that this handle shouldn't be considered valid for this DID until you've -- looked up the associated DID document and checked it appears there. resolveViaDns :: HasCallStack => Handle -> IO (Maybe Did)@@ -94,14 +103,17 @@         DNS.lookupTXT resolver ("_atproto." <> Text.encodeUtf8 rawHandle)       case results of         Right [Text.decodeASCII -> Text.stripPrefix "did=" -> Just rawDid] ->-          pure (Just (Did rawDid))+          either (error . show) (pure . Just) $ makeDid rawDid         Right [] -> pure Nothing         Left DNS.NameError -> pure Nothing         other -> error (show other)  -- | Returns 'Nothing' when the expected hostname reports 404 for the HTTP -- resolution endpoint. May raise an exception if either the handle has an--- invalid TLD or there's no HTTP server at the expected domain at all.+-- invalid TLD, the HTTP server doesn't return 200 or 404, or there's no HTTP+-- server at the expected domain at all. (This is probably a bit too strict, and+-- should ignore more HTTP errors, but I'll see based on my real-world+-- experience.) -- -- Note that this handle shouldn't be considered valid for this DID until you've -- looked up the associated DID document and checked it appears there.@@ -155,8 +167,8 @@     fromE (Right (Just dnsException, Just httpException)) =       Except.throwIO BothFailed{ dnsException, httpException } --- | '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.+-- | @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

@@ -0,0 +1,47 @@+module Did where++import Data.Text (Text)++import Bluesky.Did++testAccept :: Text -> IO ()+testAccept t = case makeDid t of+  Left err -> error $ "Did not accept " <> show t <> ": " <> show err+  Right _ -> pure ()++testReject :: DidError -> Text -> IO ()+testReject expectedErr t = case makeDid t of+  Left actualErr+    | expectedErr == actualErr -> pure ()+    | otherwise -> error $ "Wrong error for " <> show t <> ": " <> show actualErr+  Right _ -> error $ "Incorrectly accepted " <> show t++main :: IO ()+main = do+  -- examples from the docs+  mapM_ testAccept+    [ -- valid and usable+      "did:plc:z72i7hdynmk6r22z27h6tvur"+    , "did:web:blueskyweb.xyz"+    , -- syntactically valid but invalid method+      "did:method:val:two"+    , "did:m:v"+    , "did:method::::val"+    , "did:method:-:_:."+    , "did:key:zQ3shZc2QzApp2oymGvQbzP8eKheVshBHbU4ZYjeXqwSKEn6N"+    ]+  -- invalid syntax+  testReject BadMethod "did:METHOD:val"+  testReject BadMethod "did:m123:val"+  testReject NoDidPrefix "DID:method:val"+  testReject EndsWithColon "did:method:"+  testReject BadIdentifierCharacters "did:method:val/two"+  testReject BadIdentifierCharacters "did:method:val?two"+  testReject BadIdentifierCharacters "did:method:val#two"++  -- my own examples+  testAccept "did:method:A:b"+  -- percent encoding verification+  testAccept "did:plc:%ff"+  testAccept "did:plc:%F0"+  testReject BadPercentEncoding "did:plc:%FG"

@@ -18,6 +18,7 @@  main :: IO () main = do+  -- examples from the docs   mapM_ testAccept     [ "jay.bsky.social"     , "8.cn"

@@ -1,7 +1,9 @@ module Main (main) where +import qualified Did import qualified Handle  main :: IO () main = do+  Did.main   Handle.main