aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Persona.hs7
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