1 files changed, 42 insertions, 0 deletions
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"