From ae3fd8922969f37292007c6e9f9cb5b1a11e4acd Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 30 Dec 2015 00:43:01 +0100
Subject: Prevent from exception when calling persona assertion url

---
 src/server/Persona.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'src')

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
-- 
cgit v1.2.3