From a7db22556b91bc7c499e010b4c051f4442ad8ce2 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 29 Dec 2015 22:38:42 +0100
Subject: Using persona to validate emails

---
 src/server/Persona.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)
 create mode 100644 src/server/Persona.hs

(limited to 'src/server/Persona.hs')

diff --git a/src/server/Persona.hs b/src/server/Persona.hs
new file mode 100644
index 0000000..8055e8b
--- /dev/null
+++ b/src/server/Persona.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Persona
+  ( verifyEmail
+  ) where
+
+import Control.Monad (guard)
+
+import Network.HTTP.Conduit
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Aeson
+import Data.Aeson.Types (parseMaybe)
+
+import Config
+
+verifyEmail :: Config -> Text -> IO (Maybe Text)
+verifyEmail config assertion = do
+
+  initReq <- parseUrl "https://verifier.login.persona.org/verify"
+
+  let request =
+        (flip urlEncodedBody) initReq $
+          [ ("assertion", encodeUtf8 $ assertion)
+          , ("audience", encodeUtf8 $ hostname config)
+          ]
+
+  manager <- newManager tlsManagerSettings
+  response <- httpLbs request manager
+
+  return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
+
+parseEmail :: Text -> Maybe Text
+parseEmail payload = do
+  result <- decode . fromStrict . encodeUtf8 $ payload
+  flip parseMaybe result $ \obj -> do
+    status <- T.pack <$> obj .: "status"
+    guard (status == "okay")
+    obj .: "email"
-- 
cgit v1.2.3