Prevent from exception when calling persona assertion url

1 files changed, 5 insertions, 2 deletions

diff --git a/src/server/Persona.hs b/src/server/Persona.hs
index 8055e8b..267ee3b 100644
--- a/src/server/Persona.hs
+++ b/src/server/Persona.hs
@@ -7,6 +7,7 @@ module Persona
 import Control.Monad (guard)
 
 import Network.HTTP.Conduit
+import Network.HTTP.Types.Status (ok200)
 
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -23,7 +24,7 @@ verifyEmail config assertion = do
   initReq <- parseUrl "https://verifier.login.persona.org/verify"
 
   let request =
-        (flip urlEncodedBody) initReq $
+        (flip urlEncodedBody) (initReq { checkStatus = \_ _ _ -> Nothing }) $
           [ ("assertion", encodeUtf8 $ assertion)
           , ("audience", encodeUtf8 $ hostname config)
           ]
@@ -31,7 +32,9 @@ verifyEmail config assertion = do
   manager <- newManager tlsManagerSettings
   response <- httpLbs request manager
 
-  return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
+  if responseStatus response == ok200
+    then return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
+    else return Nothing
 
 parseEmail :: Text -> Maybe Text
 parseEmail payload = do