datarekisteri/Client/Auth.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Client.Auth where

import Relude

import Server.Types
import Data.Morpheus.Client
import Yesod
import Yesod.Auth
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Yesod.Auth.Message as Msg

pluginName = "externalBasic"

loginR = PluginR pluginName ["login"]

type Authorization = Text
type CredsIdent = Text

postLoginR :: YesodAuth master =>
    (Authorization -> HandlerFor master (Maybe CredsIdent)) -> AuthHandler master TypedContent
postLoginR authReq = do
    res <- runInputPostResult $ (\x y -> x <> ":" <> y)
        <$> ireq textField "email" <*> ireq textField "password"
    case res of
      FormSuccess auth -> do
          maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ B64.encodeBase64 $ encodeUtf8 auth
          case maybeAuth of
            Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided -- invalid creds
            Just txt -> do
                setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
      _ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided

authExternalBasic :: forall site. YesodAuth site =>
    (Authorization -> HandlerFor site (Maybe CredsIdent)) -> AuthPlugin site
authExternalBasic authReq = AuthPlugin pluginName dispatch loginForm
    where dispatch :: YesodAuth site => Text -> [Text] -> AuthHandler site TypedContent
          dispatch "POST" ["login"] = postLoginR authReq >>= sendResponse
          dispatch _ _ = notFound

loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
loginForm toParent = do
    emailId <- newIdent
    passwordId <- newIdent
    [whamlet|
<h1>Kirjaudu
<form action=@{toParent loginR} method=post>
    <label for="#{emailId}">
        Sähköposti
    <input id="#{emailId}" name="email" type="text" autofocus>
    <label for="#{passwordId}">
        Salasana
    <input id="#{passwordId}" name="password" type="password">
    <input type="submit" value="Kirjaudu">
|]