packages feed

bluesky-tools (empty) → 0.2.0.0

raw patch · 7 files changed

+376/−0 lines, 7 filesdep +aesondep +basedep +bluesky-tools

Dependencies added: aeson, base, bluesky-tools, dns, http-api-data, http-client, http-types, text, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Revision history for bluesky-tools++## 0.2.0.0 -- 2024-01-05++* Handle type, smart constructor, and tests.+* Resolving handles to DIDs via DNS and HTTP.+* Retrieving DID documents for did:plc: DIDs, and verifying handles against them.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Ben Millwood+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ bluesky-tools.cabal view
@@ -0,0 +1,66 @@+cabal-version:      3.4++name:               bluesky-tools+version:            0.2.0.0+synopsis:           Tools for interacting with Bluesky / AT Protocol+description:+  bluesky-tools provides tools that I've found useful while trying to integrate+  my applications with the Bluesky social network (https://bsky.social).+  Some or most of the tools are more correctly AT protocol tools, rather than+  specific to Bluesky, but I have not made that distinction in the docs.++license:            BSD-3-Clause+license-file:       LICENSE+author:             Ben Millwood+maintainer:         thebenmachine+git@gmail.com+copyright:          2025 Ben Millwood+category:           Web+build-type:         Simple+extra-doc-files:    CHANGELOG.md+-- extra-source-files:++source-repository head+  type: git+  location: https://github.com/bmillwood/bluesky-tools++common language+  default-language: GHC2021+  default-extensions:+    DeriveAnyClass+    DerivingStrategies+    OverloadedStrings+    ViewPatterns++common warnings+  ghc-options: -Wall++library+  import: language+  import: warnings+  hs-source-dirs: src+  exposed-modules:+    Bluesky.Did+    Bluesky.Handle+  -- other-modules:+  build-depends:+    aeson ^>=2.1,+    base ^>=4.18,+    dns ^>=4.2,+    http-api-data ^>=0.6,+    http-client ^>=0.7,+    http-types ^>=0.12,+    text ^>=2.0,+    transformers ^>=0.6,++test-suite bluesky-tools-test+  import: language+  import: warnings+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    Handle+  build-depends:+    base ^>=4.18,+    bluesky-tools,+    text ^>=2.0,
+ src/Bluesky/Did.hs view
@@ -0,0 +1,62 @@+module Bluesky.Did+  ( Did(Did), rawDid+  , Document(Document, alsoKnownAs)+  , getDocument+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Text as Text+import Data.Text (Text)+import GHC.Generics+import GHC.Stack++import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Status as HTTP++-- | 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.+--+-- Currently we do not implement DID validation.+newtype Did = Did { rawDid :: Text }+  deriving stock (Eq, Ord, Show)+  deriving newtype (Aeson.FromJSON)++-- | 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.+data Method+  = Web -- ^ https://w3c-ccg.github.io/did-method-web/+  | Plc -- ^ https://github.com/did-method-plc/did-method-plc+  deriving stock (Eq, Ord, Show)++method :: Did -> Maybe Method+method Did{ rawDid }+  | "did:web:" `Text.isPrefixOf` rawDid = Just Web+  | "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 Document = Document+  { id :: Did+  , alsoKnownAs :: [Text]+  } deriving stock (Eq, Ord, Show, Generic)+    deriving anyclass (Aeson.FromJSON)++-- | 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+    Nothing -> error "Unknown DID method"+    Just Web -> error "Support for did:web: is not yet implemented"+    Just Plc -> do+      req <-+        HTTP.parseRequest+          ("https://plc.directory/" <> Text.unpack rawDid)+      resp <- HTTP.httpLbs req httpManager+      case HTTP.statusCode (HTTP.responseStatus resp) of+        404 -> pure Nothing+        200 -> either fail (pure . Just) $ Aeson.eitherDecode $ HTTP.responseBody resp+        other -> fail $ "Unexpected HTTP status " <> show other
+ src/Bluesky/Handle.hs view
@@ -0,0 +1,165 @@+module Bluesky.Handle+  ( Handle, rawHandle, makeHandle, HandleError(..), validTld+  , resolveViaDns, resolveViaHttp, resolveViaBoth, resolveVerify+  ) where++import qualified Control.Concurrent.Async as Async+import qualified Control.Exception as Except+import Control.Monad+import Control.Monad.Trans.Maybe+import qualified Data.Aeson as Aeson+import Data.Aeson ((.:))+import qualified Data.Aeson.Types as Aeson+import qualified Data.Bifunctor as Bifunctor+import Data.Char+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Text (Text)+import GHC.Stack (HasCallStack)++import qualified Network.DNS as DNS+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Status as HTTP+import Web.HttpApiData (FromHttpApiData (parseUrlPiece))++import Bluesky.Did++-- | https://atproto.com/specs/handle+newtype Handle = Handle { rawHandle :: Text }+  deriving stock (Eq, Ord, Show)++data HandleError+  = TooLong+  | BadCharacters+  | EmptySegment+  | SegmentTooLong+  | SegmentStartsWithHyphen+  | SegmentEndsWithHyphen+  | OnlyOneSegment+  | LastSegmentStartsWithNumber+  deriving stock (Eq, Ord, Show)++makeHandle :: Text -> Either HandleError Handle+makeHandle t+  | Text.length t > 253 = Left TooLong+  | otherwise = checkParts True t+  where+    checkParts firstCheck remaining = case Text.breakOn "." remaining of+      (before, after)+        | Text.null before -> Left EmptySegment+        | Text.length before > 63 -> Left SegmentTooLong+        | Text.any (not . segmentChar) before -> Left BadCharacters+        | Text.take 1 before == "-" -> Left SegmentStartsWithHyphen+        | Text.takeEnd 1 before == "-" -> Left SegmentEndsWithHyphen+        | Text.null after ->+          if firstCheck+          then Left OnlyOneSegment+          else if Text.all isNumber (Text.take 1 before)+          then Left LastSegmentStartsWithNumber+          else Right (Handle (Text.toLower t))+        | otherwise -> checkParts False (Text.drop 1 after)+    segmentChar c = isAscii c && isAlphaNum c || c == '-'++-- | See "Additonal Non-Syntax Restrictions" in the spec+validTld :: Handle -> Bool+validTld (Handle h) =+  all (\tld -> not (tld `Text.isSuffixOf` h))+    [ ".alt"+    , ".arpa"+    , ".example"+    , ".internal"+    , ".invalid"+    , ".local"+    , ".localhost"+    , ".onion"+    ]++instance FromHttpApiData Handle where+  parseUrlPiece = Bifunctor.first (Text.pack . show) . 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.+--+-- 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)+resolveViaDns handle@(Handle rawHandle)+  | not (validTld handle) = error "handle has invalid TLD"+  | otherwise = do+      -- should we share rs / the resolver between calls?+      rs <- DNS.makeResolvSeed DNS.defaultResolvConf+      results <- DNS.withResolver rs $ \resolver ->+        DNS.lookupTXT resolver ("_atproto." <> Text.encodeUtf8 rawHandle)+      case results of+        Right [Text.decodeASCII -> Text.stripPrefix "did=" -> Just rawDid] ->+          pure (Just (Did 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.+--+-- 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.+resolveViaHttp :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did)+resolveViaHttp httpManager handle@(Handle rawHandle)+  | not (validTld handle) = error "handle has invalid TLD"+  | otherwise = do+      let rawHandleString = Text.unpack rawHandle+      req <-+        HTTP.parseRequest+          -- This could be a bad thing to do if the handle was arbitrary user+          -- data. But we validated it on the way in.+          -- (It still might be better to construct the URL in some structured way+          -- that insists the handle can only go in the hostname portion. But this+          -- will do.)+          ("https://" <> rawHandleString <> "/xrpc/com.atproto.identity.resolveHandle?handle=" <> rawHandleString)+      resp <- HTTP.httpLbs req httpManager+      case HTTP.statusCode (HTTP.responseStatus resp) of+        404 -> pure Nothing+        200 -> case Aeson.decode (HTTP.responseBody resp) of+          Nothing -> fail "JSON parsing failed"+          Just o -> either fail (pure . Just) $ Aeson.parseEither (.: "did") o+        other -> fail $ "Unexpected HTTP status " <> show other++-- | Raised by 'resolveViaBoth' when both methods raise exceptions.+data BothFailed = BothFailed+  { dnsException :: Except.SomeException+  , httpException :: Except.SomeException+  } deriving stock (Show)+    deriving anyclass (Except.Exception)++-- | If either 'resolveViaDns' or 'resolveViaHttp' return a 'Did', return that+-- 'Did'. Otherwise, if one or both of them raised an exception, reraise it (or+-- them, via 'BothFailed'). (Otherwise, return 'Nothing').+resolveViaBoth :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did)+resolveViaBoth httpManager handle =+  fromE =<< Async.concurrentlyE+    (toE $ resolveViaDns handle)+    (toE $ resolveViaHttp httpManager handle)+  where+    toE act = do+      r <- Except.try act+      case r of+        Right (Just did) -> pure (Left did)+        Right Nothing -> pure (Right Nothing)+        Left err -> pure (Right (Just err))+    fromE (Left r) = pure (Just r)+    fromE (Right (Nothing, Nothing)) = pure Nothing+    fromE (Right (Just e, Nothing)) = Except.throwIO e+    fromE (Right (Nothing, Just e)) = Except.throwIO e+    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.+resolveVerify :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did)+resolveVerify httpManager handle@(Handle rawHandle) = 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
+ test/Handle.hs view
@@ -0,0 +1,40 @@+module Handle where++import Data.Text (Text)++import Bluesky.Handle++testAccept :: Text -> IO ()+testAccept t = case makeHandle t of+  Left err -> error $ "Did not accept " <> show t <> ": " <> show err+  Right _ -> pure ()++testReject :: HandleError -> Text -> IO ()+testReject expectedErr t = case makeHandle 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+  mapM_ testAccept+    [ "jay.bsky.social"+    , "8.cn"+    , "name.t--t"+    , "XX.LCS.MIT.EDU"+    , "a.co"+    , "xn--notarealidn.com"+    , "xn--fiqa61au8b7zsevnm8ak20mc4a87e.xn--fiqs8s"+    , "xn--ls8h.test"+    , "example.t"+    ]+  testReject BadCharacters "jo@hn.test"+  testReject BadCharacters "💩.test"+  testReject EmptySegment "john..test"+  testReject SegmentEndsWithHyphen "xn--bcher-.tld"+  testReject LastSegmentStartsWithNumber "john.0"+  testReject LastSegmentStartsWithNumber "cn.8"+  testReject BadCharacters "www.masełkowski.pl.com"+  testReject OnlyOneSegment "org"+  testReject EmptySegment "name.org."
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import qualified Handle++main :: IO ()+main = do+  Handle.main