module Bluesky.Handle
  ( Handle, rawHandle, makeHandle, HandleError(..), validTld
  , resolveViaDns, resolveViaHttp, resolveViaBoth, BothFailed(..)
  , verifyHandle, resolveVerify
  ) where

import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as Except
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import qualified Data.Aeson as Aeson
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteString.Lazy as BSL
import Data.Char
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
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 { Handle -> Text
rawHandle :: Text }
  deriving stock (Handle -> Handle -> Bool
(Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool) -> Eq Handle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Handle -> Handle -> Bool
== :: Handle -> Handle -> Bool
$c/= :: Handle -> Handle -> Bool
/= :: Handle -> Handle -> Bool
Eq, Eq Handle
Eq Handle =>
(Handle -> Handle -> Ordering)
-> (Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool)
-> (Handle -> Handle -> Handle)
-> (Handle -> Handle -> Handle)
-> Ord Handle
Handle -> Handle -> Bool
Handle -> Handle -> Ordering
Handle -> Handle -> Handle
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Handle -> Handle -> Ordering
compare :: Handle -> Handle -> Ordering
$c< :: Handle -> Handle -> Bool
< :: Handle -> Handle -> Bool
$c<= :: Handle -> Handle -> Bool
<= :: Handle -> Handle -> Bool
$c> :: Handle -> Handle -> Bool
> :: Handle -> Handle -> Bool
$c>= :: Handle -> Handle -> Bool
>= :: Handle -> Handle -> Bool
$cmax :: Handle -> Handle -> Handle
max :: Handle -> Handle -> Handle
$cmin :: Handle -> Handle -> Handle
min :: Handle -> Handle -> Handle
Ord, Int -> Handle -> ShowS
[Handle] -> ShowS
Handle -> String
(Int -> Handle -> ShowS)
-> (Handle -> String) -> ([Handle] -> ShowS) -> Show Handle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Handle -> ShowS
showsPrec :: Int -> Handle -> ShowS
$cshow :: Handle -> String
show :: Handle -> String
$cshowList :: [Handle] -> ShowS
showList :: [Handle] -> ShowS
Show, (forall x. Handle -> Rep Handle x)
-> (forall x. Rep Handle x -> Handle) -> Generic Handle
forall x. Rep Handle x -> Handle
forall x. Handle -> Rep Handle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Handle -> Rep Handle x
from :: forall x. Handle -> Rep Handle x
$cto :: forall x. Rep Handle x -> Handle
to :: forall x. Rep Handle x -> Handle
Generic)
  deriving newtype ([Handle] -> Value
[Handle] -> Encoding
Handle -> Bool
Handle -> Value
Handle -> Encoding
(Handle -> Value)
-> (Handle -> Encoding)
-> ([Handle] -> Value)
-> ([Handle] -> Encoding)
-> (Handle -> Bool)
-> ToJSON Handle
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Handle -> Value
toJSON :: Handle -> Value
$ctoEncoding :: Handle -> Encoding
toEncoding :: Handle -> Encoding
$ctoJSONList :: [Handle] -> Value
toJSONList :: [Handle] -> Value
$ctoEncodingList :: [Handle] -> Encoding
toEncodingList :: [Handle] -> Encoding
$comitField :: Handle -> Bool
omitField :: Handle -> Bool
Aeson.ToJSON)

data HandleError
  = TooLong
  | BadCharacters
  | EmptySegment
  | SegmentTooLong
  | SegmentStartsWithHyphen
  | SegmentEndsWithHyphen
  | OnlyOneSegment
  | LastSegmentStartsWithNumber
  deriving stock (HandleError -> HandleError -> Bool
(HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> Bool) -> Eq HandleError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HandleError -> HandleError -> Bool
== :: HandleError -> HandleError -> Bool
$c/= :: HandleError -> HandleError -> Bool
/= :: HandleError -> HandleError -> Bool
Eq, Eq HandleError
Eq HandleError =>
(HandleError -> HandleError -> Ordering)
-> (HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> HandleError)
-> (HandleError -> HandleError -> HandleError)
-> Ord HandleError
HandleError -> HandleError -> Bool
HandleError -> HandleError -> Ordering
HandleError -> HandleError -> HandleError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HandleError -> HandleError -> Ordering
compare :: HandleError -> HandleError -> Ordering
$c< :: HandleError -> HandleError -> Bool
< :: HandleError -> HandleError -> Bool
$c<= :: HandleError -> HandleError -> Bool
<= :: HandleError -> HandleError -> Bool
$c> :: HandleError -> HandleError -> Bool
> :: HandleError -> HandleError -> Bool
$c>= :: HandleError -> HandleError -> Bool
>= :: HandleError -> HandleError -> Bool
$cmax :: HandleError -> HandleError -> HandleError
max :: HandleError -> HandleError -> HandleError
$cmin :: HandleError -> HandleError -> HandleError
min :: HandleError -> HandleError -> HandleError
Ord, Int -> HandleError -> ShowS
[HandleError] -> ShowS
HandleError -> String
(Int -> HandleError -> ShowS)
-> (HandleError -> String)
-> ([HandleError] -> ShowS)
-> Show HandleError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandleError -> ShowS
showsPrec :: Int -> HandleError -> ShowS
$cshow :: HandleError -> String
show :: HandleError -> String
$cshowList :: [HandleError] -> ShowS
showList :: [HandleError] -> ShowS
Show)

makeHandle :: Text -> Either HandleError Handle
makeHandle :: Text -> Either HandleError Handle
makeHandle Text
t
  | Text -> Int
Text.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
253 = HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
TooLong
  | Bool
otherwise = Bool -> Text -> Either HandleError Handle
checkParts Bool
True Text
t
  where
    checkParts :: Bool -> Text -> Either HandleError Handle
checkParts Bool
firstCheck Text
remaining = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
"." Text
remaining of
      (Text
before, Text
after)
        | Text -> Bool
Text.null Text
before -> HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
EmptySegment
        | Text -> Int
Text.length Text
before Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
63 -> HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
SegmentTooLong
        | (Char -> Bool) -> Text -> Bool
Text.any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
segmentChar) Text
before -> HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
BadCharacters
        | Int -> Text -> Text
Text.take Int
1 Text
before Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-" -> HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
SegmentStartsWithHyphen
        | Int -> Text -> Text
Text.takeEnd Int
1 Text
before Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-" -> HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
SegmentEndsWithHyphen
        | Text -> Bool
Text.null Text
after ->
          if Bool
firstCheck
          then HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
OnlyOneSegment
          else if (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isNumber (Int -> Text -> Text
Text.take Int
1 Text
before)
          then HandleError -> Either HandleError Handle
forall a b. a -> Either a b
Left HandleError
LastSegmentStartsWithNumber
          else Handle -> Either HandleError Handle
forall a b. b -> Either a b
Right (Text -> Handle
Handle (Text -> Text
Text.toLower Text
t))
        | Bool
otherwise -> Bool -> Text -> Either HandleError Handle
checkParts Bool
False (Int -> Text -> Text
Text.drop Int
1 Text
after)
    segmentChar :: Char -> Bool
segmentChar Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

-- | See "Additonal Non-Syntax Restrictions" in the spec
validTld :: Handle -> Bool
validTld :: Handle -> Bool
validTld (Handle Text
h) =
  (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Text
tld -> Bool -> Bool
not (Text
tld Text -> Text -> Bool
`Text.isSuffixOf` Text
h))
    [ Text
".alt"
    , Text
".arpa"
    , Text
".example"
    , Text
".internal"
    , Text
".invalid"
    , Text
".local"
    , Text
".localhost"
    , Text
".onion"
    ]

instance FromHttpApiData Handle where
  parseUrlPiece :: Text -> Either Text Handle
parseUrlPiece = (HandleError -> Text)
-> Either HandleError Handle -> Either Text Handle
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first (String -> Text
Text.pack (String -> Text) -> (HandleError -> String) -> HandleError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleError -> String
forall a. Show a => a -> String
show) (Either HandleError Handle -> Either Text Handle)
-> (Text -> Either HandleError Handle)
-> Text
-> Either Text Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HandleError Handle
makeHandle

instance Aeson.FromJSON Handle where
  parseJSON :: Value -> Parser Handle
parseJSON =
    String -> (Text -> Parser Handle) -> Value -> Parser Handle
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Bluesky.Handle.Handle" ((Text -> Parser Handle) -> Value -> Parser Handle)
-> (Text -> Parser Handle) -> Value -> Parser Handle
forall a b. (a -> b) -> a -> b
$ (HandleError -> Parser Handle)
-> (Handle -> Parser Handle)
-> Either HandleError Handle
-> Parser Handle
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Handle
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Handle)
-> (HandleError -> String) -> HandleError -> Parser Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleError -> String
forall a. Show a => a -> String
show) Handle -> Parser Handle
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HandleError Handle -> Parser Handle)
-> (Text -> Either HandleError Handle) -> Text -> Parser Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HandleError Handle
makeHandle

-- | Returns 'Nothing' in ordinary cases where this handle can't be resolved by
-- 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)
resolveViaDns :: HasCallStack => Handle -> IO (Maybe Did)
resolveViaDns handle :: Handle
handle@(Handle Text
rawHandle)
  | Bool -> Bool
not (Handle -> Bool
validTld Handle
handle) = String -> IO (Maybe Did)
forall a. HasCallStack => String -> a
error String
"handle has invalid TLD"
  | Bool
otherwise = do
      -- should we share rs / the resolver between calls?
      ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
DNS.defaultResolvConf
      Either DNSError [ByteString]
results <- ResolvSeed
-> (Resolver -> IO (Either DNSError [ByteString]))
-> IO (Either DNSError [ByteString])
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs ((Resolver -> IO (Either DNSError [ByteString]))
 -> IO (Either DNSError [ByteString]))
-> (Resolver -> IO (Either DNSError [ByteString]))
-> IO (Either DNSError [ByteString])
forall a b. (a -> b) -> a -> b
$ \Resolver
resolver ->
        Resolver -> ByteString -> IO (Either DNSError [ByteString])
DNS.lookupTXT Resolver
resolver (ByteString
"_atproto." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
Text.encodeUtf8 Text
rawHandle)
      case Either DNSError [ByteString]
results of
        Right [ByteString -> Text
Text.decodeASCII -> Text -> Text -> Maybe Text
Text.stripPrefix Text
"did=" -> Just Text
rawDid] ->
          (DidError -> IO (Maybe Did))
-> (Did -> IO (Maybe Did)) -> Either DidError Did -> IO (Maybe Did)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Maybe Did)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe Did))
-> (DidError -> String) -> DidError -> IO (Maybe Did)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DidError -> String
forall a. Show a => a -> String
show) (Maybe Did -> IO (Maybe Did)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Did -> IO (Maybe Did))
-> (Did -> Maybe Did) -> Did -> IO (Maybe Did)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Did -> Maybe Did
forall a. a -> Maybe a
Just) (Either DidError Did -> IO (Maybe Did))
-> Either DidError Did -> IO (Maybe Did)
forall a b. (a -> b) -> a -> b
$ Text -> Either DidError Did
makeDid Text
rawDid
        Right [] -> Maybe Did -> IO (Maybe Did)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Did
forall a. Maybe a
Nothing
        Left DNSError
DNS.NameError -> Maybe Did -> IO (Maybe Did)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Did
forall a. Maybe a
Nothing
        Either DNSError [ByteString]
other -> String -> IO (Maybe Did)
forall a. HasCallStack => String -> a
error (Either DNSError [ByteString] -> String
forall a. Show a => a -> String
show Either DNSError [ByteString]
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, 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.
resolveViaHttp :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did)
resolveViaHttp :: HasCallStack => Manager -> Handle -> IO (Maybe Did)
resolveViaHttp Manager
httpManager handle :: Handle
handle@(Handle Text
rawHandle)
  | Bool -> Bool
not (Handle -> Bool
validTld Handle
handle) = String -> IO (Maybe Did)
forall a. HasCallStack => String -> a
error String
"handle has invalid TLD"
  | Bool
otherwise = do
      let rawHandleString :: String
rawHandleString = Text -> String
Text.unpack Text
rawHandle
      Request
req <-
        String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
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.)
          (String
"https://" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rawHandleString String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/.well-known/atproto-did")
      Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
      case Status -> Int
HTTP.statusCode (Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
resp) of
        Int
404 -> Maybe Did -> IO (Maybe Did)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Did
forall a. Maybe a
Nothing
        Int
200 ->
          (DidError -> IO (Maybe Did))
-> (Did -> IO (Maybe Did)) -> Either DidError Did -> IO (Maybe Did)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Maybe Did)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe Did))
-> (DidError -> String) -> DidError -> IO (Maybe Did)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DidError -> String
forall a. Show a => a -> String
show) (Maybe Did -> IO (Maybe Did)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Did -> IO (Maybe Did))
-> (Did -> Maybe Did) -> Did -> IO (Maybe Did)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Did -> Maybe Did
forall a. a -> Maybe a
Just) (Either DidError Did -> IO (Maybe Did))
-> (ByteString -> Either DidError Did)
-> ByteString
-> IO (Maybe Did)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either DidError Did
makeDid
          (Text -> Either DidError Did)
-> (ByteString -> Text) -> ByteString -> Either DidError Did
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeASCII (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
          (ByteString -> IO (Maybe Did)) -> ByteString -> IO (Maybe Did)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
resp
        Int
other -> String -> IO (Maybe Did)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe Did)) -> String -> IO (Maybe Did)
forall a b. (a -> b) -> a -> b
$ String
"Unexpected HTTP status " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
other

-- | Raised by 'resolveViaBoth' when both methods raise exceptions.
data BothFailed = BothFailed
  { BothFailed -> SomeException
dnsException :: Except.SomeException
  , BothFailed -> SomeException
httpException :: Except.SomeException
  } deriving stock (Int -> BothFailed -> ShowS
[BothFailed] -> ShowS
BothFailed -> String
(Int -> BothFailed -> ShowS)
-> (BothFailed -> String)
-> ([BothFailed] -> ShowS)
-> Show BothFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BothFailed -> ShowS
showsPrec :: Int -> BothFailed -> ShowS
$cshow :: BothFailed -> String
show :: BothFailed -> String
$cshowList :: [BothFailed] -> ShowS
showList :: [BothFailed] -> ShowS
Show)
    deriving anyclass (Show BothFailed
Typeable BothFailed
(Typeable BothFailed, Show BothFailed) =>
(BothFailed -> SomeException)
-> (SomeException -> Maybe BothFailed)
-> (BothFailed -> String)
-> Exception BothFailed
SomeException -> Maybe BothFailed
BothFailed -> String
BothFailed -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: BothFailed -> SomeException
toException :: BothFailed -> SomeException
$cfromException :: SomeException -> Maybe BothFailed
fromException :: SomeException -> Maybe BothFailed
$cdisplayException :: BothFailed -> String
displayException :: BothFailed -> String
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 :: HasCallStack => Manager -> Handle -> IO (Maybe Did)
resolveViaBoth Manager
httpManager Handle
handle =
  Either Did (Maybe SomeException, Maybe SomeException)
-> IO (Maybe Did)
forall {a}.
Either a (Maybe SomeException, Maybe SomeException) -> IO (Maybe a)
fromE (Either Did (Maybe SomeException, Maybe SomeException)
 -> IO (Maybe Did))
-> IO (Either Did (Maybe SomeException, Maybe SomeException))
-> IO (Maybe Did)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Did (Maybe SomeException))
-> IO (Either Did (Maybe SomeException))
-> IO (Either Did (Maybe SomeException, Maybe SomeException))
forall e a b.
IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
Async.concurrentlyE
    (IO (Maybe Did) -> IO (Either Did (Maybe SomeException))
forall {a} {a}.
Exception a =>
IO (Maybe a) -> IO (Either a (Maybe a))
toE (IO (Maybe Did) -> IO (Either Did (Maybe SomeException)))
-> IO (Maybe Did) -> IO (Either Did (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ HasCallStack => Handle -> IO (Maybe Did)
Handle -> IO (Maybe Did)
resolveViaDns Handle
handle)
    (IO (Maybe Did) -> IO (Either Did (Maybe SomeException))
forall {a} {a}.
Exception a =>
IO (Maybe a) -> IO (Either a (Maybe a))
toE (IO (Maybe Did) -> IO (Either Did (Maybe SomeException)))
-> IO (Maybe Did) -> IO (Either Did (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ HasCallStack => Manager -> Handle -> IO (Maybe Did)
Manager -> Handle -> IO (Maybe Did)
resolveViaHttp Manager
httpManager Handle
handle)
  where
    toE :: IO (Maybe a) -> IO (Either a (Maybe a))
toE IO (Maybe a)
act = do
      Either a (Maybe a)
r <- IO (Maybe a) -> IO (Either a (Maybe a))
forall e a. Exception e => IO a -> IO (Either e a)
Except.try IO (Maybe a)
act
      case Either a (Maybe a)
r of
        Right (Just a
did) -> Either a (Maybe a) -> IO (Either a (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a (Maybe a)
forall a b. a -> Either a b
Left a
did)
        Right Maybe a
Nothing -> Either a (Maybe a) -> IO (Either a (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Either a (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing)
        Left a
err -> Either a (Maybe a) -> IO (Either a (Maybe a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Either a (Maybe a)
forall a b. b -> Either a b
Right (a -> Maybe a
forall a. a -> Maybe a
Just a
err))
    fromE :: Either a (Maybe SomeException, Maybe SomeException) -> IO (Maybe a)
fromE (Left a
r) = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
r)
    fromE (Right (Maybe SomeException
Nothing, Maybe SomeException
Nothing)) = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    fromE (Right (Just SomeException
e, Maybe SomeException
Nothing)) = SomeException -> IO (Maybe a)
forall e a. Exception e => e -> IO a
Except.throwIO SomeException
e
    fromE (Right (Maybe SomeException
Nothing, Just SomeException
e)) = SomeException -> IO (Maybe a)
forall e a. Exception e => e -> IO a
Except.throwIO SomeException
e
    fromE (Right (Just SomeException
dnsException, Just SomeException
httpException)) =
      BothFailed -> IO (Maybe a)
forall e a. Exception e => e -> IO a
Except.throwIO BothFailed{ SomeException
dnsException :: SomeException
dnsException :: SomeException
dnsException, SomeException
httpException :: SomeException
httpException :: SomeException
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.
-- 'Nothing' if the document can't be fetched.
verifyHandle :: HTTP.Manager -> Handle -> Did -> IO (Maybe Bool)
verifyHandle :: Manager -> Handle -> Did -> IO (Maybe Bool)
verifyHandle Manager
httpManager (Handle Text
rawHandle) Did
did = MaybeT IO Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Bool -> IO (Maybe Bool))
-> MaybeT IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ do
  Document
doc <- IO (Maybe Document) -> MaybeT IO Document
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Document) -> MaybeT IO Document)
-> IO (Maybe Document) -> MaybeT IO Document
forall a b. (a -> b) -> a -> b
$ HasCallStack => Manager -> Did -> IO (Maybe Document)
Manager -> Did -> IO (Maybe Document)
getDocument Manager
httpManager Did
did
  Bool -> MaybeT IO Bool
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> MaybeT IO Bool) -> Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ (Text
"at://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rawHandle) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Document -> [Text]
alsoKnownAs Document
doc

-- | Combines 'resolveViaBoth' and 'verifyHandle'. Raises an error if
-- verification fails.
resolveVerify :: HasCallStack => HTTP.Manager -> Handle -> IO (Maybe Did)
resolveVerify :: HasCallStack => Manager -> Handle -> IO (Maybe Did)
resolveVerify Manager
httpManager Handle
handle = MaybeT IO Did -> IO (Maybe Did)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Did -> IO (Maybe Did))
-> MaybeT IO Did -> IO (Maybe Did)
forall a b. (a -> b) -> a -> b
$ do
  Did
did <- IO (Maybe Did) -> MaybeT IO Did
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Did) -> MaybeT IO Did)
-> IO (Maybe Did) -> MaybeT IO Did
forall a b. (a -> b) -> a -> b
$ HasCallStack => Manager -> Handle -> IO (Maybe Did)
Manager -> Handle -> IO (Maybe Did)
resolveViaBoth Manager
httpManager Handle
handle
  Maybe Bool
verified <- IO (Maybe Bool) -> MaybeT IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Bool) -> MaybeT IO (Maybe Bool))
-> IO (Maybe Bool) -> MaybeT IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Manager -> Handle -> Did -> IO (Maybe Bool)
verifyHandle Manager
httpManager Handle
handle Did
did
  case Maybe Bool
verified of
    Maybe Bool
Nothing -> String -> MaybeT IO Did
forall a. HasCallStack => String -> a
error String
"Can't get DID document to verify handle"
    Just Bool
False -> String -> MaybeT IO Did
forall a. HasCallStack => String -> a
error String
"Handle failed verification: not in DID document"
    Just Bool
True -> Did -> MaybeT IO Did
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Did
did