{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell, TypeFamilies #-}
module Happstack.Authenticate.OpenId.Core where

import Control.Applicative         (Alternative)
import Control.Monad               (msum)
import Control.Lens                ((?=), (^.), (.=), makeLenses, view, at)
import Control.Monad.Trans         (MonadIO(liftIO))
import Data.Acid                   (AcidState, Query, Update, makeAcidic)
import Data.Acid.Advanced          (query', update')
import qualified Data.Aeson        as Aeson
import Data.Aeson                  (Object(..), Value(..), decode, encode)
import Data.Aeson.Types            (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)
import Data.Data                   (Data, Typeable)
import qualified Data.HashMap.Strict as HashMap
import Data.Map                    (Map)
import qualified Data.Map          as Map
import Data.Maybe                  (mapMaybe)
import Data.Monoid                 ((<>))
import Data.SafeCopy               (Migrate(..), SafeCopy, base, extension, deriveSafeCopy)
import qualified Data.Text               as T
import           Data.Text               (Text)
import qualified Data.Text.Encoding      as T
import qualified Data.Text.Lazy          as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Map          as Map
import Data.UserId                 (UserId)
import GHC.Generics                (Generic)
import Happstack.Authenticate.Core (AuthenticateConfig(..), AuthenticateState, CoreError(..), CreateAnonymousUser(..), GetUserByUserId(..), HappstackAuthenticateI18N(..), addTokenCookie, getToken, jsonOptions, toJSONError, toJSONSuccess, toJSONResponse, tokenIsAuthAdmin, userId)
import Happstack.Authenticate.OpenId.URL
import Happstack.Server            (RqBody(..), Happstack, Method(..), Response, askRq, unauthorized, badRequest, internalServerError, forbidden, lookPairsBS, method, resp, takeRequestBody, toResponse, toResponseBS, ok)
import Language.Javascript.JMacro
import Network.HTTP.Conduit        (newManager, tlsManagerSettings)
import Text.Shakespeare.I18N       (RenderMessage(..), Lang, mkMessageFor)
import Web.Authenticate.OpenId     (Identifier)
import Web.Authenticate.OpenId     (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl)

{-

The OpenId authentication scheme works as follows:

 - the user tells us which OpenId provider they want to use
 - we call 'getForwardUrl' to construct a url for that provider
 - the user is redirected to that 'url' -- typically a 3rd party site
 - the user interacts with site to confirm the login
 - that site redirects the user back to a url at our site with some 'claims' in the query string
 - we then talk to the user's OpenId server and verify those claims
 - we know have a verified OpenId identifier for the user

-}

$(deriveSafeCopy 1 'base ''Identifier)

------------------------------------------------------------------------------
-- OpenIdError
------------------------------------------------------------------------------

data OpenIdError
  = UnknownIdentifier
  | CoreError { OpenIdError -> CoreError
openIdErrorMessageE :: CoreError }
  deriving (OpenIdError -> OpenIdError -> Bool
(OpenIdError -> OpenIdError -> Bool)
-> (OpenIdError -> OpenIdError -> Bool) -> Eq OpenIdError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpenIdError -> OpenIdError -> Bool
$c/= :: OpenIdError -> OpenIdError -> Bool
== :: OpenIdError -> OpenIdError -> Bool
$c== :: OpenIdError -> OpenIdError -> Bool
Eq, Eq OpenIdError
Eq OpenIdError
-> (OpenIdError -> OpenIdError -> Ordering)
-> (OpenIdError -> OpenIdError -> Bool)
-> (OpenIdError -> OpenIdError -> Bool)
-> (OpenIdError -> OpenIdError -> Bool)
-> (OpenIdError -> OpenIdError -> Bool)
-> (OpenIdError -> OpenIdError -> OpenIdError)
-> (OpenIdError -> OpenIdError -> OpenIdError)
-> Ord OpenIdError
OpenIdError -> OpenIdError -> Bool
OpenIdError -> OpenIdError -> Ordering
OpenIdError -> OpenIdError -> OpenIdError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OpenIdError -> OpenIdError -> OpenIdError
$cmin :: OpenIdError -> OpenIdError -> OpenIdError
max :: OpenIdError -> OpenIdError -> OpenIdError
$cmax :: OpenIdError -> OpenIdError -> OpenIdError
>= :: OpenIdError -> OpenIdError -> Bool
$c>= :: OpenIdError -> OpenIdError -> Bool
> :: OpenIdError -> OpenIdError -> Bool
$c> :: OpenIdError -> OpenIdError -> Bool
<= :: OpenIdError -> OpenIdError -> Bool
$c<= :: OpenIdError -> OpenIdError -> Bool
< :: OpenIdError -> OpenIdError -> Bool
$c< :: OpenIdError -> OpenIdError -> Bool
compare :: OpenIdError -> OpenIdError -> Ordering
$ccompare :: OpenIdError -> OpenIdError -> Ordering
$cp1Ord :: Eq OpenIdError
Ord, ReadPrec [OpenIdError]
ReadPrec OpenIdError
Int -> ReadS OpenIdError
ReadS [OpenIdError]
(Int -> ReadS OpenIdError)
-> ReadS [OpenIdError]
-> ReadPrec OpenIdError
-> ReadPrec [OpenIdError]
-> Read OpenIdError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OpenIdError]
$creadListPrec :: ReadPrec [OpenIdError]
readPrec :: ReadPrec OpenIdError
$creadPrec :: ReadPrec OpenIdError
readList :: ReadS [OpenIdError]
$creadList :: ReadS [OpenIdError]
readsPrec :: Int -> ReadS OpenIdError
$creadsPrec :: Int -> ReadS OpenIdError
Read, Int -> OpenIdError -> ShowS
[OpenIdError] -> ShowS
OpenIdError -> String
(Int -> OpenIdError -> ShowS)
-> (OpenIdError -> String)
-> ([OpenIdError] -> ShowS)
-> Show OpenIdError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenIdError] -> ShowS
$cshowList :: [OpenIdError] -> ShowS
show :: OpenIdError -> String
$cshow :: OpenIdError -> String
showsPrec :: Int -> OpenIdError -> ShowS
$cshowsPrec :: Int -> OpenIdError -> ShowS
Show, Typeable OpenIdError
DataType
Constr
Typeable OpenIdError
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> OpenIdError -> c OpenIdError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c OpenIdError)
-> (OpenIdError -> Constr)
-> (OpenIdError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c OpenIdError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c OpenIdError))
-> ((forall b. Data b => b -> b) -> OpenIdError -> OpenIdError)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdError -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdError -> r)
-> (forall u. (forall d. Data d => d -> u) -> OpenIdError -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> OpenIdError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError)
-> Data OpenIdError
OpenIdError -> DataType
OpenIdError -> Constr
(forall b. Data b => b -> b) -> OpenIdError -> OpenIdError
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdError -> c OpenIdError
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdError
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OpenIdError -> u
forall u. (forall d. Data d => d -> u) -> OpenIdError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdError -> c OpenIdError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdError)
$cCoreError :: Constr
$cUnknownIdentifier :: Constr
$tOpenIdError :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
gmapMp :: (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
gmapM :: (forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdError -> m OpenIdError
gmapQi :: Int -> (forall d. Data d => d -> u) -> OpenIdError -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenIdError -> u
gmapQ :: (forall d. Data d => d -> u) -> OpenIdError -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OpenIdError -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdError -> r
gmapT :: (forall b. Data b => b -> b) -> OpenIdError -> OpenIdError
$cgmapT :: (forall b. Data b => b -> b) -> OpenIdError -> OpenIdError
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdError)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c OpenIdError)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdError)
dataTypeOf :: OpenIdError -> DataType
$cdataTypeOf :: OpenIdError -> DataType
toConstr :: OpenIdError -> Constr
$ctoConstr :: OpenIdError -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdError
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdError -> c OpenIdError
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdError -> c OpenIdError
$cp1Data :: Typeable OpenIdError
Data, Typeable, (forall x. OpenIdError -> Rep OpenIdError x)
-> (forall x. Rep OpenIdError x -> OpenIdError)
-> Generic OpenIdError
forall x. Rep OpenIdError x -> OpenIdError
forall x. OpenIdError -> Rep OpenIdError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpenIdError x -> OpenIdError
$cfrom :: forall x. OpenIdError -> Rep OpenIdError x
Generic)
instance ToJSON   OpenIdError where toJSON :: OpenIdError -> Value
toJSON    = Options -> OpenIdError -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON OpenIdError where parseJSON :: Value -> Parser OpenIdError
parseJSON = Options -> Value -> Parser OpenIdError
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

instance ToJExpr OpenIdError where
    toJExpr :: OpenIdError -> JExpr
toJExpr = Value -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Value -> JExpr) -> (OpenIdError -> Value) -> OpenIdError -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenIdError -> Value
forall a. ToJSON a => a -> Value
toJSON

mkMessageFor "HappstackAuthenticateI18N" "OpenIdError" "messages/openid/error" ("en")

------------------------------------------------------------------------------
-- OpenIdState
------------------------------------------------------------------------------

data OpenIdState_1 = OpenIdState_1
    { OpenIdState_1 -> Map Identifier UserId
_identifiers_1 :: Map Identifier UserId
    }
    deriving (OpenIdState_1 -> OpenIdState_1 -> Bool
(OpenIdState_1 -> OpenIdState_1 -> Bool)
-> (OpenIdState_1 -> OpenIdState_1 -> Bool) -> Eq OpenIdState_1
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c/= :: OpenIdState_1 -> OpenIdState_1 -> Bool
== :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c== :: OpenIdState_1 -> OpenIdState_1 -> Bool
Eq, Eq OpenIdState_1
Eq OpenIdState_1
-> (OpenIdState_1 -> OpenIdState_1 -> Ordering)
-> (OpenIdState_1 -> OpenIdState_1 -> Bool)
-> (OpenIdState_1 -> OpenIdState_1 -> Bool)
-> (OpenIdState_1 -> OpenIdState_1 -> Bool)
-> (OpenIdState_1 -> OpenIdState_1 -> Bool)
-> (OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1)
-> (OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1)
-> Ord OpenIdState_1
OpenIdState_1 -> OpenIdState_1 -> Bool
OpenIdState_1 -> OpenIdState_1 -> Ordering
OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1
$cmin :: OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1
max :: OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1
$cmax :: OpenIdState_1 -> OpenIdState_1 -> OpenIdState_1
>= :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c>= :: OpenIdState_1 -> OpenIdState_1 -> Bool
> :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c> :: OpenIdState_1 -> OpenIdState_1 -> Bool
<= :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c<= :: OpenIdState_1 -> OpenIdState_1 -> Bool
< :: OpenIdState_1 -> OpenIdState_1 -> Bool
$c< :: OpenIdState_1 -> OpenIdState_1 -> Bool
compare :: OpenIdState_1 -> OpenIdState_1 -> Ordering
$ccompare :: OpenIdState_1 -> OpenIdState_1 -> Ordering
$cp1Ord :: Eq OpenIdState_1
Ord, ReadPrec [OpenIdState_1]
ReadPrec OpenIdState_1
Int -> ReadS OpenIdState_1
ReadS [OpenIdState_1]
(Int -> ReadS OpenIdState_1)
-> ReadS [OpenIdState_1]
-> ReadPrec OpenIdState_1
-> ReadPrec [OpenIdState_1]
-> Read OpenIdState_1
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OpenIdState_1]
$creadListPrec :: ReadPrec [OpenIdState_1]
readPrec :: ReadPrec OpenIdState_1
$creadPrec :: ReadPrec OpenIdState_1
readList :: ReadS [OpenIdState_1]
$creadList :: ReadS [OpenIdState_1]
readsPrec :: Int -> ReadS OpenIdState_1
$creadsPrec :: Int -> ReadS OpenIdState_1
Read, Int -> OpenIdState_1 -> ShowS
[OpenIdState_1] -> ShowS
OpenIdState_1 -> String
(Int -> OpenIdState_1 -> ShowS)
-> (OpenIdState_1 -> String)
-> ([OpenIdState_1] -> ShowS)
-> Show OpenIdState_1
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenIdState_1] -> ShowS
$cshowList :: [OpenIdState_1] -> ShowS
show :: OpenIdState_1 -> String
$cshow :: OpenIdState_1 -> String
showsPrec :: Int -> OpenIdState_1 -> ShowS
$cshowsPrec :: Int -> OpenIdState_1 -> ShowS
Show, Typeable OpenIdState_1
DataType
Constr
Typeable OpenIdState_1
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> OpenIdState_1 -> c OpenIdState_1)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c OpenIdState_1)
-> (OpenIdState_1 -> Constr)
-> (OpenIdState_1 -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c OpenIdState_1))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c OpenIdState_1))
-> ((forall b. Data b => b -> b) -> OpenIdState_1 -> OpenIdState_1)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r)
-> (forall u. (forall d. Data d => d -> u) -> OpenIdState_1 -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> OpenIdState_1 -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1)
-> Data OpenIdState_1
OpenIdState_1 -> DataType
OpenIdState_1 -> Constr
(forall b. Data b => b -> b) -> OpenIdState_1 -> OpenIdState_1
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState_1 -> c OpenIdState_1
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState_1
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OpenIdState_1 -> u
forall u. (forall d. Data d => d -> u) -> OpenIdState_1 -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState_1
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState_1 -> c OpenIdState_1
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdState_1)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState_1)
$cOpenIdState_1 :: Constr
$tOpenIdState_1 :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
gmapMp :: (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
gmapM :: (forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdState_1 -> m OpenIdState_1
gmapQi :: Int -> (forall d. Data d => d -> u) -> OpenIdState_1 -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenIdState_1 -> u
gmapQ :: (forall d. Data d => d -> u) -> OpenIdState_1 -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OpenIdState_1 -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState_1 -> r
gmapT :: (forall b. Data b => b -> b) -> OpenIdState_1 -> OpenIdState_1
$cgmapT :: (forall b. Data b => b -> b) -> OpenIdState_1 -> OpenIdState_1
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState_1)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState_1)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c OpenIdState_1)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdState_1)
dataTypeOf :: OpenIdState_1 -> DataType
$cdataTypeOf :: OpenIdState_1 -> DataType
toConstr :: OpenIdState_1 -> Constr
$ctoConstr :: OpenIdState_1 -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState_1
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState_1
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState_1 -> c OpenIdState_1
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState_1 -> c OpenIdState_1
$cp1Data :: Typeable OpenIdState_1
Data, Typeable, (forall x. OpenIdState_1 -> Rep OpenIdState_1 x)
-> (forall x. Rep OpenIdState_1 x -> OpenIdState_1)
-> Generic OpenIdState_1
forall x. Rep OpenIdState_1 x -> OpenIdState_1
forall x. OpenIdState_1 -> Rep OpenIdState_1 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpenIdState_1 x -> OpenIdState_1
$cfrom :: forall x. OpenIdState_1 -> Rep OpenIdState_1 x
Generic)
deriveSafeCopy 1 'base ''OpenIdState_1
makeLenses ''OpenIdState_1

data OpenIdState = OpenIdState
    { OpenIdState -> Map Identifier UserId
_identifiers :: Map Identifier UserId
    , OpenIdState -> Maybe Lang
_openIdRealm :: Maybe Text
    }
    deriving (OpenIdState -> OpenIdState -> Bool
(OpenIdState -> OpenIdState -> Bool)
-> (OpenIdState -> OpenIdState -> Bool) -> Eq OpenIdState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpenIdState -> OpenIdState -> Bool
$c/= :: OpenIdState -> OpenIdState -> Bool
== :: OpenIdState -> OpenIdState -> Bool
$c== :: OpenIdState -> OpenIdState -> Bool
Eq, Eq OpenIdState
Eq OpenIdState
-> (OpenIdState -> OpenIdState -> Ordering)
-> (OpenIdState -> OpenIdState -> Bool)
-> (OpenIdState -> OpenIdState -> Bool)
-> (OpenIdState -> OpenIdState -> Bool)
-> (OpenIdState -> OpenIdState -> Bool)
-> (OpenIdState -> OpenIdState -> OpenIdState)
-> (OpenIdState -> OpenIdState -> OpenIdState)
-> Ord OpenIdState
OpenIdState -> OpenIdState -> Bool
OpenIdState -> OpenIdState -> Ordering
OpenIdState -> OpenIdState -> OpenIdState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OpenIdState -> OpenIdState -> OpenIdState
$cmin :: OpenIdState -> OpenIdState -> OpenIdState
max :: OpenIdState -> OpenIdState -> OpenIdState
$cmax :: OpenIdState -> OpenIdState -> OpenIdState
>= :: OpenIdState -> OpenIdState -> Bool
$c>= :: OpenIdState -> OpenIdState -> Bool
> :: OpenIdState -> OpenIdState -> Bool
$c> :: OpenIdState -> OpenIdState -> Bool
<= :: OpenIdState -> OpenIdState -> Bool
$c<= :: OpenIdState -> OpenIdState -> Bool
< :: OpenIdState -> OpenIdState -> Bool
$c< :: OpenIdState -> OpenIdState -> Bool
compare :: OpenIdState -> OpenIdState -> Ordering
$ccompare :: OpenIdState -> OpenIdState -> Ordering
$cp1Ord :: Eq OpenIdState
Ord, ReadPrec [OpenIdState]
ReadPrec OpenIdState
Int -> ReadS OpenIdState
ReadS [OpenIdState]
(Int -> ReadS OpenIdState)
-> ReadS [OpenIdState]
-> ReadPrec OpenIdState
-> ReadPrec [OpenIdState]
-> Read OpenIdState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OpenIdState]
$creadListPrec :: ReadPrec [OpenIdState]
readPrec :: ReadPrec OpenIdState
$creadPrec :: ReadPrec OpenIdState
readList :: ReadS [OpenIdState]
$creadList :: ReadS [OpenIdState]
readsPrec :: Int -> ReadS OpenIdState
$creadsPrec :: Int -> ReadS OpenIdState
Read, Int -> OpenIdState -> ShowS
[OpenIdState] -> ShowS
OpenIdState -> String
(Int -> OpenIdState -> ShowS)
-> (OpenIdState -> String)
-> ([OpenIdState] -> ShowS)
-> Show OpenIdState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenIdState] -> ShowS
$cshowList :: [OpenIdState] -> ShowS
show :: OpenIdState -> String
$cshow :: OpenIdState -> String
showsPrec :: Int -> OpenIdState -> ShowS
$cshowsPrec :: Int -> OpenIdState -> ShowS
Show, Typeable OpenIdState
DataType
Constr
Typeable OpenIdState
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> OpenIdState -> c OpenIdState)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c OpenIdState)
-> (OpenIdState -> Constr)
-> (OpenIdState -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c OpenIdState))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c OpenIdState))
-> ((forall b. Data b => b -> b) -> OpenIdState -> OpenIdState)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdState -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenIdState -> r)
-> (forall u. (forall d. Data d => d -> u) -> OpenIdState -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> OpenIdState -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState)
-> Data OpenIdState
OpenIdState -> DataType
OpenIdState -> Constr
(forall b. Data b => b -> b) -> OpenIdState -> OpenIdState
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState -> c OpenIdState
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OpenIdState -> u
forall u. (forall d. Data d => d -> u) -> OpenIdState -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState -> c OpenIdState
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdState)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState)
$cOpenIdState :: Constr
$tOpenIdState :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
gmapMp :: (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
gmapM :: (forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenIdState -> m OpenIdState
gmapQi :: Int -> (forall d. Data d => d -> u) -> OpenIdState -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenIdState -> u
gmapQ :: (forall d. Data d => d -> u) -> OpenIdState -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OpenIdState -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenIdState -> r
gmapT :: (forall b. Data b => b -> b) -> OpenIdState -> OpenIdState
$cgmapT :: (forall b. Data b => b -> b) -> OpenIdState -> OpenIdState
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c OpenIdState)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c OpenIdState)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenIdState)
dataTypeOf :: OpenIdState -> DataType
$cdataTypeOf :: OpenIdState -> DataType
toConstr :: OpenIdState -> Constr
$ctoConstr :: OpenIdState -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenIdState
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState -> c OpenIdState
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenIdState -> c OpenIdState
$cp1Data :: Typeable OpenIdState
Data, Typeable, (forall x. OpenIdState -> Rep OpenIdState x)
-> (forall x. Rep OpenIdState x -> OpenIdState)
-> Generic OpenIdState
forall x. Rep OpenIdState x -> OpenIdState
forall x. OpenIdState -> Rep OpenIdState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpenIdState x -> OpenIdState
$cfrom :: forall x. OpenIdState -> Rep OpenIdState x
Generic)
deriveSafeCopy 2 'extension ''OpenIdState
makeLenses ''OpenIdState

instance Migrate OpenIdState where
  type MigrateFrom OpenIdState = OpenIdState_1
  migrate :: MigrateFrom OpenIdState -> OpenIdState
migrate (OpenIdState_1 ids) = Map Identifier UserId -> Maybe Lang -> OpenIdState
OpenIdState Map Identifier UserId
ids Maybe Lang
forall a. Maybe a
Nothing

initialOpenIdState :: OpenIdState
initialOpenIdState :: OpenIdState
initialOpenIdState = OpenIdState :: Map Identifier UserId -> Maybe Lang -> OpenIdState
OpenIdState
    { _identifiers :: Map Identifier UserId
_identifiers = [(Identifier, UserId)] -> Map Identifier UserId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList []
    , _openIdRealm :: Maybe Lang
_openIdRealm = Maybe Lang
forall a. Maybe a
Nothing
    }

------------------------------------------------------------------------------
-- 'OpenIdState' acid-state methods
------------------------------------------------------------------------------

identifierToUserId :: Identifier -> Query OpenIdState (Maybe UserId)
identifierToUserId :: Identifier -> Query OpenIdState (Maybe UserId)
identifierToUserId Identifier
identifier = Getting (Maybe UserId) OpenIdState (Maybe UserId)
-> Query OpenIdState (Maybe UserId)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Map Identifier UserId
 -> Const (Maybe UserId) (Map Identifier UserId))
-> OpenIdState -> Const (Maybe UserId) OpenIdState
Lens' OpenIdState (Map Identifier UserId)
identifiers ((Map Identifier UserId
  -> Const (Maybe UserId) (Map Identifier UserId))
 -> OpenIdState -> Const (Maybe UserId) OpenIdState)
-> ((Maybe UserId -> Const (Maybe UserId) (Maybe UserId))
    -> Map Identifier UserId
    -> Const (Maybe UserId) (Map Identifier UserId))
-> Getting (Maybe UserId) OpenIdState (Maybe UserId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Identifier UserId)
-> Lens'
     (Map Identifier UserId) (Maybe (IxValue (Map Identifier UserId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
Index (Map Identifier UserId)
identifier)

associateIdentifierWithUserId :: Identifier -> UserId -> Update OpenIdState ()
associateIdentifierWithUserId :: Identifier -> UserId -> Update OpenIdState ()
associateIdentifierWithUserId Identifier
ident UserId
uid =
  (Map Identifier UserId -> Identity (Map Identifier UserId))
-> OpenIdState -> Identity OpenIdState
Lens' OpenIdState (Map Identifier UserId)
identifiers ((Map Identifier UserId -> Identity (Map Identifier UserId))
 -> OpenIdState -> Identity OpenIdState)
-> ((Maybe UserId -> Identity (Maybe UserId))
    -> Map Identifier UserId -> Identity (Map Identifier UserId))
-> (Maybe UserId -> Identity (Maybe UserId))
-> OpenIdState
-> Identity OpenIdState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Identifier UserId)
-> Lens'
     (Map Identifier UserId) (Maybe (IxValue (Map Identifier UserId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
Index (Map Identifier UserId)
ident ((Maybe UserId -> Identity (Maybe UserId))
 -> OpenIdState -> Identity OpenIdState)
-> UserId -> Update OpenIdState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= UserId
uid

-- | Get the OpenId realm to use for authentication
getOpenIdRealm :: Query OpenIdState (Maybe Text)
getOpenIdRealm :: Query OpenIdState (Maybe Lang)
getOpenIdRealm = Getting (Maybe Lang) OpenIdState (Maybe Lang)
-> Query OpenIdState (Maybe Lang)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Lang) OpenIdState (Maybe Lang)
Lens' OpenIdState (Maybe Lang)
openIdRealm

-- | set the realm used for OpenId Authentication
--
-- IMPORTANT: Changing this value after users have registered is
-- likely to invalidate existing OpenId tokens resulting in users no
-- longer being able to access their old accounts.
setOpenIdRealm :: Maybe Text
               -> Update OpenIdState ()
setOpenIdRealm :: Maybe Lang -> Update OpenIdState ()
setOpenIdRealm Maybe Lang
realm = (Maybe Lang -> Identity (Maybe Lang))
-> OpenIdState -> Identity OpenIdState
Lens' OpenIdState (Maybe Lang)
openIdRealm ((Maybe Lang -> Identity (Maybe Lang))
 -> OpenIdState -> Identity OpenIdState)
-> Maybe Lang -> Update OpenIdState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe Lang
realm

makeAcidic ''OpenIdState
  [ 'identifierToUserId
  , 'associateIdentifierWithUserId
  , 'getOpenIdRealm
  , 'setOpenIdRealm
  ]

data SetRealmData = SetRealmData
  { SetRealmData -> Maybe Lang
_srOpenIdRealm :: Maybe Text
  }
  deriving (SetRealmData -> SetRealmData -> Bool
(SetRealmData -> SetRealmData -> Bool)
-> (SetRealmData -> SetRealmData -> Bool) -> Eq SetRealmData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetRealmData -> SetRealmData -> Bool
$c/= :: SetRealmData -> SetRealmData -> Bool
== :: SetRealmData -> SetRealmData -> Bool
$c== :: SetRealmData -> SetRealmData -> Bool
Eq, Eq SetRealmData
Eq SetRealmData
-> (SetRealmData -> SetRealmData -> Ordering)
-> (SetRealmData -> SetRealmData -> Bool)
-> (SetRealmData -> SetRealmData -> Bool)
-> (SetRealmData -> SetRealmData -> Bool)
-> (SetRealmData -> SetRealmData -> Bool)
-> (SetRealmData -> SetRealmData -> SetRealmData)
-> (SetRealmData -> SetRealmData -> SetRealmData)
-> Ord SetRealmData
SetRealmData -> SetRealmData -> Bool
SetRealmData -> SetRealmData -> Ordering
SetRealmData -> SetRealmData -> SetRealmData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SetRealmData -> SetRealmData -> SetRealmData
$cmin :: SetRealmData -> SetRealmData -> SetRealmData
max :: SetRealmData -> SetRealmData -> SetRealmData
$cmax :: SetRealmData -> SetRealmData -> SetRealmData
>= :: SetRealmData -> SetRealmData -> Bool
$c>= :: SetRealmData -> SetRealmData -> Bool
> :: SetRealmData -> SetRealmData -> Bool
$c> :: SetRealmData -> SetRealmData -> Bool
<= :: SetRealmData -> SetRealmData -> Bool
$c<= :: SetRealmData -> SetRealmData -> Bool
< :: SetRealmData -> SetRealmData -> Bool
$c< :: SetRealmData -> SetRealmData -> Bool
compare :: SetRealmData -> SetRealmData -> Ordering
$ccompare :: SetRealmData -> SetRealmData -> Ordering
$cp1Ord :: Eq SetRealmData
Ord, ReadPrec [SetRealmData]
ReadPrec SetRealmData
Int -> ReadS SetRealmData
ReadS [SetRealmData]
(Int -> ReadS SetRealmData)
-> ReadS [SetRealmData]
-> ReadPrec SetRealmData
-> ReadPrec [SetRealmData]
-> Read SetRealmData
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SetRealmData]
$creadListPrec :: ReadPrec [SetRealmData]
readPrec :: ReadPrec SetRealmData
$creadPrec :: ReadPrec SetRealmData
readList :: ReadS [SetRealmData]
$creadList :: ReadS [SetRealmData]
readsPrec :: Int -> ReadS SetRealmData
$creadsPrec :: Int -> ReadS SetRealmData
Read, Int -> SetRealmData -> ShowS
[SetRealmData] -> ShowS
SetRealmData -> String
(Int -> SetRealmData -> ShowS)
-> (SetRealmData -> String)
-> ([SetRealmData] -> ShowS)
-> Show SetRealmData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetRealmData] -> ShowS
$cshowList :: [SetRealmData] -> ShowS
show :: SetRealmData -> String
$cshow :: SetRealmData -> String
showsPrec :: Int -> SetRealmData -> ShowS
$cshowsPrec :: Int -> SetRealmData -> ShowS
Show, Typeable SetRealmData
DataType
Constr
Typeable SetRealmData
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> SetRealmData -> c SetRealmData)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SetRealmData)
-> (SetRealmData -> Constr)
-> (SetRealmData -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c SetRealmData))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c SetRealmData))
-> ((forall b. Data b => b -> b) -> SetRealmData -> SetRealmData)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SetRealmData -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SetRealmData -> r)
-> (forall u. (forall d. Data d => d -> u) -> SetRealmData -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> SetRealmData -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData)
-> Data SetRealmData
SetRealmData -> DataType
SetRealmData -> Constr
(forall b. Data b => b -> b) -> SetRealmData -> SetRealmData
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SetRealmData -> c SetRealmData
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SetRealmData
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> SetRealmData -> u
forall u. (forall d. Data d => d -> u) -> SetRealmData -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SetRealmData
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SetRealmData -> c SetRealmData
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SetRealmData)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SetRealmData)
$cSetRealmData :: Constr
$tSetRealmData :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
gmapMp :: (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
gmapM :: (forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SetRealmData -> m SetRealmData
gmapQi :: Int -> (forall d. Data d => d -> u) -> SetRealmData -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SetRealmData -> u
gmapQ :: (forall d. Data d => d -> u) -> SetRealmData -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SetRealmData -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SetRealmData -> r
gmapT :: (forall b. Data b => b -> b) -> SetRealmData -> SetRealmData
$cgmapT :: (forall b. Data b => b -> b) -> SetRealmData -> SetRealmData
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SetRealmData)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SetRealmData)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c SetRealmData)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SetRealmData)
dataTypeOf :: SetRealmData -> DataType
$cdataTypeOf :: SetRealmData -> DataType
toConstr :: SetRealmData -> Constr
$ctoConstr :: SetRealmData -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SetRealmData
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SetRealmData
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SetRealmData -> c SetRealmData
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SetRealmData -> c SetRealmData
$cp1Data :: Typeable SetRealmData
Data, Typeable, (forall x. SetRealmData -> Rep SetRealmData x)
-> (forall x. Rep SetRealmData x -> SetRealmData)
-> Generic SetRealmData
forall x. Rep SetRealmData x -> SetRealmData
forall x. SetRealmData -> Rep SetRealmData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SetRealmData x -> SetRealmData
$cfrom :: forall x. SetRealmData -> Rep SetRealmData x
Generic)
makeLenses ''SetRealmData
instance ToJSON   SetRealmData where toJSON :: SetRealmData -> Value
toJSON    = Options -> SetRealmData -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON SetRealmData where parseJSON :: Value -> Parser SetRealmData
parseJSON = Options -> Value -> Parser SetRealmData
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

realm :: (Happstack m) =>
         AcidState AuthenticateState
      -> AcidState OpenIdState
      -> m Response
realm :: AcidState AuthenticateState -> AcidState OpenIdState -> m Response
realm AcidState AuthenticateState
authenticateState AcidState OpenIdState
openIdState =
  do Maybe (Token, JWT VerifiedJWT)
mt <- AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getToken AcidState AuthenticateState
authenticateState
     case Maybe (Token, JWT VerifiedJWT)
mt of
       Maybe (Token, JWT VerifiedJWT)
Nothing                -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ OpenIdError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError (CoreError -> OpenIdError
CoreError CoreError
AuthorizationRequired)
       (Just (Token
token,JWT VerifiedJWT
_))
         | Token
token Token -> Getting Bool Token Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Token Bool
Lens' Token Bool
tokenIsAuthAdmin Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
forbidden (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$  OpenIdError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError (CoreError -> OpenIdError
CoreError CoreError
Forbidden)
         | Bool
otherwise ->
            [m Response] -> m Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do Method -> m ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
GET
                      Maybe Lang
mRealm <- AcidState (EventState GetOpenIdRealm)
-> GetOpenIdRealm -> m (EventResult GetOpenIdRealm)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetOpenIdRealm)
AcidState OpenIdState
openIdState GetOpenIdRealm
GetOpenIdRealm
                      Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Maybe Lang -> Response
forall a. ToJSON a => a -> Response
toJSONSuccess Maybe Lang
mRealm
                 , do Method -> m ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST
                      ~(Just (Body Tag
body)) <- Request -> m (Maybe RqBody)
forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody (Request -> m (Maybe RqBody)) -> m Request -> m (Maybe RqBody)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
                      case Tag -> Maybe SetRealmData
forall a. FromJSON a => Tag -> Maybe a
Aeson.decode Tag
body of
                        Maybe SetRealmData
Nothing   -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
badRequest (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ OpenIdError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError (CoreError -> OpenIdError
CoreError CoreError
JSONDecodeFailed)
                        (Just (SetRealmData Maybe Lang
mRealm)) ->
                          do -- liftIO $ putStrLn $ "mRealm from JSON: " ++ show mRealm
                             AcidState (EventState SetOpenIdRealm)
-> SetOpenIdRealm -> m (EventResult SetOpenIdRealm)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState SetOpenIdRealm)
AcidState OpenIdState
openIdState (Maybe Lang -> SetOpenIdRealm
SetOpenIdRealm Maybe Lang
mRealm)
                             Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ () -> Response
forall a. ToJSON a => a -> Response
toJSONSuccess ()
                 ]

-- this get's the identifier the openid provider provides. It is our
-- only chance to capture the Identifier. So, before we send a
-- Response we need to have some sort of cookie set that identifies
-- the user. We can not just put the identifier in the cookie because
-- we don't want some one to fake it.
getIdentifier :: (Happstack m) => m Identifier
getIdentifier :: m Identifier
getIdentifier =
    do [(String, Either String Tag)]
pairs'      <- m [(String, Either String Tag)]
forall (m :: * -> *).
(Monad m, HasRqData m) =>
m [(String, Either String Tag)]
lookPairsBS
       let pairs :: [(Lang, Lang)]
pairs = ((String, Either String Tag) -> Maybe (Lang, Lang))
-> [(String, Either String Tag)] -> [(Lang, Lang)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(String
k, Either String Tag
ev) -> case Either String Tag
ev of (Left String
_) -> Maybe (Lang, Lang)
forall a. Maybe a
Nothing ; (Right Tag
v) -> (Lang, Lang) -> Maybe (Lang, Lang)
forall a. a -> Maybe a
Just (String -> Lang
T.pack String
k, Text -> Lang
TL.toStrict (Text -> Lang) -> Text -> Lang
forall a b. (a -> b) -> a -> b
$ Tag -> Text
TL.decodeUtf8 Tag
v)) [(String, Either String Tag)]
pairs'
       OpenIdResponse
oir <- IO OpenIdResponse -> m OpenIdResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OpenIdResponse -> m OpenIdResponse)
-> IO OpenIdResponse -> m OpenIdResponse
forall a b. (a -> b) -> a -> b
$ do Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
                          [(Lang, Lang)] -> Manager -> IO OpenIdResponse
forall (m :: * -> *).
MonadIO m =>
[(Lang, Lang)] -> Manager -> m OpenIdResponse
authenticateClaimed [(Lang, Lang)]
pairs Manager
manager
       Identifier -> m Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenIdResponse -> Identifier
oirOpLocal OpenIdResponse
oir)

token :: (Alternative m, Happstack m) =>
         AcidState AuthenticateState
      -> AuthenticateConfig
      -> AcidState OpenIdState
      -> m Response
token :: AcidState AuthenticateState
-> AuthenticateConfig -> AcidState OpenIdState -> m Response
token AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig AcidState OpenIdState
openIdState =
    do Identifier
identifier <- m Identifier
forall (m :: * -> *). Happstack m => m Identifier
getIdentifier
       Maybe UserId
mUserId <- AcidState (EventState IdentifierToUserId)
-> IdentifierToUserId -> m (EventResult IdentifierToUserId)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState IdentifierToUserId)
AcidState OpenIdState
openIdState (Identifier -> IdentifierToUserId
IdentifierToUserId Identifier
identifier)
       Maybe User
mUser <- case Maybe UserId
mUserId of
         Maybe UserId
Nothing    -> -- badRequest $ toJSONError UnknownIdentifier
           do User
user <- AcidState (EventState CreateAnonymousUser)
-> CreateAnonymousUser -> m (EventResult CreateAnonymousUser)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState CreateAnonymousUser)
AcidState AuthenticateState
authenticateState CreateAnonymousUser
CreateAnonymousUser
              AcidState (EventState AssociateIdentifierWithUserId)
-> AssociateIdentifierWithUserId
-> m (EventResult AssociateIdentifierWithUserId)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState AssociateIdentifierWithUserId)
AcidState OpenIdState
openIdState (Identifier -> UserId -> AssociateIdentifierWithUserId
AssociateIdentifierWithUserId Identifier
identifier (User
user User -> Getting UserId User UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId User UserId
Lens' User UserId
userId))
--              addTokenCookie authenticateState user
              Maybe User -> m (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> Maybe User
forall a. a -> Maybe a
Just User
user)
         (Just UserId
uid) ->
           do Maybe User
mu <- AcidState (EventState GetUserByUserId)
-> GetUserByUserId -> m (EventResult GetUserByUserId)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetUserByUserId)
AcidState AuthenticateState
authenticateState (UserId -> GetUserByUserId
GetUserByUserId UserId
uid)
              case Maybe User
mu of
                Maybe User
Nothing -> Maybe User -> m (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe User
forall a. Maybe a
Nothing
                (Just User
u) ->
                  Maybe User -> m (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> Maybe User
forall a. a -> Maybe a
Just User
u)
       case Maybe User
mUser of
         Maybe User
Nothing     -> Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ OpenIdError -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError (OpenIdError -> Response) -> OpenIdError -> Response
forall a b. (a -> b) -> a -> b
$ CoreError -> OpenIdError
CoreError CoreError
InvalidUserId
         (Just User
user) -> do Lang
token <- AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
addTokenCookie AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig User
user
                           let tokenBS :: Tag
tokenBS = Text -> Tag
TL.encodeUtf8 (Text -> Tag) -> Text -> Tag
forall a b. (a -> b) -> a -> b
$ Lang -> Text
TL.fromStrict Lang
token
--                           ok $ toResponse token
                           Response -> m Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Tag -> Response
toResponseBS ByteString
"text/html" (Tag -> Response) -> Tag -> Response
forall a b. (a -> b) -> a -> b
$ Tag
"<html><head><script type='text/javascript'>window.opener.tokenCB('" Tag -> Tag -> Tag
forall a. Semigroup a => a -> a -> a
<> Tag
tokenBS Tag -> Tag -> Tag
forall a. Semigroup a => a -> a -> a
<> Tag
"'); window.close();</script></head><body></body></html>"

--                           liftIO $ print token
--                           ok $ toResponseBS "text/html" $ "<html><head><script type='text/javascript'>localStorage.setItem('user',</script></head><body>wheee</body></html>"
                  {-
                  do token <- addTokenCookie authenticateState u
                     resp 201 $ toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)]
-}
{-
account :: (Happstack m) =>
           AcidState AuthenticateState
        -> AcidState OpenIdState
        -> Maybe (UserId, AccountURL)
        -> m (Either OpenIdError UserId)
-- handle new account created via POST to /account
account authenticateState openIdState Nothing =
  undefined
-}
{-


connect :: (Happstack m, MonadRoute m, URL m ~ OpenIdURL) =>
              AuthMode     -- ^ authentication mode
           -> Maybe Text -- ^ realm
           -> Text       -- ^ openid url
           -> m Response
connect authMode realm url =
    do openIdUrl <- showURL (O_OpenId authMode)
       gotoURL <- liftIO $ withManager $ getForwardUrl url openIdUrl realm []
       seeOther (T.unpack gotoURL) (toResponse gotoURL)

handleOpenId :: (Alternative m, Happstack m, MonadRoute m, URL m ~ OpenIdURL) =>
                AcidState AuthState
             -> Maybe Text   -- ^ realm
             -> Text         -- ^ onAuthURL
             -> OpenIdURL    -- ^ this url
             -> m Response
handleOpenId acid realm onAuthURL url =
    case url of
      (O_OpenId authMode)                  -> openIdPage acid authMode onAuthURL
      (O_Connect authMode)                 ->
          do url <- lookText "url"
             connect authMode realm (TL.toStrict url)

-}