From 7c2fad741711e64fd15a8a8a0b4c949fcae54348 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Tue, 16 Apr 2019 16:10:17 +0000
Subject: [PATCH] Implement fetchAPIDOrH using a dedicated error type

---
 src/Web/ActivityPub.hs | 39 ++++++++++++++++++++++++++++-----------
 1 file changed, 28 insertions(+), 11 deletions(-)

diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 834e52e..0160be1 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -709,6 +709,33 @@ fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
     showError Nothing  = "Object @id doesn't match the URI we fetched"
     showError (Just e) = displayException e
 
+data FetchAPError
+    = FetchAPErrorGet APGetError
+    -- Object @id doesn't match the URI we fetched
+    | FetchAPErrorIdMismatch
+    -- Object @id URI's host doesn't match the URI we fetched
+    | FetchAPErrorHostMismatch
+    deriving Show
+
+fetchAPIDOrH'
+    :: (MonadIO m, ActivityPub a, ActivityPub b)
+    => Manager
+    -> (a -> LocalURI)
+    -> Text
+    -> LocalURI
+    -> ExceptT FetchAPError m (Either a b)
+fetchAPIDOrH' m getId h lu = do
+    e <- withExceptT FetchAPErrorGet $ fetchAP' m $ l2f h lu
+    case e of
+        Left' (Doc h' x) ->
+            if h == h' && getId x == lu
+                then return $ Left x
+                else throwE FetchAPErrorIdMismatch
+        Right' (Doc h' y) ->
+            if h == h'
+                then return $ Right y
+                else throwE FetchAPErrorHostMismatch
+
 fetchAPIDOrH
     :: (MonadIO m, ActivityPub a, ActivityPub b)
     => Manager
@@ -716,17 +743,7 @@ fetchAPIDOrH
     -> Text
     -> LocalURI
     -> ExceptT String m (Either a b)
-fetchAPIDOrH m getId h lu = do
-    e <- fetchAP m $ l2f h lu
-    case e of
-        Left' (Doc h' x) ->
-            if h == h' && getId x == lu
-                then return $ Left x
-                else throwE "Object @id doesn't match the URI we fetched"
-        Right' (Doc h' y) ->
-            if h == h'
-                then return $ Right y
-                else throwE "Object @id URI's host doesn't match the URI we fetched"
+fetchAPIDOrH m getId h lu = withExceptT show $ fetchAPIDOrH' m getId h lu
 
 -- | Fetches the given actor and checks whether it lists the given key (as a
 -- URI, not as an embedded object). If it does, returns 'Right' the fetched