{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, TypeFamilies, TypeSynonymInstances, UndecidableInstances, OverloadedStrings #-}
{-

A user is uniquely identified by their 'UserId'. A user can have one
or more authentication methods associated with their account. However,
each authentication method can only be associated with a single
'UserId'. This means, for example, that a user can not use the same
openid account to log in as multiple different users.

Additionally, it is assume that all authentication methods associated
with the 'UserId' are controlled by a single individual. They are not
intended to provide a way for several different users to share the
same account.

An email address is also collected to make account recovery easier.

Authentication Method
---------------------

When creating an account there are some common aspects -- such as the
username and email address. But we also want to allow the user to
select a method for authentication.

Creating the account could be multiple steps. What if we store the
partial data in a token. That way we avoid creating half-a-user.

From an API point of view -- we want the client to simple POST to
/users and create an account.

For different authentication backends, we need the user to be able to
fetch the partials for the extra information.

-}

module Happstack.Authenticate.Core
    ( AuthenticateConfig(..)
    , isAuthAdmin
    , usernameAcceptable
    , requireEmail
    , systemFromAddress
    , systemReplyToAddress
    , systemSendmailPath
    , postLoginRedirect
    , createUserCallback
    , HappstackAuthenticateI18N(..)
    , UserId(..)
    , unUserId
    , rUserId
    , succUserId
    , jsonOptions
    , toJSONResponse
    , toJSONSuccess
    , toJSONError
    , Username(..)
    , unUsername
    , rUsername
    , usernamePolicy
    , Email(..)
    , unEmail
    , User(..)
    , userId
    , username
    , email
    , UserIxs
    , IxUser
    , SharedSecret(..)
    , unSharedSecret
    , SimpleAddress(..)
    , genSharedSecret
    , genSharedSecretDevURandom
    , genSharedSecretSysRandom
    , SharedSecrets
    , initialSharedSecrets
    , CoreError(..)
    , NewAccountMode(..)
    , AuthenticateState(..)
    , sharedSecrets
    , users
    , nextUserId
    , defaultSessionTimeout
    , newAccountMode
    , initialAuthenticateState
    , SetSharedSecret(..)
    , GetSharedSecret(..)
    , SetDefaultSessionTimeout(..)
    , GetDefaultSessionTimeout(..)
    , SetNewAccountMode(..)
    , GetNewAccountMode(..)
    , CreateUser(..)
    , CreateAnonymousUser(..)
    , UpdateUser(..)
    , DeleteUser(..)
    , GetUserByUsername(..)
    , GetUserByUserId(..)
    , GetUserByEmail(..)
    , GetUsers(..)
    , GetUsersByEmail(..)
    , GetAuthenticateState(..)
    , getOrGenSharedSecret
    , Token(..)
    , tokenUser
    , tokenIsAuthAdmin
    , TokenText
    , issueToken
    , decodeAndVerifyToken
    , authCookieName
    , addTokenCookie
    , deleteTokenCookie
    , getTokenCookie
    , getTokenHeader
    , getToken
    , getUserId
    , AuthenticationMethod(..)
    , unAuthenticationMethod
    , rAuthenticationMethod
    , AuthenticationHandler
    , AuthenticationHandlers
    , AuthenticateURL(..)
    , rAuthenticationMethods
    , rControllers
    , systemFromAddress
    , systemReplyToAddress
    , systemSendmailPath
    , authenticateURL
    , nestAuthenticationMethod
    ) where

import Control.Applicative             (Applicative(pure), Alternative, (<$>), optional)
import Control.Category                ((.), id)
import Control.Exception               (SomeException)
import qualified Control.Exception     as E
import Control.Lens                    ((?=), (.=), (^.), (.~), makeLenses, view, set)
import Control.Lens.At                 (IxValue(..), Ixed(..), Index(..), At(at))
import Control.Monad.Trans             (MonadIO(liftIO))
import Control.Monad.Reader            (ask)
import Control.Monad.State             (get, put, modify)
import Data.Aeson                      (FromJSON(..), ToJSON(..), Result(..), fromJSON)
import qualified Data.Aeson            as A
import Data.Aeson.Types                (Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON)
import Data.Acid                       (AcidState, Update, Query, makeAcidic)
import Data.Acid.Advanced              (update', query')
import Data.ByteString.Base64          (encode)
import qualified Data.ByteString.Char8 as B
import Data.Data                       (Data, Typeable)
import Data.Default                    (def)
import Data.Map                        (Map)
import qualified Data.Map              as Map
import Data.Maybe                      (fromMaybe, maybeToList)
import Data.Monoid                     ((<>), mconcat, mempty)
import Data.SafeCopy                   (SafeCopy, Migrate(..), base, deriveSafeCopy, extension)
import Data.IxSet.Typed
import qualified Data.IxSet.Typed      as IxSet
import           Data.Set              (Set)
import qualified Data.Set              as Set
import Data.Text                       (Text)
import qualified Data.Text             as Text
import qualified Data.Text.Encoding    as Text
import Data.Time                       (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX           (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.UserId                     (UserId(..), rUserId, succUserId, unUserId)
import GHC.Generics                    (Generic)
import Happstack.Server                (Cookie(secure), CookieLife(Session, MaxAge), Happstack, ServerPartT, Request(rqSecure), Response, addCookie, askRq, expireCookie, getHeaderM, lookCookie, lookCookieValue, mkCookie, notFound, toResponseBS)
-- import Happstack.Server.Internal.Clock (getApproximateUTCTime)
import Language.Javascript.JMacro
import Prelude                         hiding ((.), id, exp)
import System.IO                       (IOMode(ReadMode), withFile)
import System.Random                   (randomRIO)
import Text.Boomerang.TH               (makeBoomerangs)
import Text.Shakespeare.I18N           (RenderMessage(renderMessage), mkMessageFor)
import Web.JWT                         (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, verify)
#if MIN_VERSION_jwt(0,8,0)
import Web.JWT                         (ClaimsMap(..), hmacSecret)
#else
import Web.JWT                         (secret)
#endif

import Web.Routes                      (RouteT, PathInfo(..), nestURL)
import Web.Routes.Boomerang
import Web.Routes.Happstack            ()
import Web.Routes.TH                   (derivePathInfo)

#if MIN_VERSION_jwt(0,8,0)
#else
unClaimsMap = id
#endif


-- | when creating JSON field names, drop the first character. Since
-- we are using lens, the leading character should always be _.
jsonOptions :: Options
jsonOptions :: Options
jsonOptions = Options
defaultOptions { fieldLabelModifier :: String -> String
fieldLabelModifier = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 }

data HappstackAuthenticateI18N = HappstackAuthenticateI18N

------------------------------------------------------------------------------
-- CoreError
------------------------------------------------------------------------------

-- | the `CoreError` type is used to represent errors in a language
-- agnostic manner. The errors are translated into human readable form
-- via the I18N translations.
data CoreError
  = HandlerNotFound -- AuthenticationMethod
  | URLDecodeFailed
  | UsernameAlreadyExists
  | AuthorizationRequired
  | Forbidden
  | JSONDecodeFailed
  | InvalidUserId
  | UsernameNotAcceptable
  | InvalidEmail
  | TextError Text
    deriving (CoreError -> CoreError -> Bool
(CoreError -> CoreError -> Bool)
-> (CoreError -> CoreError -> Bool) -> Eq CoreError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CoreError -> CoreError -> Bool
$c/= :: CoreError -> CoreError -> Bool
== :: CoreError -> CoreError -> Bool
$c== :: CoreError -> CoreError -> Bool
Eq, Eq CoreError
Eq CoreError
-> (CoreError -> CoreError -> Ordering)
-> (CoreError -> CoreError -> Bool)
-> (CoreError -> CoreError -> Bool)
-> (CoreError -> CoreError -> Bool)
-> (CoreError -> CoreError -> Bool)
-> (CoreError -> CoreError -> CoreError)
-> (CoreError -> CoreError -> CoreError)
-> Ord CoreError
CoreError -> CoreError -> Bool
CoreError -> CoreError -> Ordering
CoreError -> CoreError -> CoreError
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 :: CoreError -> CoreError -> CoreError
$cmin :: CoreError -> CoreError -> CoreError
max :: CoreError -> CoreError -> CoreError
$cmax :: CoreError -> CoreError -> CoreError
>= :: CoreError -> CoreError -> Bool
$c>= :: CoreError -> CoreError -> Bool
> :: CoreError -> CoreError -> Bool
$c> :: CoreError -> CoreError -> Bool
<= :: CoreError -> CoreError -> Bool
$c<= :: CoreError -> CoreError -> Bool
< :: CoreError -> CoreError -> Bool
$c< :: CoreError -> CoreError -> Bool
compare :: CoreError -> CoreError -> Ordering
$ccompare :: CoreError -> CoreError -> Ordering
$cp1Ord :: Eq CoreError
Ord, ReadPrec [CoreError]
ReadPrec CoreError
Int -> ReadS CoreError
ReadS [CoreError]
(Int -> ReadS CoreError)
-> ReadS [CoreError]
-> ReadPrec CoreError
-> ReadPrec [CoreError]
-> Read CoreError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CoreError]
$creadListPrec :: ReadPrec [CoreError]
readPrec :: ReadPrec CoreError
$creadPrec :: ReadPrec CoreError
readList :: ReadS [CoreError]
$creadList :: ReadS [CoreError]
readsPrec :: Int -> ReadS CoreError
$creadsPrec :: Int -> ReadS CoreError
Read, Int -> CoreError -> String -> String
[CoreError] -> String -> String
CoreError -> String
(Int -> CoreError -> String -> String)
-> (CoreError -> String)
-> ([CoreError] -> String -> String)
-> Show CoreError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CoreError] -> String -> String
$cshowList :: [CoreError] -> String -> String
show :: CoreError -> String
$cshow :: CoreError -> String
showsPrec :: Int -> CoreError -> String -> String
$cshowsPrec :: Int -> CoreError -> String -> String
Show, Typeable CoreError
DataType
Constr
Typeable CoreError
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> CoreError -> c CoreError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c CoreError)
-> (CoreError -> Constr)
-> (CoreError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c CoreError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CoreError))
-> ((forall b. Data b => b -> b) -> CoreError -> CoreError)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> CoreError -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> CoreError -> r)
-> (forall u. (forall d. Data d => d -> u) -> CoreError -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> CoreError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> CoreError -> m CoreError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CoreError -> m CoreError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CoreError -> m CoreError)
-> Data CoreError
CoreError -> DataType
CoreError -> Constr
(forall b. Data b => b -> b) -> CoreError -> CoreError
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CoreError -> c CoreError
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CoreError
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) -> CoreError -> u
forall u. (forall d. Data d => d -> u) -> CoreError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CoreError -> m CoreError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CoreError -> m CoreError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CoreError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CoreError -> c CoreError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CoreError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CoreError)
$cTextError :: Constr
$cInvalidEmail :: Constr
$cUsernameNotAcceptable :: Constr
$cInvalidUserId :: Constr
$cJSONDecodeFailed :: Constr
$cForbidden :: Constr
$cAuthorizationRequired :: Constr
$cUsernameAlreadyExists :: Constr
$cURLDecodeFailed :: Constr
$cHandlerNotFound :: Constr
$tCoreError :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> CoreError -> m CoreError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CoreError -> m CoreError
gmapMp :: (forall d. Data d => d -> m d) -> CoreError -> m CoreError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CoreError -> m CoreError
gmapM :: (forall d. Data d => d -> m d) -> CoreError -> m CoreError
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CoreError -> m CoreError
gmapQi :: Int -> (forall d. Data d => d -> u) -> CoreError -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CoreError -> u
gmapQ :: (forall d. Data d => d -> u) -> CoreError -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CoreError -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CoreError -> r
gmapT :: (forall b. Data b => b -> b) -> CoreError -> CoreError
$cgmapT :: (forall b. Data b => b -> b) -> CoreError -> CoreError
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CoreError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CoreError)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c CoreError)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CoreError)
dataTypeOf :: CoreError -> DataType
$cdataTypeOf :: CoreError -> DataType
toConstr :: CoreError -> Constr
$ctoConstr :: CoreError -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CoreError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CoreError
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CoreError -> c CoreError
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CoreError -> c CoreError
$cp1Data :: Typeable CoreError
Data, Typeable, (forall x. CoreError -> Rep CoreError x)
-> (forall x. Rep CoreError x -> CoreError) -> Generic CoreError
forall x. Rep CoreError x -> CoreError
forall x. CoreError -> Rep CoreError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CoreError x -> CoreError
$cfrom :: forall x. CoreError -> Rep CoreError x
Generic)
instance ToJSON   CoreError where toJSON :: CoreError -> Value
toJSON    = Options -> CoreError -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON CoreError where parseJSON :: Value -> Parser CoreError
parseJSON = Options -> Value -> Parser CoreError
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

instance ToJExpr CoreError where
    toJExpr :: CoreError -> JExpr
toJExpr = Value -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Value -> JExpr) -> (CoreError -> Value) -> CoreError -> JExpr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CoreError -> Value
forall a. ToJSON a => a -> Value
toJSON

deriveSafeCopy 0 'base ''CoreError

mkMessageFor "HappstackAuthenticateI18N" "CoreError" "messages/core" ("en")

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

instance ToJSON   Status where toJSON :: Status -> Value
toJSON    = Options -> Status -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON Status where parseJSON :: Value -> Parser Status
parseJSON = Options -> Value -> Parser Status
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

data JSONResponse = JSONResponse
    { JSONResponse -> Status
_jrStatus :: Status
    , JSONResponse -> Value
_jrData   :: A.Value
    }
    deriving (JSONResponse -> JSONResponse -> Bool
(JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> Bool) -> Eq JSONResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONResponse -> JSONResponse -> Bool
$c/= :: JSONResponse -> JSONResponse -> Bool
== :: JSONResponse -> JSONResponse -> Bool
$c== :: JSONResponse -> JSONResponse -> Bool
Eq, ReadPrec [JSONResponse]
ReadPrec JSONResponse
Int -> ReadS JSONResponse
ReadS [JSONResponse]
(Int -> ReadS JSONResponse)
-> ReadS [JSONResponse]
-> ReadPrec JSONResponse
-> ReadPrec [JSONResponse]
-> Read JSONResponse
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [JSONResponse]
$creadListPrec :: ReadPrec [JSONResponse]
readPrec :: ReadPrec JSONResponse
$creadPrec :: ReadPrec JSONResponse
readList :: ReadS [JSONResponse]
$creadList :: ReadS [JSONResponse]
readsPrec :: Int -> ReadS JSONResponse
$creadsPrec :: Int -> ReadS JSONResponse
Read, Int -> JSONResponse -> String -> String
[JSONResponse] -> String -> String
JSONResponse -> String
(Int -> JSONResponse -> String -> String)
-> (JSONResponse -> String)
-> ([JSONResponse] -> String -> String)
-> Show JSONResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [JSONResponse] -> String -> String
$cshowList :: [JSONResponse] -> String -> String
show :: JSONResponse -> String
$cshow :: JSONResponse -> String
showsPrec :: Int -> JSONResponse -> String -> String
$cshowsPrec :: Int -> JSONResponse -> String -> String
Show, Typeable JSONResponse
DataType
Constr
Typeable JSONResponse
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> JSONResponse -> c JSONResponse)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c JSONResponse)
-> (JSONResponse -> Constr)
-> (JSONResponse -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c JSONResponse))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c JSONResponse))
-> ((forall b. Data b => b -> b) -> JSONResponse -> JSONResponse)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> JSONResponse -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> JSONResponse -> r)
-> (forall u. (forall d. Data d => d -> u) -> JSONResponse -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> JSONResponse -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse)
-> Data JSONResponse
JSONResponse -> DataType
JSONResponse -> Constr
(forall b. Data b => b -> b) -> JSONResponse -> JSONResponse
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JSONResponse -> c JSONResponse
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JSONResponse
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) -> JSONResponse -> u
forall u. (forall d. Data d => d -> u) -> JSONResponse -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JSONResponse
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JSONResponse -> c JSONResponse
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c JSONResponse)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JSONResponse)
$cJSONResponse :: Constr
$tJSONResponse :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
gmapMp :: (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
gmapM :: (forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> JSONResponse -> m JSONResponse
gmapQi :: Int -> (forall d. Data d => d -> u) -> JSONResponse -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> JSONResponse -> u
gmapQ :: (forall d. Data d => d -> u) -> JSONResponse -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> JSONResponse -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JSONResponse -> r
gmapT :: (forall b. Data b => b -> b) -> JSONResponse -> JSONResponse
$cgmapT :: (forall b. Data b => b -> b) -> JSONResponse -> JSONResponse
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JSONResponse)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JSONResponse)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c JSONResponse)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c JSONResponse)
dataTypeOf :: JSONResponse -> DataType
$cdataTypeOf :: JSONResponse -> DataType
toConstr :: JSONResponse -> Constr
$ctoConstr :: JSONResponse -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JSONResponse
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JSONResponse
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JSONResponse -> c JSONResponse
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JSONResponse -> c JSONResponse
$cp1Data :: Typeable JSONResponse
Data, Typeable, (forall x. JSONResponse -> Rep JSONResponse x)
-> (forall x. Rep JSONResponse x -> JSONResponse)
-> Generic JSONResponse
forall x. Rep JSONResponse x -> JSONResponse
forall x. JSONResponse -> Rep JSONResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JSONResponse x -> JSONResponse
$cfrom :: forall x. JSONResponse -> Rep JSONResponse x
Generic)
-- deriveSafeCopy 1 'base ''JSONResponse
makeLenses ''JSONResponse
makeBoomerangs ''JSONResponse

instance ToJSON   JSONResponse where toJSON :: JSONResponse -> Value
toJSON    = Options -> JSONResponse -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON JSONResponse where parseJSON :: Value -> Parser JSONResponse
parseJSON = Options -> Value -> Parser JSONResponse
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

-- | convert a value to a JSON encoded 'Response'
toJSONResponse :: (RenderMessage HappstackAuthenticateI18N e, ToJSON a) => Either e a -> Response
toJSONResponse :: Either e a -> Response
toJSONResponse (Left e
e)  = e -> Response
forall e.
RenderMessage HappstackAuthenticateI18N e =>
e -> Response
toJSONError   e
e
toJSONResponse (Right a
a) = a -> Response
forall a. ToJSON a => a -> Response
toJSONSuccess a
a

-- | convert a value to a JSON encoded 'Response'
toJSONSuccess :: (ToJSON a) => a -> Response
toJSONSuccess :: a -> Response
toJSONSuccess a
a = ByteString -> ByteString -> Response
toResponseBS ByteString
"application/json" (JSONResponse -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Status -> Value -> JSONResponse
JSONResponse Status
Ok (a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
a)))

-- | convert an error to a JSON encoded 'Response'
--
-- FIXME: I18N
toJSONError :: forall e. (RenderMessage HappstackAuthenticateI18N e) => e -> Response
toJSONError :: e -> Response
toJSONError e
e = ByteString -> ByteString -> Response
toResponseBS ByteString
"application/json" (JSONResponse -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Status -> Value -> JSONResponse
JSONResponse Status
NotOk (Lang -> Value
forall a. ToJSON a => a -> Value
A.toJSON (HappstackAuthenticateI18N -> [Lang] -> e -> Lang
forall master message.
RenderMessage master message =>
master -> [Lang] -> message -> Lang
renderMessage HappstackAuthenticateI18N
HappstackAuthenticateI18N [Lang
"en"] e
e))))
--                (A.encode (A.object ["error" A..= renderMessage HappstackAuthenticateI18N ["en"] e]))

------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- UserId
------------------------------------------------------------------------------
{-
-- | a 'UserId' uniquely identifies a user.
newtype UserId = UserId { _unUserId :: Integer }
    deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic)
deriveSafeCopy 1 'base ''UserId
makeLenses ''UserId
makeBoomerangs ''UserId

instance ToJSON   UserId where toJSON (UserId i) = toJSON i
instance FromJSON UserId where parseJSON v = UserId <$> parseJSON v

instance PathInfo UserId where
    toPathSegments (UserId i) = toPathSegments i
    fromPathSegments = UserId <$> fromPathSegments

-- | get the next `UserId`
succUserId :: UserId -> UserId
succUserId (UserId i) = UserId (succ i)
-}
------------------------------------------------------------------------------
-- Username
------------------------------------------------------------------------------

-- | an arbitrary, but unique string that the user uses to identify themselves
newtype Username = Username { Username -> Lang
_unUsername :: Text }
      deriving (Username -> Username -> Bool
(Username -> Username -> Bool)
-> (Username -> Username -> Bool) -> Eq Username
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Username -> Username -> Bool
$c/= :: Username -> Username -> Bool
== :: Username -> Username -> Bool
$c== :: Username -> Username -> Bool
Eq, Eq Username
Eq Username
-> (Username -> Username -> Ordering)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Bool)
-> (Username -> Username -> Username)
-> (Username -> Username -> Username)
-> Ord Username
Username -> Username -> Bool
Username -> Username -> Ordering
Username -> Username -> Username
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 :: Username -> Username -> Username
$cmin :: Username -> Username -> Username
max :: Username -> Username -> Username
$cmax :: Username -> Username -> Username
>= :: Username -> Username -> Bool
$c>= :: Username -> Username -> Bool
> :: Username -> Username -> Bool
$c> :: Username -> Username -> Bool
<= :: Username -> Username -> Bool
$c<= :: Username -> Username -> Bool
< :: Username -> Username -> Bool
$c< :: Username -> Username -> Bool
compare :: Username -> Username -> Ordering
$ccompare :: Username -> Username -> Ordering
$cp1Ord :: Eq Username
Ord, ReadPrec [Username]
ReadPrec Username
Int -> ReadS Username
ReadS [Username]
(Int -> ReadS Username)
-> ReadS [Username]
-> ReadPrec Username
-> ReadPrec [Username]
-> Read Username
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Username]
$creadListPrec :: ReadPrec [Username]
readPrec :: ReadPrec Username
$creadPrec :: ReadPrec Username
readList :: ReadS [Username]
$creadList :: ReadS [Username]
readsPrec :: Int -> ReadS Username
$creadsPrec :: Int -> ReadS Username
Read, Int -> Username -> String -> String
[Username] -> String -> String
Username -> String
(Int -> Username -> String -> String)
-> (Username -> String)
-> ([Username] -> String -> String)
-> Show Username
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Username] -> String -> String
$cshowList :: [Username] -> String -> String
show :: Username -> String
$cshow :: Username -> String
showsPrec :: Int -> Username -> String -> String
$cshowsPrec :: Int -> Username -> String -> String
Show, Typeable Username
DataType
Constr
Typeable Username
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Username -> c Username)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Username)
-> (Username -> Constr)
-> (Username -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Username))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Username))
-> ((forall b. Data b => b -> b) -> Username -> Username)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Username -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Username -> r)
-> (forall u. (forall d. Data d => d -> u) -> Username -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Username -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Username -> m Username)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Username -> m Username)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Username -> m Username)
-> Data Username
Username -> DataType
Username -> Constr
(forall b. Data b => b -> b) -> Username -> Username
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Username -> c Username
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Username
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) -> Username -> u
forall u. (forall d. Data d => d -> u) -> Username -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Username -> m Username
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Username -> m Username
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Username
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Username -> c Username
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Username)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Username)
$cUsername :: Constr
$tUsername :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Username -> m Username
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Username -> m Username
gmapMp :: (forall d. Data d => d -> m d) -> Username -> m Username
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Username -> m Username
gmapM :: (forall d. Data d => d -> m d) -> Username -> m Username
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Username -> m Username
gmapQi :: Int -> (forall d. Data d => d -> u) -> Username -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Username -> u
gmapQ :: (forall d. Data d => d -> u) -> Username -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Username -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Username -> r
gmapT :: (forall b. Data b => b -> b) -> Username -> Username
$cgmapT :: (forall b. Data b => b -> b) -> Username -> Username
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Username)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Username)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Username)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Username)
dataTypeOf :: Username -> DataType
$cdataTypeOf :: Username -> DataType
toConstr :: Username -> Constr
$ctoConstr :: Username -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Username
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Username
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Username -> c Username
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Username -> c Username
$cp1Data :: Typeable Username
Data, Typeable, (forall x. Username -> Rep Username x)
-> (forall x. Rep Username x -> Username) -> Generic Username
forall x. Rep Username x -> Username
forall x. Username -> Rep Username x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Username x -> Username
$cfrom :: forall x. Username -> Rep Username x
Generic)
deriveSafeCopy 1 'base ''Username
makeLenses ''Username
makeBoomerangs ''Username

instance ToJSON   Username where toJSON :: Username -> Value
toJSON (Username Lang
i) = Lang -> Value
forall a. ToJSON a => a -> Value
toJSON Lang
i
instance FromJSON Username where parseJSON :: Value -> Parser Username
parseJSON Value
v = Lang -> Username
Username (Lang -> Username) -> Parser Lang -> Parser Username
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Lang
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance PathInfo Username where
    toPathSegments :: Username -> [Lang]
toPathSegments (Username Lang
t) = Lang -> [Lang]
forall url. PathInfo url => url -> [Lang]
toPathSegments Lang
t
    fromPathSegments :: URLParser Username
fromPathSegments = Lang -> Username
Username (Lang -> Username)
-> ParsecT [Lang] () Identity Lang -> URLParser Username
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Lang] () Identity Lang
forall url. PathInfo url => URLParser url
fromPathSegments

------------------------------------------------------------------------------
-- Email
------------------------------------------------------------------------------

-- | an `Email` address. No validation in performed.
newtype Email = Email { Email -> Lang
_unEmail :: Text }
      deriving (Email -> Email -> Bool
(Email -> Email -> Bool) -> (Email -> Email -> Bool) -> Eq Email
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Email -> Email -> Bool
$c/= :: Email -> Email -> Bool
== :: Email -> Email -> Bool
$c== :: Email -> Email -> Bool
Eq, Eq Email
Eq Email
-> (Email -> Email -> Ordering)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Bool)
-> (Email -> Email -> Email)
-> (Email -> Email -> Email)
-> Ord Email
Email -> Email -> Bool
Email -> Email -> Ordering
Email -> Email -> Email
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 :: Email -> Email -> Email
$cmin :: Email -> Email -> Email
max :: Email -> Email -> Email
$cmax :: Email -> Email -> Email
>= :: Email -> Email -> Bool
$c>= :: Email -> Email -> Bool
> :: Email -> Email -> Bool
$c> :: Email -> Email -> Bool
<= :: Email -> Email -> Bool
$c<= :: Email -> Email -> Bool
< :: Email -> Email -> Bool
$c< :: Email -> Email -> Bool
compare :: Email -> Email -> Ordering
$ccompare :: Email -> Email -> Ordering
$cp1Ord :: Eq Email
Ord, ReadPrec [Email]
ReadPrec Email
Int -> ReadS Email
ReadS [Email]
(Int -> ReadS Email)
-> ReadS [Email]
-> ReadPrec Email
-> ReadPrec [Email]
-> Read Email
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Email]
$creadListPrec :: ReadPrec [Email]
readPrec :: ReadPrec Email
$creadPrec :: ReadPrec Email
readList :: ReadS [Email]
$creadList :: ReadS [Email]
readsPrec :: Int -> ReadS Email
$creadsPrec :: Int -> ReadS Email
Read, Int -> Email -> String -> String
[Email] -> String -> String
Email -> String
(Int -> Email -> String -> String)
-> (Email -> String) -> ([Email] -> String -> String) -> Show Email
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Email] -> String -> String
$cshowList :: [Email] -> String -> String
show :: Email -> String
$cshow :: Email -> String
showsPrec :: Int -> Email -> String -> String
$cshowsPrec :: Int -> Email -> String -> String
Show, Typeable Email
DataType
Constr
Typeable Email
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Email -> c Email)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Email)
-> (Email -> Constr)
-> (Email -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Email))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Email))
-> ((forall b. Data b => b -> b) -> Email -> Email)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r)
-> (forall u. (forall d. Data d => d -> u) -> Email -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Email -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Email -> m Email)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Email -> m Email)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Email -> m Email)
-> Data Email
Email -> DataType
Email -> Constr
(forall b. Data b => b -> b) -> Email -> Email
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Email -> c Email
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Email
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) -> Email -> u
forall u. (forall d. Data d => d -> u) -> Email -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Email -> m Email
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Email -> m Email
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Email
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Email -> c Email
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Email)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Email)
$cEmail :: Constr
$tEmail :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Email -> m Email
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Email -> m Email
gmapMp :: (forall d. Data d => d -> m d) -> Email -> m Email
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Email -> m Email
gmapM :: (forall d. Data d => d -> m d) -> Email -> m Email
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Email -> m Email
gmapQi :: Int -> (forall d. Data d => d -> u) -> Email -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Email -> u
gmapQ :: (forall d. Data d => d -> u) -> Email -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Email -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Email -> r
gmapT :: (forall b. Data b => b -> b) -> Email -> Email
$cgmapT :: (forall b. Data b => b -> b) -> Email -> Email
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Email)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Email)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Email)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Email)
dataTypeOf :: Email -> DataType
$cdataTypeOf :: Email -> DataType
toConstr :: Email -> Constr
$ctoConstr :: Email -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Email
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Email
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Email -> c Email
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Email -> c Email
$cp1Data :: Typeable Email
Data, Typeable, (forall x. Email -> Rep Email x)
-> (forall x. Rep Email x -> Email) -> Generic Email
forall x. Rep Email x -> Email
forall x. Email -> Rep Email x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Email x -> Email
$cfrom :: forall x. Email -> Rep Email x
Generic)
deriveSafeCopy 1 'base ''Email
makeLenses ''Email

instance ToJSON   Email where toJSON :: Email -> Value
toJSON (Email Lang
i) = Lang -> Value
forall a. ToJSON a => a -> Value
toJSON Lang
i
instance FromJSON Email where parseJSON :: Value -> Parser Email
parseJSON Value
v = Lang -> Email
Email (Lang -> Email) -> Parser Lang -> Parser Email
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Lang
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance PathInfo Email where
    toPathSegments :: Email -> [Lang]
toPathSegments (Email Lang
t) = Lang -> [Lang]
forall url. PathInfo url => url -> [Lang]
toPathSegments Lang
t
    fromPathSegments :: URLParser Email
fromPathSegments = Lang -> Email
Email (Lang -> Email)
-> ParsecT [Lang] () Identity Lang -> URLParser Email
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Lang] () Identity Lang
forall url. PathInfo url => URLParser url
fromPathSegments

------------------------------------------------------------------------------
-- User
------------------------------------------------------------------------------

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

instance ToJSON   User where toJSON :: User -> Value
toJSON    = Options -> User -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON    Options
jsonOptions
instance FromJSON User where parseJSON :: Value -> Parser User
parseJSON = Options -> Value -> Parser User
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions

type UserIxs = '[UserId, Username, Email]
type IxUser  = IxSet UserIxs User

instance Indexable UserIxs User where
    indices :: IxList UserIxs User
indices = Ix UserId User
-> Ix Username User -> Ix Email User -> IxList UserIxs User
forall (ixs :: [*]) a r. MkIxList ixs ixs a r => r
ixList
             ((User -> [UserId]) -> Ix UserId User
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((User -> [UserId]) -> Ix UserId User)
-> (User -> [UserId]) -> Ix UserId User
forall a b. (a -> b) -> a -> b
$ (UserId -> [UserId] -> [UserId]
forall a. a -> [a] -> [a]
:[]) (UserId -> [UserId]) -> (User -> UserId) -> User -> [UserId]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting UserId User UserId -> User -> UserId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UserId User UserId
Lens' User UserId
userId)
             ((User -> [Username]) -> Ix Username User
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((User -> [Username]) -> Ix Username User)
-> (User -> [Username]) -> Ix Username User
forall a b. (a -> b) -> a -> b
$ (Username -> [Username] -> [Username]
forall a. a -> [a] -> [a]
:[]) (Username -> [Username])
-> (User -> Username) -> User -> [Username]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting Username User Username -> User -> Username
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Username User Username
Lens' User Username
username)
             ((User -> [Email]) -> Ix Email User
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((User -> [Email]) -> Ix Email User)
-> (User -> [Email]) -> Ix Email User
forall a b. (a -> b) -> a -> b
$ Maybe Email -> [Email]
forall a. Maybe a -> [a]
maybeToList (Maybe Email -> [Email])
-> (User -> Maybe Email) -> User -> [Email]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting (Maybe Email) User (Maybe Email) -> User -> Maybe Email
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Email) User (Maybe Email)
Lens' User (Maybe Email)
email)

------------------------------------------------------------------------------
-- SimpleAddress
------------------------------------------------------------------------------

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

------------------------------------------------------------------------------
-- AuthenticateConfig
------------------------------------------------------------------------------

-- | Various configuration options that apply to all authentication methods
data AuthenticateConfig = AuthenticateConfig
    { AuthenticateConfig -> UserId -> IO Bool
_isAuthAdmin          :: UserId -> IO Bool           -- ^ can user administrate the authentication system?
    , AuthenticateConfig -> Username -> Maybe CoreError
_usernameAcceptable   :: Username -> Maybe CoreError -- ^ enforce username policies, valid email, etc. 'Nothing' == ok, 'Just Text' == error message
    , AuthenticateConfig -> Bool
_requireEmail         :: Bool                        -- ^ require use to supply an email address when creating an account
    , AuthenticateConfig -> Maybe SimpleAddress
_systemFromAddress    :: Maybe SimpleAddress         -- ^ From: line for emails sent by the server
    , AuthenticateConfig -> Maybe SimpleAddress
_systemReplyToAddress :: Maybe SimpleAddress         -- ^ Reply-To: line for emails sent by the server
    , AuthenticateConfig -> Maybe String
_systemSendmailPath   :: Maybe FilePath              -- ^ path to sendmail if it is not \/usr\/sbin\/sendmail
    , AuthenticateConfig -> Maybe Lang
_postLoginRedirect    :: Maybe Text                  -- ^ path to redirect to after a successful login
    , AuthenticateConfig -> Maybe (User -> IO ())
_createUserCallback   :: Maybe (User -> IO ())       -- ^ a function to call when a new user is created. Useful for adding them to mailing lists or other stuff
    }
    deriving (Typeable, (forall x. AuthenticateConfig -> Rep AuthenticateConfig x)
-> (forall x. Rep AuthenticateConfig x -> AuthenticateConfig)
-> Generic AuthenticateConfig
forall x. Rep AuthenticateConfig x -> AuthenticateConfig
forall x. AuthenticateConfig -> Rep AuthenticateConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthenticateConfig x -> AuthenticateConfig
$cfrom :: forall x. AuthenticateConfig -> Rep AuthenticateConfig x
Generic)
makeLenses ''AuthenticateConfig

-- | a very basic policy for 'userAcceptable'
--
-- Enforces:
--
--  'Username' can not be empty
usernamePolicy :: Username
               -> Maybe CoreError
usernamePolicy :: Username -> Maybe CoreError
usernamePolicy Username
username =
    if Lang -> Bool
Text.null (Lang -> Bool) -> Lang -> Bool
forall a b. (a -> b) -> a -> b
$ Username
username Username -> Getting Lang Username Lang -> Lang
forall s a. s -> Getting a s a -> a
^. Getting Lang Username Lang
Iso' Username Lang
unUsername
    then CoreError -> Maybe CoreError
forall a. a -> Maybe a
Just CoreError
UsernameNotAcceptable
    else Maybe CoreError
forall a. Maybe a
Nothing

------------------------------------------------------------------------------
-- SharedSecret
------------------------------------------------------------------------------

-- | The shared secret is used to encrypt a users data on a per-user basis.
-- We can invalidate a JWT value by changing the shared secret.
newtype SharedSecret = SharedSecret { SharedSecret -> Lang
_unSharedSecret :: Text }
      deriving (SharedSecret -> SharedSecret -> Bool
(SharedSecret -> SharedSecret -> Bool)
-> (SharedSecret -> SharedSecret -> Bool) -> Eq SharedSecret
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SharedSecret -> SharedSecret -> Bool
$c/= :: SharedSecret -> SharedSecret -> Bool
== :: SharedSecret -> SharedSecret -> Bool
$c== :: SharedSecret -> SharedSecret -> Bool
Eq, Eq SharedSecret
Eq SharedSecret
-> (SharedSecret -> SharedSecret -> Ordering)
-> (SharedSecret -> SharedSecret -> Bool)
-> (SharedSecret -> SharedSecret -> Bool)
-> (SharedSecret -> SharedSecret -> Bool)
-> (SharedSecret -> SharedSecret -> Bool)
-> (SharedSecret -> SharedSecret -> SharedSecret)
-> (SharedSecret -> SharedSecret -> SharedSecret)
-> Ord SharedSecret
SharedSecret -> SharedSecret -> Bool
SharedSecret -> SharedSecret -> Ordering
SharedSecret -> SharedSecret -> SharedSecret
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 :: SharedSecret -> SharedSecret -> SharedSecret
$cmin :: SharedSecret -> SharedSecret -> SharedSecret
max :: SharedSecret -> SharedSecret -> SharedSecret
$cmax :: SharedSecret -> SharedSecret -> SharedSecret
>= :: SharedSecret -> SharedSecret -> Bool
$c>= :: SharedSecret -> SharedSecret -> Bool
> :: SharedSecret -> SharedSecret -> Bool
$c> :: SharedSecret -> SharedSecret -> Bool
<= :: SharedSecret -> SharedSecret -> Bool
$c<= :: SharedSecret -> SharedSecret -> Bool
< :: SharedSecret -> SharedSecret -> Bool
$c< :: SharedSecret -> SharedSecret -> Bool
compare :: SharedSecret -> SharedSecret -> Ordering
$ccompare :: SharedSecret -> SharedSecret -> Ordering
$cp1Ord :: Eq SharedSecret
Ord, ReadPrec [SharedSecret]
ReadPrec SharedSecret
Int -> ReadS SharedSecret
ReadS [SharedSecret]
(Int -> ReadS SharedSecret)
-> ReadS [SharedSecret]
-> ReadPrec SharedSecret
-> ReadPrec [SharedSecret]
-> Read SharedSecret
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SharedSecret]
$creadListPrec :: ReadPrec [SharedSecret]
readPrec :: ReadPrec SharedSecret
$creadPrec :: ReadPrec SharedSecret
readList :: ReadS [SharedSecret]
$creadList :: ReadS [SharedSecret]
readsPrec :: Int -> ReadS SharedSecret
$creadsPrec :: Int -> ReadS SharedSecret
Read, Int -> SharedSecret -> String -> String
[SharedSecret] -> String -> String
SharedSecret -> String
(Int -> SharedSecret -> String -> String)
-> (SharedSecret -> String)
-> ([SharedSecret] -> String -> String)
-> Show SharedSecret
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SharedSecret] -> String -> String
$cshowList :: [SharedSecret] -> String -> String
show :: SharedSecret -> String
$cshow :: SharedSecret -> String
showsPrec :: Int -> SharedSecret -> String -> String
$cshowsPrec :: Int -> SharedSecret -> String -> String
Show, Typeable SharedSecret
DataType
Constr
Typeable SharedSecret
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> SharedSecret -> c SharedSecret)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SharedSecret)
-> (SharedSecret -> Constr)
-> (SharedSecret -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c SharedSecret))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c SharedSecret))
-> ((forall b. Data b => b -> b) -> SharedSecret -> SharedSecret)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SharedSecret -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SharedSecret -> r)
-> (forall u. (forall d. Data d => d -> u) -> SharedSecret -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> SharedSecret -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret)
-> Data SharedSecret
SharedSecret -> DataType
SharedSecret -> Constr
(forall b. Data b => b -> b) -> SharedSecret -> SharedSecret
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SharedSecret -> c SharedSecret
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SharedSecret
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) -> SharedSecret -> u
forall u. (forall d. Data d => d -> u) -> SharedSecret -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SharedSecret
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SharedSecret -> c SharedSecret
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SharedSecret)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SharedSecret)
$cSharedSecret :: Constr
$tSharedSecret :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
gmapMp :: (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
gmapM :: (forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SharedSecret -> m SharedSecret
gmapQi :: Int -> (forall d. Data d => d -> u) -> SharedSecret -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SharedSecret -> u
gmapQ :: (forall d. Data d => d -> u) -> SharedSecret -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SharedSecret -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SharedSecret -> r
gmapT :: (forall b. Data b => b -> b) -> SharedSecret -> SharedSecret
$cgmapT :: (forall b. Data b => b -> b) -> SharedSecret -> SharedSecret
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SharedSecret)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SharedSecret)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c SharedSecret)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SharedSecret)
dataTypeOf :: SharedSecret -> DataType
$cdataTypeOf :: SharedSecret -> DataType
toConstr :: SharedSecret -> Constr
$ctoConstr :: SharedSecret -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SharedSecret
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SharedSecret
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SharedSecret -> c SharedSecret
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SharedSecret -> c SharedSecret
$cp1Data :: Typeable SharedSecret
Data, Typeable, (forall x. SharedSecret -> Rep SharedSecret x)
-> (forall x. Rep SharedSecret x -> SharedSecret)
-> Generic SharedSecret
forall x. Rep SharedSecret x -> SharedSecret
forall x. SharedSecret -> Rep SharedSecret x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SharedSecret x -> SharedSecret
$cfrom :: forall x. SharedSecret -> Rep SharedSecret x
Generic)
deriveSafeCopy 1 'base ''SharedSecret
makeLenses ''SharedSecret

-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
-- system RNG as a fallback. This is the function used to generate salts by
-- 'makePassword'.
genSharedSecret :: (MonadIO m) => m SharedSecret
genSharedSecret :: m SharedSecret
genSharedSecret = IO SharedSecret -> m SharedSecret
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SharedSecret -> m SharedSecret)
-> IO SharedSecret -> m SharedSecret
forall a b. (a -> b) -> a -> b
$ IO SharedSecret
-> (SomeException -> IO SharedSecret) -> IO SharedSecret
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch IO SharedSecret
genSharedSecretDevURandom (\(SomeException
_::SomeException) -> IO SharedSecret
genSharedSecretSysRandom)

-- | Generate a 'SharedSecret' from @\/dev\/urandom@.
--
-- see: `genSharedSecret`
genSharedSecretDevURandom :: IO SharedSecret
genSharedSecretDevURandom :: IO SharedSecret
genSharedSecretDevURandom = String -> IOMode -> (Handle -> IO SharedSecret) -> IO SharedSecret
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
"/dev/urandom" IOMode
ReadMode ((Handle -> IO SharedSecret) -> IO SharedSecret)
-> (Handle -> IO SharedSecret) -> IO SharedSecret
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
                      ByteString
secret <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
32
                      SharedSecret -> IO SharedSecret
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedSecret -> IO SharedSecret)
-> SharedSecret -> IO SharedSecret
forall a b. (a -> b) -> a -> b
$ Lang -> SharedSecret
SharedSecret (Lang -> SharedSecret)
-> (ByteString -> Lang) -> ByteString -> SharedSecret
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Lang
Text.decodeUtf8 (ByteString -> Lang)
-> (ByteString -> ByteString) -> ByteString -> Lang
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
encode (ByteString -> SharedSecret) -> ByteString -> SharedSecret
forall a b. (a -> b) -> a -> b
$ ByteString
secret

-- | Generate a 'SharedSecret' from 'System.Random'.
--
-- see: `genSharedSecret`
genSharedSecretSysRandom :: IO SharedSecret
genSharedSecretSysRandom :: IO SharedSecret
genSharedSecretSysRandom = IO String
randomChars IO String -> (String -> IO SharedSecret) -> IO SharedSecret
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SharedSecret -> IO SharedSecret
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedSecret -> IO SharedSecret)
-> (String -> SharedSecret) -> String -> IO SharedSecret
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lang -> SharedSecret
SharedSecret (Lang -> SharedSecret)
-> (String -> Lang) -> String -> SharedSecret
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Lang
Text.decodeUtf8 (ByteString -> Lang) -> (String -> ByteString) -> String -> Lang
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> ByteString
B.pack
    where randomChars :: IO String
randomChars = [IO Char] -> IO String
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO Char] -> IO String) -> [IO Char] -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> IO Char -> [IO Char]
forall a. Int -> a -> [a]
replicate Int
32 (IO Char -> [IO Char]) -> IO Char -> [IO Char]
forall a b. (a -> b) -> a -> b
$ (Char, Char) -> IO Char
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Char
'\NUL', Char
'\255')

------------------------------------------------------------------------------
-- SharedSecrets
------------------------------------------------------------------------------

-- | A map which stores the `SharedSecret` for each `UserId`
type SharedSecrets = Map UserId SharedSecret

-- | An empty `SharedSecrets`
initialSharedSecrets :: SharedSecrets
initialSharedSecrets :: SharedSecrets
initialSharedSecrets = SharedSecrets
forall k a. Map k a
Map.empty

------------------------------------------------------------------------------
-- NewAccountMode
------------------------------------------------------------------------------

-- | This value is used to configure the type of new user registrations
-- permitted for this system.
data NewAccountMode
  = OpenRegistration      -- ^ new users can create their own accounts
  | ModeratedRegistration -- ^ new users can apply to create their own accounts, but a moderator must approve them before they are active
  | ClosedRegistration    -- ^ only the admin can create a new account
    deriving (NewAccountMode -> NewAccountMode -> Bool
(NewAccountMode -> NewAccountMode -> Bool)
-> (NewAccountMode -> NewAccountMode -> Bool) -> Eq NewAccountMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewAccountMode -> NewAccountMode -> Bool
$c/= :: NewAccountMode -> NewAccountMode -> Bool
== :: NewAccountMode -> NewAccountMode -> Bool
$c== :: NewAccountMode -> NewAccountMode -> Bool
Eq, Int -> NewAccountMode -> String -> String
[NewAccountMode] -> String -> String
NewAccountMode -> String
(Int -> NewAccountMode -> String -> String)
-> (NewAccountMode -> String)
-> ([NewAccountMode] -> String -> String)
-> Show NewAccountMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NewAccountMode] -> String -> String
$cshowList :: [NewAccountMode] -> String -> String
show :: NewAccountMode -> String
$cshow :: NewAccountMode -> String
showsPrec :: Int -> NewAccountMode -> String -> String
$cshowsPrec :: Int -> NewAccountMode -> String -> String
Show, Typeable, (forall x. NewAccountMode -> Rep NewAccountMode x)
-> (forall x. Rep NewAccountMode x -> NewAccountMode)
-> Generic NewAccountMode
forall x. Rep NewAccountMode x -> NewAccountMode
forall x. NewAccountMode -> Rep NewAccountMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NewAccountMode x -> NewAccountMode
$cfrom :: forall x. NewAccountMode -> Rep NewAccountMode x
Generic)
deriveSafeCopy 1 'base ''NewAccountMode

------------------------------------------------------------------------------
-- AuthenticateState
------------------------------------------------------------------------------

-- | this acid-state value contains the state common to all
-- authentication methods
data AuthenticateState = AuthenticateState
    { AuthenticateState -> SharedSecrets
_sharedSecrets             :: SharedSecrets
    , AuthenticateState -> IxUser
_users                     :: IxUser
    , AuthenticateState -> UserId
_nextUserId                :: UserId
    , AuthenticateState -> Int
_defaultSessionTimeout     :: Int     -- ^ default session time out in seconds
    , AuthenticateState -> NewAccountMode
_newAccountMode            :: NewAccountMode
    }
    deriving (AuthenticateState -> AuthenticateState -> Bool
(AuthenticateState -> AuthenticateState -> Bool)
-> (AuthenticateState -> AuthenticateState -> Bool)
-> Eq AuthenticateState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthenticateState -> AuthenticateState -> Bool
$c/= :: AuthenticateState -> AuthenticateState -> Bool
== :: AuthenticateState -> AuthenticateState -> Bool
$c== :: AuthenticateState -> AuthenticateState -> Bool
Eq, Int -> AuthenticateState -> String -> String
[AuthenticateState] -> String -> String
AuthenticateState -> String
(Int -> AuthenticateState -> String -> String)
-> (AuthenticateState -> String)
-> ([AuthenticateState] -> String -> String)
-> Show AuthenticateState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AuthenticateState] -> String -> String
$cshowList :: [AuthenticateState] -> String -> String
show :: AuthenticateState -> String
$cshow :: AuthenticateState -> String
showsPrec :: Int -> AuthenticateState -> String -> String
$cshowsPrec :: Int -> AuthenticateState -> String -> String
Show, Typeable, (forall x. AuthenticateState -> Rep AuthenticateState x)
-> (forall x. Rep AuthenticateState x -> AuthenticateState)
-> Generic AuthenticateState
forall x. Rep AuthenticateState x -> AuthenticateState
forall x. AuthenticateState -> Rep AuthenticateState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthenticateState x -> AuthenticateState
$cfrom :: forall x. AuthenticateState -> Rep AuthenticateState x
Generic)
deriveSafeCopy 1 'base ''AuthenticateState
makeLenses ''AuthenticateState

-- | a reasonable initial 'AuthenticateState'
initialAuthenticateState :: AuthenticateState
initialAuthenticateState :: AuthenticateState
initialAuthenticateState = AuthenticateState :: SharedSecrets
-> IxUser -> UserId -> Int -> NewAccountMode -> AuthenticateState
AuthenticateState
    { _sharedSecrets :: SharedSecrets
_sharedSecrets             = SharedSecrets
initialSharedSecrets
    , _users :: IxUser
_users                     = IxUser
forall (ixs :: [*]) a. Indexable ixs a => IxSet ixs a
IxSet.empty
    , _nextUserId :: UserId
_nextUserId                = Integer -> UserId
UserId Integer
1
    , _defaultSessionTimeout :: Int
_defaultSessionTimeout     = Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60
    , _newAccountMode :: NewAccountMode
_newAccountMode            = NewAccountMode
OpenRegistration
    }

------------------------------------------------------------------------------
-- SharedSecrets AcidState Methods
------------------------------------------------------------------------------

-- | set the 'SharedSecret' for 'UserId' overwritten any previous secret.
setSharedSecret :: UserId
                -> SharedSecret
                -> Update AuthenticateState ()
setSharedSecret :: UserId -> SharedSecret -> Update AuthenticateState ()
setSharedSecret UserId
userId SharedSecret
sharedSecret =
  (SharedSecrets -> Identity SharedSecrets)
-> AuthenticateState -> Identity AuthenticateState
Lens' AuthenticateState SharedSecrets
sharedSecrets ((SharedSecrets -> Identity SharedSecrets)
 -> AuthenticateState -> Identity AuthenticateState)
-> ((Maybe SharedSecret -> Identity (Maybe SharedSecret))
    -> SharedSecrets -> Identity SharedSecrets)
-> (Maybe SharedSecret -> Identity (Maybe SharedSecret))
-> AuthenticateState
-> Identity AuthenticateState
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Index SharedSecrets
-> Lens' SharedSecrets (Maybe (IxValue SharedSecrets))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SharedSecrets
UserId
userId ((Maybe SharedSecret -> Identity (Maybe SharedSecret))
 -> AuthenticateState -> Identity AuthenticateState)
-> SharedSecret -> Update AuthenticateState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= SharedSecret
sharedSecret

-- | get the 'SharedSecret' for 'UserId'
getSharedSecret :: UserId
                -> Query AuthenticateState (Maybe SharedSecret)
getSharedSecret :: UserId -> Query AuthenticateState (Maybe SharedSecret)
getSharedSecret UserId
userId =
  Getting (Maybe SharedSecret) AuthenticateState (Maybe SharedSecret)
-> Query AuthenticateState (Maybe SharedSecret)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SharedSecrets -> Const (Maybe SharedSecret) SharedSecrets)
-> AuthenticateState
-> Const (Maybe SharedSecret) AuthenticateState
Lens' AuthenticateState SharedSecrets
sharedSecrets ((SharedSecrets -> Const (Maybe SharedSecret) SharedSecrets)
 -> AuthenticateState
 -> Const (Maybe SharedSecret) AuthenticateState)
-> ((Maybe SharedSecret
     -> Const (Maybe SharedSecret) (Maybe SharedSecret))
    -> SharedSecrets -> Const (Maybe SharedSecret) SharedSecrets)
-> Getting
     (Maybe SharedSecret) AuthenticateState (Maybe SharedSecret)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Index SharedSecrets
-> Lens' SharedSecrets (Maybe (IxValue SharedSecrets))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SharedSecrets
UserId
userId)

------------------------------------------------------------------------------
-- SessionTimeout AcidState Methods
------------------------------------------------------------------------------

-- | set the default inactivity timeout for new sessions
setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180)
               -> Update AuthenticateState ()
setDefaultSessionTimeout :: Int -> Update AuthenticateState ()
setDefaultSessionTimeout Int
newTimeout =
    (AuthenticateState -> AuthenticateState)
-> Update AuthenticateState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AuthenticateState -> AuthenticateState)
 -> Update AuthenticateState ())
-> (AuthenticateState -> AuthenticateState)
-> Update AuthenticateState ()
forall a b. (a -> b) -> a -> b
$ \as :: AuthenticateState
as@AuthenticateState{Int
SharedSecrets
IxUser
UserId
NewAccountMode
_newAccountMode :: NewAccountMode
_defaultSessionTimeout :: Int
_nextUserId :: UserId
_users :: IxUser
_sharedSecrets :: SharedSecrets
_newAccountMode :: AuthenticateState -> NewAccountMode
_defaultSessionTimeout :: AuthenticateState -> Int
_nextUserId :: AuthenticateState -> UserId
_users :: AuthenticateState -> IxUser
_sharedSecrets :: AuthenticateState -> SharedSecrets
..} -> AuthenticateState
as { _defaultSessionTimeout :: Int
_defaultSessionTimeout = Int
newTimeout }

-- | set the default inactivity timeout for new sessions
getDefaultSessionTimeout :: Query AuthenticateState Int
getDefaultSessionTimeout :: Query AuthenticateState Int
getDefaultSessionTimeout =
    Getting Int AuthenticateState Int -> AuthenticateState -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int AuthenticateState Int
Lens' AuthenticateState Int
defaultSessionTimeout (AuthenticateState -> Int)
-> Query AuthenticateState AuthenticateState
-> Query AuthenticateState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query AuthenticateState AuthenticateState
forall r (m :: * -> *). MonadReader r m => m r
ask

------------------------------------------------------------------------------
-- NewAccountMode AcidState Methods
------------------------------------------------------------------------------

-- | set the 'NewAccountMode'
setNewAccountMode :: NewAccountMode
                  -> Update AuthenticateState ()
setNewAccountMode :: NewAccountMode -> Update AuthenticateState ()
setNewAccountMode NewAccountMode
mode =
  (NewAccountMode -> Identity NewAccountMode)
-> AuthenticateState -> Identity AuthenticateState
Lens' AuthenticateState NewAccountMode
newAccountMode ((NewAccountMode -> Identity NewAccountMode)
 -> AuthenticateState -> Identity AuthenticateState)
-> NewAccountMode -> Update AuthenticateState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= NewAccountMode
mode

-- | get the 'NewAccountMode'
getNewAccountMode :: Query AuthenticateState NewAccountMode
getNewAccountMode :: Query AuthenticateState NewAccountMode
getNewAccountMode =
  Getting NewAccountMode AuthenticateState NewAccountMode
-> Query AuthenticateState NewAccountMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NewAccountMode AuthenticateState NewAccountMode
Lens' AuthenticateState NewAccountMode
newAccountMode

------------------------------------------------------------------------------
-- User related AcidState Methods
------------------------------------------------------------------------------

-- | Create a new 'User'. This will allocate a new 'UserId'. The
-- returned 'User' value will have the updated 'UserId'.
createUser :: User
           -> Update AuthenticateState (Either CoreError User)
createUser :: User -> Update AuthenticateState (Either CoreError User)
createUser User
u =
    do as :: AuthenticateState
as@AuthenticateState{Int
SharedSecrets
IxUser
UserId
NewAccountMode
_newAccountMode :: NewAccountMode
_defaultSessionTimeout :: Int
_nextUserId :: UserId
_users :: IxUser
_sharedSecrets :: SharedSecrets
_newAccountMode :: AuthenticateState -> NewAccountMode
_defaultSessionTimeout :: AuthenticateState -> Int
_nextUserId :: AuthenticateState -> UserId
_users :: AuthenticateState -> IxUser
_sharedSecrets :: AuthenticateState -> SharedSecrets
..} <- Update AuthenticateState AuthenticateState
forall s (m :: * -> *). MonadState s m => m s
get
       if IxUser -> Bool
forall (ixs :: [*]) a. IxSet ixs a -> Bool
IxSet.null (IxUser -> Bool) -> IxUser -> Bool
forall a b. (a -> b) -> a -> b
$ (AuthenticateState
as AuthenticateState
-> Getting IxUser AuthenticateState IxUser -> IxUser
forall s a. s -> Getting a s a -> a
^. Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users) IxUser -> Username -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= (User
u User -> Getting Username User Username -> Username
forall s a. s -> Getting a s a -> a
^. Getting Username User Username
Lens' User Username
username)
         then do let user' :: User
user' = ASetter User User UserId UserId -> UserId -> User -> User
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter User User UserId UserId
Lens' User UserId
userId UserId
_nextUserId User
u
                     as' :: AuthenticateState
as' = AuthenticateState
as { _users :: IxUser
_users      = User -> IxUser -> IxUser
forall (ixs :: [*]) a.
Indexable ixs a =>
a -> IxSet ixs a -> IxSet ixs a
IxSet.insert User
user' IxUser
_users
                              , _nextUserId :: UserId
_nextUserId = UserId -> UserId
forall a. Enum a => a -> a
succ UserId
_nextUserId
                              }
                 AuthenticateState -> Update AuthenticateState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AuthenticateState
as'
                 Either CoreError User
-> Update AuthenticateState (Either CoreError User)
forall (m :: * -> *) a. Monad m => a -> m a
return (User -> Either CoreError User
forall a b. b -> Either a b
Right User
user')
         else
             Either CoreError User
-> Update AuthenticateState (Either CoreError User)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreError -> Either CoreError User
forall a b. a -> Either a b
Left CoreError
UsernameAlreadyExists)

-- | Create a new 'User'. This will allocate a new 'UserId'. The
-- returned 'User' value will have the updated 'UserId'.
createAnonymousUser :: Update AuthenticateState User
createAnonymousUser :: Update AuthenticateState User
createAnonymousUser =
  do as :: AuthenticateState
as@AuthenticateState{Int
SharedSecrets
IxUser
UserId
NewAccountMode
_newAccountMode :: NewAccountMode
_defaultSessionTimeout :: Int
_nextUserId :: UserId
_users :: IxUser
_sharedSecrets :: SharedSecrets
_newAccountMode :: AuthenticateState -> NewAccountMode
_defaultSessionTimeout :: AuthenticateState -> Int
_nextUserId :: AuthenticateState -> UserId
_users :: AuthenticateState -> IxUser
_sharedSecrets :: AuthenticateState -> SharedSecrets
..} <- Update AuthenticateState AuthenticateState
forall s (m :: * -> *). MonadState s m => m s
get
     let user :: User
user = User :: UserId -> Username -> Maybe Email -> User
User { _userId :: UserId
_userId   = UserId
_nextUserId
                     , _username :: Username
_username = Lang -> Username
Username (Lang
"Anonymous " Lang -> Lang -> Lang
forall a. Semigroup a => a -> a -> a
<> String -> Lang
Text.pack (UserId -> String
forall a. Show a => a -> String
show UserId
_nextUserId))
                     , _email :: Maybe Email
_email    = Maybe Email
forall a. Maybe a
Nothing
                     }
         as' :: AuthenticateState
as' = AuthenticateState
as { _users :: IxUser
_users      = User -> IxUser -> IxUser
forall (ixs :: [*]) a.
Indexable ixs a =>
a -> IxSet ixs a -> IxSet ixs a
IxSet.insert User
user IxUser
_users
                  , _nextUserId :: UserId
_nextUserId = UserId -> UserId
forall a. Enum a => a -> a
succ UserId
_nextUserId
                  }
     AuthenticateState -> Update AuthenticateState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AuthenticateState
as'
     User -> Update AuthenticateState User
forall (m :: * -> *) a. Monad m => a -> m a
return User
user

-- | Update an existing 'User'. Must already have a valid 'UserId'.
updateUser :: User
           -> Update AuthenticateState ()
updateUser :: User -> Update AuthenticateState ()
updateUser User
u =
  do as :: AuthenticateState
as@AuthenticateState{Int
SharedSecrets
IxUser
UserId
NewAccountMode
_newAccountMode :: NewAccountMode
_defaultSessionTimeout :: Int
_nextUserId :: UserId
_users :: IxUser
_sharedSecrets :: SharedSecrets
_newAccountMode :: AuthenticateState -> NewAccountMode
_defaultSessionTimeout :: AuthenticateState -> Int
_nextUserId :: AuthenticateState -> UserId
_users :: AuthenticateState -> IxUser
_sharedSecrets :: AuthenticateState -> SharedSecrets
..} <- Update AuthenticateState AuthenticateState
forall s (m :: * -> *). MonadState s m => m s
get
     let as' :: AuthenticateState
as' = AuthenticateState
as { _users :: IxUser
_users = UserId -> User -> IxUser -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
ix -> a -> IxSet ixs a -> IxSet ixs a
IxSet.updateIx (User
u User -> Getting UserId User UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId User UserId
Lens' User UserId
userId) User
u IxUser
_users
                  }
     AuthenticateState -> Update AuthenticateState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AuthenticateState
as'

-- | Delete 'User' with the specified 'UserId'
deleteUser :: UserId
           -> Update AuthenticateState ()
deleteUser :: UserId -> Update AuthenticateState ()
deleteUser UserId
uid =
  do as :: AuthenticateState
as@AuthenticateState{Int
SharedSecrets
IxUser
UserId
NewAccountMode
_newAccountMode :: NewAccountMode
_defaultSessionTimeout :: Int
_nextUserId :: UserId
_users :: IxUser
_sharedSecrets :: SharedSecrets
_newAccountMode :: AuthenticateState -> NewAccountMode
_defaultSessionTimeout :: AuthenticateState -> Int
_nextUserId :: AuthenticateState -> UserId
_users :: AuthenticateState -> IxUser
_sharedSecrets :: AuthenticateState -> SharedSecrets
..} <- Update AuthenticateState AuthenticateState
forall s (m :: * -> *). MonadState s m => m s
get
     let as' :: AuthenticateState
as' = AuthenticateState
as { _users :: IxUser
_users = UserId -> IxUser -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
ix -> IxSet ixs a -> IxSet ixs a
IxSet.deleteIx UserId
uid IxUser
_users
                  }
     AuthenticateState -> Update AuthenticateState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AuthenticateState
as'

-- | look up a 'User' by their 'Username'
getUserByUsername :: Username
                  -> Query AuthenticateState (Maybe User)
getUserByUsername :: Username -> Query AuthenticateState (Maybe User)
getUserByUsername Username
username =
    do IxUser
us <- Getting IxUser AuthenticateState IxUser
-> Query AuthenticateState IxUser
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users
       Maybe User -> Query AuthenticateState (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe User -> Query AuthenticateState (Maybe User))
-> Maybe User -> Query AuthenticateState (Maybe User)
forall a b. (a -> b) -> a -> b
$ IxUser -> Maybe User
forall a (ixs :: [*]). Ord a => IxSet ixs a -> Maybe a
getOne (IxUser -> Maybe User) -> IxUser -> Maybe User
forall a b. (a -> b) -> a -> b
$ IxUser
us IxUser -> Username -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= Username
username

-- | look up a 'User' by their 'UserId'
getUserByUserId :: UserId
                  -> Query AuthenticateState (Maybe User)
getUserByUserId :: UserId -> Query AuthenticateState (Maybe User)
getUserByUserId UserId
userId =
    do IxUser
us <- Getting IxUser AuthenticateState IxUser
-> Query AuthenticateState IxUser
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users
       Maybe User -> Query AuthenticateState (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe User -> Query AuthenticateState (Maybe User))
-> Maybe User -> Query AuthenticateState (Maybe User)
forall a b. (a -> b) -> a -> b
$ IxUser -> Maybe User
forall a (ixs :: [*]). Ord a => IxSet ixs a -> Maybe a
getOne (IxUser -> Maybe User) -> IxUser -> Maybe User
forall a b. (a -> b) -> a -> b
$ IxUser
us IxUser -> UserId -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= UserId
userId

-- | find all 'Users'
--
getUsers :: Query AuthenticateState (Set User)
getUsers :: Query AuthenticateState (Set User)
getUsers =
    do IxUser
us <- Getting IxUser AuthenticateState IxUser
-> Query AuthenticateState IxUser
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users
       Set User -> Query AuthenticateState (Set User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set User -> Query AuthenticateState (Set User))
-> Set User -> Query AuthenticateState (Set User)
forall a b. (a -> b) -> a -> b
$ IxUser -> Set User
forall (ixs :: [*]) a. IxSet ixs a -> Set a
toSet (IxUser -> Set User) -> IxUser -> Set User
forall a b. (a -> b) -> a -> b
$ IxUser
us

-- | look up a 'User' by their 'Email'
--
-- NOTE: if the email is associated with more than one account this will return 'Nothing'
getUserByEmail :: Email
               -> Query AuthenticateState (Maybe User)
getUserByEmail :: Email -> Query AuthenticateState (Maybe User)
getUserByEmail Email
email =
    do IxUser
us <- Getting IxUser AuthenticateState IxUser
-> Query AuthenticateState IxUser
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users
       Maybe User -> Query AuthenticateState (Maybe User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe User -> Query AuthenticateState (Maybe User))
-> Maybe User -> Query AuthenticateState (Maybe User)
forall a b. (a -> b) -> a -> b
$ IxUser -> Maybe User
forall a (ixs :: [*]). Ord a => IxSet ixs a -> Maybe a
getOne (IxUser -> Maybe User) -> IxUser -> Maybe User
forall a b. (a -> b) -> a -> b
$ IxUser
us IxUser -> Email -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= Email
email

-- | find all 'Users' which match 'Email'
--
getUsersByEmail :: Email
               -> Query AuthenticateState (Set User)
getUsersByEmail :: Email -> Query AuthenticateState (Set User)
getUsersByEmail Email
email =
    do IxUser
us <- Getting IxUser AuthenticateState IxUser
-> Query AuthenticateState IxUser
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting IxUser AuthenticateState IxUser
Lens' AuthenticateState IxUser
users
       Set User -> Query AuthenticateState (Set User)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set User -> Query AuthenticateState (Set User))
-> Set User -> Query AuthenticateState (Set User)
forall a b. (a -> b) -> a -> b
$ IxUser -> Set User
forall (ixs :: [*]) a. IxSet ixs a -> Set a
toSet (IxUser -> Set User) -> IxUser -> Set User
forall a b. (a -> b) -> a -> b
$ IxUser
us IxUser -> Email -> IxUser
forall (ixs :: [*]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= Email
email

-- | get the entire AuthenticateState value
getAuthenticateState :: Query AuthenticateState AuthenticateState
getAuthenticateState :: Query AuthenticateState AuthenticateState
getAuthenticateState = Query AuthenticateState AuthenticateState
forall r (m :: * -> *). MonadReader r m => m r
ask

makeAcidic ''AuthenticateState
    [ 'setDefaultSessionTimeout
    , 'getDefaultSessionTimeout
    , 'setSharedSecret
    , 'getSharedSecret
    , 'setNewAccountMode
    , 'getNewAccountMode
    , 'createUser
    , 'createAnonymousUser
    , 'updateUser
    , 'deleteUser
    , 'getUserByUsername
    , 'getUserByUserId
    , 'getUsers
    , 'getUserByEmail
    , 'getUsersByEmail
    , 'getAuthenticateState
    ]

------------------------------------------------------------------------------
-- Shared Secret Functions
------------------------------------------------------------------------------

-- | get the 'SharedSecret' for 'UserId'. Generate one if they don't have one yet.
getOrGenSharedSecret :: (MonadIO m) =>
                        AcidState AuthenticateState
                     -> UserId
                     -> m (SharedSecret)
getOrGenSharedSecret :: AcidState AuthenticateState -> UserId -> m SharedSecret
getOrGenSharedSecret AcidState AuthenticateState
authenticateState UserId
uid =
 do Maybe SharedSecret
mSSecret <- AcidState (EventState GetSharedSecret)
-> GetSharedSecret -> m (EventResult GetSharedSecret)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetSharedSecret)
AcidState AuthenticateState
authenticateState (UserId -> GetSharedSecret
GetSharedSecret UserId
uid)
    case Maybe SharedSecret
mSSecret of
      (Just SharedSecret
ssecret) -> SharedSecret -> m SharedSecret
forall (m :: * -> *) a. Monad m => a -> m a
return SharedSecret
ssecret
      Maybe SharedSecret
Nothing -> do
        SharedSecret
ssecret <- m SharedSecret
forall (m :: * -> *). MonadIO m => m SharedSecret
genSharedSecret
        AcidState (EventState SetSharedSecret)
-> SetSharedSecret -> m (EventResult SetSharedSecret)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState SetSharedSecret)
AcidState AuthenticateState
authenticateState (UserId -> SharedSecret -> SetSharedSecret
SetSharedSecret UserId
uid SharedSecret
ssecret)
        SharedSecret -> m SharedSecret
forall (m :: * -> *) a. Monad m => a -> m a
return SharedSecret
ssecret

------------------------------------------------------------------------------
-- Token Functions
------------------------------------------------------------------------------

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

-- | `TokenText` is the encrypted form of the `Token` which is passed
-- between the server and the client.
type TokenText = Text

-- | create a `Token` for `User`
--
-- The @isAuthAdmin@ paramater is a function which will be called to
-- determine if `UserId` is a user who should be given Administrator
-- privileges. This includes the ability to things such as set the
-- `OpenId` realm, change the registeration mode, etc.
issueToken :: (MonadIO m) =>
              AcidState AuthenticateState
           -> AuthenticateConfig
           -> User                         -- ^ the user
           -> m TokenText
issueToken :: AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
issueToken AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig User
user =
  do SharedSecret
ssecret <- AcidState AuthenticateState -> UserId -> m SharedSecret
forall (m :: * -> *).
MonadIO m =>
AcidState AuthenticateState -> UserId -> m SharedSecret
getOrGenSharedSecret AcidState AuthenticateState
authenticateState (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)
     Bool
admin   <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (AuthenticateConfig
authenticateConfig AuthenticateConfig
-> Getting
     (UserId -> IO Bool) AuthenticateConfig (UserId -> IO Bool)
-> UserId
-> IO Bool
forall s a. s -> Getting a s a -> a
^. Getting (UserId -> IO Bool) AuthenticateConfig (UserId -> IO Bool)
Lens' AuthenticateConfig (UserId -> IO Bool)
isAuthAdmin) (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)
     UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
     let claims :: JWTClaimsSet
claims = JWTClaimsSet :: Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe IntDate
-> Maybe IntDate
-> Maybe IntDate
-> Maybe StringOrURI
-> ClaimsMap
-> JWTClaimsSet
JWTClaimsSet
                   { iss :: Maybe StringOrURI
iss = Maybe StringOrURI
forall a. Maybe a
Nothing
                   , sub :: Maybe StringOrURI
sub = Maybe StringOrURI
forall a. Maybe a
Nothing
                   , aud :: Maybe (Either StringOrURI [StringOrURI])
aud = Maybe (Either StringOrURI [StringOrURI])
forall a. Maybe a
Nothing
                   , exp :: Maybe IntDate
exp = NominalDiffTime -> Maybe IntDate
intDate (NominalDiffTime -> Maybe IntDate)
-> NominalDiffTime -> Maybe IntDate
forall a b. (a -> b) -> a -> b
$ UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
30) UTCTime
now)
                   , nbf :: Maybe IntDate
nbf = Maybe IntDate
forall a. Maybe a
Nothing
                   , iat :: Maybe IntDate
iat = Maybe IntDate
forall a. Maybe a
Nothing
                   , jti :: Maybe StringOrURI
jti = Maybe StringOrURI
forall a. Maybe a
Nothing
                   , unregisteredClaims :: ClaimsMap
unregisteredClaims =
#if MIN_VERSION_jwt(0,8,0)
                         Map Lang Value -> ClaimsMap
ClaimsMap (Map Lang Value -> ClaimsMap) -> Map Lang Value -> ClaimsMap
forall a b. (a -> b) -> a -> b
$
#endif
                           [(Lang, Value)] -> Map Lang Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Lang
"user"     , User -> Value
forall a. ToJSON a => a -> Value
toJSON User
user)
                                        , (Lang
"authAdmin", Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
admin)
                                        ]
                   }
#if MIN_VERSION_jwt(0,10,0)
     Lang -> m Lang
forall (m :: * -> *) a. Monad m => a -> m a
return (Lang -> m Lang) -> Lang -> m Lang
forall a b. (a -> b) -> a -> b
$ Signer -> JOSEHeader -> JWTClaimsSet -> Lang
encodeSigned (Lang -> Signer
hmacSecret (Lang -> Signer) -> Lang -> Signer
forall a b. (a -> b) -> a -> b
$ SharedSecret -> Lang
_unSharedSecret SharedSecret
ssecret) JOSEHeader
forall a. Monoid a => a
mempty JWTClaimsSet
claims
#elif MIN_VERSION_jwt(0,9,0)
     return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims
#else
     return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims
#endif

-- | decode and verify the `TokenText`. If successful, return the
-- `Token` otherwise `Nothing`.
decodeAndVerifyToken :: (MonadIO m) =>
                        AcidState AuthenticateState
                     -> UTCTime
                     -> TokenText
                     -> m (Maybe (Token, JWT VerifiedJWT))
decodeAndVerifyToken :: AcidState AuthenticateState
-> UTCTime -> Lang -> m (Maybe (Token, JWT VerifiedJWT))
decodeAndVerifyToken AcidState AuthenticateState
authenticateState UTCTime
now Lang
token =
  do -- decode unverified token
     let mUnverified :: Maybe (JWT UnverifiedJWT)
mUnverified = Lang -> Maybe (JWT UnverifiedJWT)
decode Lang
token
     case Maybe (JWT UnverifiedJWT)
mUnverified of
       Maybe (JWT UnverifiedJWT)
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
       (Just JWT UnverifiedJWT
unverified) ->
         -- check that token has user claim
         case Lang -> Map Lang Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
"user" (ClaimsMap -> Map Lang Value
unClaimsMap (JWTClaimsSet -> ClaimsMap
unregisteredClaims (JWT UnverifiedJWT -> JWTClaimsSet
forall r. JWT r -> JWTClaimsSet
claims JWT UnverifiedJWT
unverified))) of
           Maybe Value
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
           (Just Value
uv) ->
             -- decode user json value
             case Value -> Result User
forall a. FromJSON a => Value -> Result a
fromJSON Value
uv of
               (Error String
_) -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
               (Success User
u) ->
                 do -- get the shared secret for userId
                    Maybe SharedSecret
mssecret <- AcidState (EventState GetSharedSecret)
-> GetSharedSecret -> m (EventResult GetSharedSecret)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState GetSharedSecret)
AcidState AuthenticateState
authenticateState (UserId -> GetSharedSecret
GetSharedSecret (User
u User -> Getting UserId User UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId User UserId
Lens' User UserId
userId))
                    case Maybe SharedSecret
mssecret of
                      Maybe SharedSecret
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
                      (Just SharedSecret
ssecret) ->
                        -- finally we can verify all the claims
#if MIN_VERSION_jwt(0,8,0)
                        case Signer -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)
verify (Lang -> Signer
hmacSecret (SharedSecret -> Lang
_unSharedSecret SharedSecret
ssecret)) JWT UnverifiedJWT
unverified of
#else
                        case verify (secret (_unSharedSecret ssecret)) unverified of
#endif
                          Maybe (JWT VerifiedJWT)
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
                          (Just JWT VerifiedJWT
verified) -> -- check expiration
                            case JWTClaimsSet -> Maybe IntDate
exp (JWT VerifiedJWT -> JWTClaimsSet
forall r. JWT r -> JWTClaimsSet
claims JWT VerifiedJWT
verified) of
                            -- exp field missing, expire now
                              Maybe IntDate
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
                              (Just IntDate
exp') ->
                                if (UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
now) NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> (IntDate -> NominalDiffTime
secondsSinceEpoch IntDate
exp')
                                then Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
                                else case Lang -> Map Lang Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Lang
"authAdmin" (ClaimsMap -> Map Lang Value
unClaimsMap (JWTClaimsSet -> ClaimsMap
unregisteredClaims (JWT VerifiedJWT -> JWTClaimsSet
forall r. JWT r -> JWTClaimsSet
claims JWT VerifiedJWT
verified))) of
                                       Maybe Value
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Token, JWT VerifiedJWT) -> Maybe (Token, JWT VerifiedJWT)
forall a. a -> Maybe a
Just (User -> Bool -> Token
Token User
u Bool
False, JWT VerifiedJWT
verified))
                                       (Just Value
a) ->
                                           case Value -> Result Bool
forall a. FromJSON a => Value -> Result a
fromJSON Value
a of
                                             (Error String
_) -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Token, JWT VerifiedJWT) -> Maybe (Token, JWT VerifiedJWT)
forall a. a -> Maybe a
Just (User -> Bool -> Token
Token User
u Bool
False, JWT VerifiedJWT
verified))
                                             (Success Bool
b) -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Token, JWT VerifiedJWT) -> Maybe (Token, JWT VerifiedJWT)
forall a. a -> Maybe a
Just (User -> Bool -> Token
Token User
u Bool
b, JWT VerifiedJWT
verified))

------------------------------------------------------------------------------
-- Token in a Cookie
------------------------------------------------------------------------------

-- | name of the `Cookie` used to hold the `TokenText`
authCookieName :: String
authCookieName :: String
authCookieName = String
"atc"

-- | create a `Token` for `User` and add a `Cookie` to the `Response`
--
-- see also: `issueToken`
addTokenCookie :: (Happstack m) =>
                  AcidState AuthenticateState
               -> AuthenticateConfig
               -> User
               -> m TokenText
addTokenCookie :: AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
addTokenCookie AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig User
user =
  do Lang
token <- AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
forall (m :: * -> *).
MonadIO m =>
AcidState AuthenticateState -> AuthenticateConfig -> User -> m Lang
issueToken AcidState AuthenticateState
authenticateState AuthenticateConfig
authenticateConfig User
user
     Bool
s <- Request -> Bool
rqSecure (Request -> Bool) -> m Request -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq -- FIXME: this isn't that accurate in the face of proxies
     CookieLife -> Cookie -> m ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge (Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
24Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
30)) ((String -> String -> Cookie
mkCookie String
authCookieName (Lang -> String
Text.unpack Lang
token)) { secure :: Bool
secure = Bool
s })
--     addCookie (MaxAge 60) ((mkCookie authCookieName (Text.unpack token)) { secure = s })
     Lang -> m Lang
forall (m :: * -> *) a. Monad m => a -> m a
return Lang
token

-- | delete the `Token` `Cookie`
deleteTokenCookie  :: (Happstack m) =>
                      m ()
deleteTokenCookie :: m ()
deleteTokenCookie =
  String -> m ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie String
authCookieName


-- | get, decode, and verify the `Token` from the `Cookie`.
getTokenCookie :: (Happstack m) =>
                   AcidState AuthenticateState
                -> m (Maybe (Token, JWT VerifiedJWT))
getTokenCookie :: AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getTokenCookie AcidState AuthenticateState
authenticateState =
  do Maybe String
mToken <- m String -> m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m String -> m (Maybe String)) -> m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> m String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue String
authCookieName
     case Maybe String
mToken of
       Maybe String
Nothing      -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
       (Just String
token) ->
           do UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              AcidState AuthenticateState
-> UTCTime -> Lang -> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
MonadIO m =>
AcidState AuthenticateState
-> UTCTime -> Lang -> m (Maybe (Token, JWT VerifiedJWT))
decodeAndVerifyToken AcidState AuthenticateState
authenticateState UTCTime
now (String -> Lang
Text.pack String
token)


------------------------------------------------------------------------------
-- Token in a Header
------------------------------------------------------------------------------

-- | get, decode, and verify the `Token` from the @Authorization@ HTTP header
getTokenHeader :: (Happstack m) =>
                  AcidState AuthenticateState
               -> m (Maybe (Token, JWT VerifiedJWT))
getTokenHeader :: AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getTokenHeader AcidState AuthenticateState
authenticateState =
  do Maybe ByteString
mAuth <- String -> m (Maybe ByteString)
forall (m :: * -> *).
ServerMonad m =>
String -> m (Maybe ByteString)
getHeaderM String
"Authorization"
     case Maybe ByteString
mAuth of
       Maybe ByteString
Nothing -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Token, JWT VerifiedJWT)
forall a. Maybe a
Nothing
       (Just ByteString
auth') ->
         do let auth :: ByteString
auth = Int -> ByteString -> ByteString
B.drop Int
7 ByteString
auth'
            UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            AcidState AuthenticateState
-> UTCTime -> Lang -> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
MonadIO m =>
AcidState AuthenticateState
-> UTCTime -> Lang -> m (Maybe (Token, JWT VerifiedJWT))
decodeAndVerifyToken AcidState AuthenticateState
authenticateState UTCTime
now (ByteString -> Lang
Text.decodeUtf8 ByteString
auth)

------------------------------------------------------------------------------
-- Token in a Header or Cookie
------------------------------------------------------------------------------

-- | get, decode, and verify the `Token` looking first in the
-- @Authorization@ header and then in `Cookie`.
--
-- see also: `getTokenHeader`, `getTokenCookie`
getToken :: (Happstack m) =>
            AcidState AuthenticateState
         -> m (Maybe (Token, JWT VerifiedJWT))
getToken :: AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getToken AcidState AuthenticateState
authenticateState =
  do Maybe (Token, JWT VerifiedJWT)
mToken <- AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getTokenHeader AcidState AuthenticateState
authenticateState
     case Maybe (Token, JWT VerifiedJWT)
mToken of
       Maybe (Token, JWT VerifiedJWT)
Nothing      -> AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getTokenCookie AcidState AuthenticateState
authenticateState
       (Just (Token, JWT VerifiedJWT)
token) -> Maybe (Token, JWT VerifiedJWT)
-> m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Token, JWT VerifiedJWT) -> Maybe (Token, JWT VerifiedJWT)
forall a. a -> Maybe a
Just (Token, JWT VerifiedJWT)
token)

------------------------------------------------------------------------------
-- helper function: calls `getToken` but only returns the `UserId`
------------------------------------------------------------------------------

-- | get the `UserId`
--
-- calls `getToken` but returns only the `UserId`
getUserId :: (Happstack m) =>
             AcidState AuthenticateState
          -> m (Maybe UserId)
getUserId :: AcidState AuthenticateState -> m (Maybe UserId)
getUserId AcidState AuthenticateState
authenticateState =
  do Maybe (Token, JWT VerifiedJWT)
mToken <- 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)
mToken of
       Maybe (Token, JWT VerifiedJWT)
Nothing       -> Maybe UserId -> m (Maybe UserId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserId
forall a. Maybe a
Nothing
       (Just (Token
token, JWT VerifiedJWT
_)) -> Maybe UserId -> m (Maybe UserId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserId -> m (Maybe UserId))
-> Maybe UserId -> m (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Token
token Token -> Getting User Token User -> User
forall s a. s -> Getting a s a -> a
^. Getting User Token User
Lens' Token User
tokenUser User -> Getting UserId User UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId User UserId
Lens' User UserId
userId)


------------------------------------------------------------------------------
-- AuthenticationMethod
------------------------------------------------------------------------------

-- | `AuthenticationMethod` is used by the routing system to select which
-- authentication backend should handle this request.
newtype AuthenticationMethod = AuthenticationMethod
  { AuthenticationMethod -> Lang
_unAuthenticationMethod :: Text }
  deriving (AuthenticationMethod -> AuthenticationMethod -> Bool
(AuthenticationMethod -> AuthenticationMethod -> Bool)
-> (AuthenticationMethod -> AuthenticationMethod -> Bool)
-> Eq AuthenticationMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c/= :: AuthenticationMethod -> AuthenticationMethod -> Bool
== :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c== :: AuthenticationMethod -> AuthenticationMethod -> Bool
Eq, Eq AuthenticationMethod
Eq AuthenticationMethod
-> (AuthenticationMethod -> AuthenticationMethod -> Ordering)
-> (AuthenticationMethod -> AuthenticationMethod -> Bool)
-> (AuthenticationMethod -> AuthenticationMethod -> Bool)
-> (AuthenticationMethod -> AuthenticationMethod -> Bool)
-> (AuthenticationMethod -> AuthenticationMethod -> Bool)
-> (AuthenticationMethod
    -> AuthenticationMethod -> AuthenticationMethod)
-> (AuthenticationMethod
    -> AuthenticationMethod -> AuthenticationMethod)
-> Ord AuthenticationMethod
AuthenticationMethod -> AuthenticationMethod -> Bool
AuthenticationMethod -> AuthenticationMethod -> Ordering
AuthenticationMethod
-> AuthenticationMethod -> AuthenticationMethod
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 :: AuthenticationMethod
-> AuthenticationMethod -> AuthenticationMethod
$cmin :: AuthenticationMethod
-> AuthenticationMethod -> AuthenticationMethod
max :: AuthenticationMethod
-> AuthenticationMethod -> AuthenticationMethod
$cmax :: AuthenticationMethod
-> AuthenticationMethod -> AuthenticationMethod
>= :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c>= :: AuthenticationMethod -> AuthenticationMethod -> Bool
> :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c> :: AuthenticationMethod -> AuthenticationMethod -> Bool
<= :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c<= :: AuthenticationMethod -> AuthenticationMethod -> Bool
< :: AuthenticationMethod -> AuthenticationMethod -> Bool
$c< :: AuthenticationMethod -> AuthenticationMethod -> Bool
compare :: AuthenticationMethod -> AuthenticationMethod -> Ordering
$ccompare :: AuthenticationMethod -> AuthenticationMethod -> Ordering
$cp1Ord :: Eq AuthenticationMethod
Ord, ReadPrec [AuthenticationMethod]
ReadPrec AuthenticationMethod
Int -> ReadS AuthenticationMethod
ReadS [AuthenticationMethod]
(Int -> ReadS AuthenticationMethod)
-> ReadS [AuthenticationMethod]
-> ReadPrec AuthenticationMethod
-> ReadPrec [AuthenticationMethod]
-> Read AuthenticationMethod
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AuthenticationMethod]
$creadListPrec :: ReadPrec [AuthenticationMethod]
readPrec :: ReadPrec AuthenticationMethod
$creadPrec :: ReadPrec AuthenticationMethod
readList :: ReadS [AuthenticationMethod]
$creadList :: ReadS [AuthenticationMethod]
readsPrec :: Int -> ReadS AuthenticationMethod
$creadsPrec :: Int -> ReadS AuthenticationMethod
Read, Int -> AuthenticationMethod -> String -> String
[AuthenticationMethod] -> String -> String
AuthenticationMethod -> String
(Int -> AuthenticationMethod -> String -> String)
-> (AuthenticationMethod -> String)
-> ([AuthenticationMethod] -> String -> String)
-> Show AuthenticationMethod
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AuthenticationMethod] -> String -> String
$cshowList :: [AuthenticationMethod] -> String -> String
show :: AuthenticationMethod -> String
$cshow :: AuthenticationMethod -> String
showsPrec :: Int -> AuthenticationMethod -> String -> String
$cshowsPrec :: Int -> AuthenticationMethod -> String -> String
Show, Typeable AuthenticationMethod
DataType
Constr
Typeable AuthenticationMethod
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> AuthenticationMethod
    -> c AuthenticationMethod)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c AuthenticationMethod)
-> (AuthenticationMethod -> Constr)
-> (AuthenticationMethod -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c AuthenticationMethod))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c AuthenticationMethod))
-> ((forall b. Data b => b -> b)
    -> AuthenticationMethod -> AuthenticationMethod)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> AuthenticationMethod -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> AuthenticationMethod -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> AuthenticationMethod -> m AuthenticationMethod)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> AuthenticationMethod -> m AuthenticationMethod)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> AuthenticationMethod -> m AuthenticationMethod)
-> Data AuthenticationMethod
AuthenticationMethod -> DataType
AuthenticationMethod -> Constr
(forall b. Data b => b -> b)
-> AuthenticationMethod -> AuthenticationMethod
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> AuthenticationMethod
-> c AuthenticationMethod
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticationMethod
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) -> AuthenticationMethod -> u
forall u.
(forall d. Data d => d -> u) -> AuthenticationMethod -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticationMethod
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> AuthenticationMethod
-> c AuthenticationMethod
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c AuthenticationMethod)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticationMethod)
$cAuthenticationMethod :: Constr
$tAuthenticationMethod :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
gmapMp :: (forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
gmapM :: (forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> AuthenticationMethod -> m AuthenticationMethod
gmapQi :: Int -> (forall d. Data d => d -> u) -> AuthenticationMethod -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> AuthenticationMethod -> u
gmapQ :: (forall d. Data d => d -> u) -> AuthenticationMethod -> [u]
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> AuthenticationMethod -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticationMethod -> r
gmapT :: (forall b. Data b => b -> b)
-> AuthenticationMethod -> AuthenticationMethod
$cgmapT :: (forall b. Data b => b -> b)
-> AuthenticationMethod -> AuthenticationMethod
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticationMethod)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticationMethod)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c AuthenticationMethod)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c AuthenticationMethod)
dataTypeOf :: AuthenticationMethod -> DataType
$cdataTypeOf :: AuthenticationMethod -> DataType
toConstr :: AuthenticationMethod -> Constr
$ctoConstr :: AuthenticationMethod -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticationMethod
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticationMethod
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> AuthenticationMethod
-> c AuthenticationMethod
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> AuthenticationMethod
-> c AuthenticationMethod
$cp1Data :: Typeable AuthenticationMethod
Data, Typeable, (forall x. AuthenticationMethod -> Rep AuthenticationMethod x)
-> (forall x. Rep AuthenticationMethod x -> AuthenticationMethod)
-> Generic AuthenticationMethod
forall x. Rep AuthenticationMethod x -> AuthenticationMethod
forall x. AuthenticationMethod -> Rep AuthenticationMethod x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthenticationMethod x -> AuthenticationMethod
$cfrom :: forall x. AuthenticationMethod -> Rep AuthenticationMethod x
Generic)
derivePathInfo ''AuthenticationMethod
deriveSafeCopy 1 'base ''AuthenticationMethod
makeLenses ''AuthenticationMethod
makeBoomerangs ''AuthenticationMethod

instance ToJSON AuthenticationMethod   where toJSON :: AuthenticationMethod -> Value
toJSON (AuthenticationMethod Lang
method) = Lang -> Value
forall a. ToJSON a => a -> Value
toJSON Lang
method
instance FromJSON AuthenticationMethod where parseJSON :: Value -> Parser AuthenticationMethod
parseJSON Value
v = Lang -> AuthenticationMethod
AuthenticationMethod (Lang -> AuthenticationMethod)
-> Parser Lang -> Parser AuthenticationMethod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Lang
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

type AuthenticationHandler = [Text] -> RouteT AuthenticateURL (ServerPartT IO) Response

type AuthenticationHandlers = Map AuthenticationMethod AuthenticationHandler

------------------------------------------------------------------------------
-- AuthenticationURL
------------------------------------------------------------------------------

data AuthenticateURL
    = -- Users (Maybe UserId)
      AuthenticationMethods (Maybe (AuthenticationMethod, [Text]))
    | Controllers
    deriving (AuthenticateURL -> AuthenticateURL -> Bool
(AuthenticateURL -> AuthenticateURL -> Bool)
-> (AuthenticateURL -> AuthenticateURL -> Bool)
-> Eq AuthenticateURL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthenticateURL -> AuthenticateURL -> Bool
$c/= :: AuthenticateURL -> AuthenticateURL -> Bool
== :: AuthenticateURL -> AuthenticateURL -> Bool
$c== :: AuthenticateURL -> AuthenticateURL -> Bool
Eq, Eq AuthenticateURL
Eq AuthenticateURL
-> (AuthenticateURL -> AuthenticateURL -> Ordering)
-> (AuthenticateURL -> AuthenticateURL -> Bool)
-> (AuthenticateURL -> AuthenticateURL -> Bool)
-> (AuthenticateURL -> AuthenticateURL -> Bool)
-> (AuthenticateURL -> AuthenticateURL -> Bool)
-> (AuthenticateURL -> AuthenticateURL -> AuthenticateURL)
-> (AuthenticateURL -> AuthenticateURL -> AuthenticateURL)
-> Ord AuthenticateURL
AuthenticateURL -> AuthenticateURL -> Bool
AuthenticateURL -> AuthenticateURL -> Ordering
AuthenticateURL -> AuthenticateURL -> AuthenticateURL
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 :: AuthenticateURL -> AuthenticateURL -> AuthenticateURL
$cmin :: AuthenticateURL -> AuthenticateURL -> AuthenticateURL
max :: AuthenticateURL -> AuthenticateURL -> AuthenticateURL
$cmax :: AuthenticateURL -> AuthenticateURL -> AuthenticateURL
>= :: AuthenticateURL -> AuthenticateURL -> Bool
$c>= :: AuthenticateURL -> AuthenticateURL -> Bool
> :: AuthenticateURL -> AuthenticateURL -> Bool
$c> :: AuthenticateURL -> AuthenticateURL -> Bool
<= :: AuthenticateURL -> AuthenticateURL -> Bool
$c<= :: AuthenticateURL -> AuthenticateURL -> Bool
< :: AuthenticateURL -> AuthenticateURL -> Bool
$c< :: AuthenticateURL -> AuthenticateURL -> Bool
compare :: AuthenticateURL -> AuthenticateURL -> Ordering
$ccompare :: AuthenticateURL -> AuthenticateURL -> Ordering
$cp1Ord :: Eq AuthenticateURL
Ord, ReadPrec [AuthenticateURL]
ReadPrec AuthenticateURL
Int -> ReadS AuthenticateURL
ReadS [AuthenticateURL]
(Int -> ReadS AuthenticateURL)
-> ReadS [AuthenticateURL]
-> ReadPrec AuthenticateURL
-> ReadPrec [AuthenticateURL]
-> Read AuthenticateURL
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AuthenticateURL]
$creadListPrec :: ReadPrec [AuthenticateURL]
readPrec :: ReadPrec AuthenticateURL
$creadPrec :: ReadPrec AuthenticateURL
readList :: ReadS [AuthenticateURL]
$creadList :: ReadS [AuthenticateURL]
readsPrec :: Int -> ReadS AuthenticateURL
$creadsPrec :: Int -> ReadS AuthenticateURL
Read, Int -> AuthenticateURL -> String -> String
[AuthenticateURL] -> String -> String
AuthenticateURL -> String
(Int -> AuthenticateURL -> String -> String)
-> (AuthenticateURL -> String)
-> ([AuthenticateURL] -> String -> String)
-> Show AuthenticateURL
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AuthenticateURL] -> String -> String
$cshowList :: [AuthenticateURL] -> String -> String
show :: AuthenticateURL -> String
$cshow :: AuthenticateURL -> String
showsPrec :: Int -> AuthenticateURL -> String -> String
$cshowsPrec :: Int -> AuthenticateURL -> String -> String
Show, Typeable AuthenticateURL
DataType
Constr
Typeable AuthenticateURL
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> AuthenticateURL -> c AuthenticateURL)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c AuthenticateURL)
-> (AuthenticateURL -> Constr)
-> (AuthenticateURL -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c AuthenticateURL))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c AuthenticateURL))
-> ((forall b. Data b => b -> b)
    -> AuthenticateURL -> AuthenticateURL)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> AuthenticateURL -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> AuthenticateURL -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> AuthenticateURL -> m AuthenticateURL)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> AuthenticateURL -> m AuthenticateURL)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> AuthenticateURL -> m AuthenticateURL)
-> Data AuthenticateURL
AuthenticateURL -> DataType
AuthenticateURL -> Constr
(forall b. Data b => b -> b) -> AuthenticateURL -> AuthenticateURL
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AuthenticateURL -> c AuthenticateURL
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticateURL
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) -> AuthenticateURL -> u
forall u. (forall d. Data d => d -> u) -> AuthenticateURL -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticateURL
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AuthenticateURL -> c AuthenticateURL
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c AuthenticateURL)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticateURL)
$cControllers :: Constr
$cAuthenticationMethods :: Constr
$tAuthenticateURL :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
gmapMp :: (forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
gmapM :: (forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> AuthenticateURL -> m AuthenticateURL
gmapQi :: Int -> (forall d. Data d => d -> u) -> AuthenticateURL -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> AuthenticateURL -> u
gmapQ :: (forall d. Data d => d -> u) -> AuthenticateURL -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> AuthenticateURL -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AuthenticateURL -> r
gmapT :: (forall b. Data b => b -> b) -> AuthenticateURL -> AuthenticateURL
$cgmapT :: (forall b. Data b => b -> b) -> AuthenticateURL -> AuthenticateURL
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticateURL)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c AuthenticateURL)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c AuthenticateURL)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c AuthenticateURL)
dataTypeOf :: AuthenticateURL -> DataType
$cdataTypeOf :: AuthenticateURL -> DataType
toConstr :: AuthenticateURL -> Constr
$ctoConstr :: AuthenticateURL -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticateURL
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c AuthenticateURL
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AuthenticateURL -> c AuthenticateURL
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AuthenticateURL -> c AuthenticateURL
$cp1Data :: Typeable AuthenticateURL
Data, Typeable, (forall x. AuthenticateURL -> Rep AuthenticateURL x)
-> (forall x. Rep AuthenticateURL x -> AuthenticateURL)
-> Generic AuthenticateURL
forall x. Rep AuthenticateURL x -> AuthenticateURL
forall x. AuthenticateURL -> Rep AuthenticateURL x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthenticateURL x -> AuthenticateURL
$cfrom :: forall x. AuthenticateURL -> Rep AuthenticateURL x
Generic)

makeBoomerangs ''AuthenticateURL

-- | a `Router` for `AuthenicateURL`
authenticateURL :: Router () (AuthenticateURL :- ())
authenticateURL :: Router () (AuthenticateURL :- ())
authenticateURL =
  (  -- "users" </> (  rUsers . rMaybe userId )
    Boomerang
  TextsError [Lang] (AuthenticateURL :- ()) (AuthenticateURL :- ())
"authentication-methods" Boomerang
  TextsError [Lang] (AuthenticateURL :- ()) (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
forall b c a.
Boomerang TextsError [Lang] b c
-> Boomerang TextsError [Lang] a b
-> Boomerang TextsError [Lang] a c
</> ( Boomerang
  TextsError
  [Lang]
  (Maybe (AuthenticationMethod, [Lang]) :- ())
  (AuthenticateURL :- ())
forall tok e r.
Boomerang
  e
  tok
  (Maybe (AuthenticationMethod, [Lang]) :- r)
  (AuthenticateURL :- r)
rAuthenticationMethods Boomerang
  TextsError
  [Lang]
  (Maybe (AuthenticationMethod, [Lang]) :- ())
  (AuthenticateURL :- ())
-> Boomerang
     TextsError [Lang] () (Maybe (AuthenticationMethod, [Lang]) :- ())
-> Router () (AuthenticateURL :- ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Boomerang
  TextsError [Lang] () ((AuthenticationMethod, [Lang]) :- ())
-> Boomerang
     TextsError [Lang] () (Maybe (AuthenticationMethod, [Lang]) :- ())
forall e tok r a.
Boomerang e tok r (a :- r) -> Boomerang e tok r (Maybe a :- r)
rMaybe Boomerang
  TextsError [Lang] () ((AuthenticationMethod, [Lang]) :- ())
forall r.
Boomerang TextsError [Lang] r ((AuthenticationMethod, [Lang]) :- r)
authenticationMethod)
  Router () (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
forall a. Semigroup a => a -> a -> a
<> Boomerang
  TextsError [Lang] (AuthenticateURL :- ()) (AuthenticateURL :- ())
"controllers" Boomerang
  TextsError [Lang] (AuthenticateURL :- ()) (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
-> Router () (AuthenticateURL :- ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Router () (AuthenticateURL :- ())
forall tok e r. Boomerang e tok r (AuthenticateURL :- r)
rControllers
  )
  where
    userId :: Boomerang TextsError [Lang] r (UserId :- r)
userId = Boomerang TextsError [Lang] (Integer :- r) (UserId :- r)
forall tok e r. Boomerang e tok (Integer :- r) (UserId :- r)
rUserId Boomerang TextsError [Lang] (Integer :- r) (UserId :- r)
-> Boomerang TextsError [Lang] r (Integer :- r)
-> Boomerang TextsError [Lang] r (UserId :- r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Boomerang TextsError [Lang] r (Integer :- r)
forall r. Boomerang TextsError [Lang] r (Integer :- r)
integer
    authenticationMethod :: Boomerang TextsError [Lang] r ((AuthenticationMethod, [Lang]) :- r)
authenticationMethod = Boomerang
  TextsError
  [Lang]
  (AuthenticationMethod :- ([Lang] :- r))
  ((AuthenticationMethod, [Lang]) :- r)
forall e tok f s r. Boomerang e tok (f :- (s :- r)) ((f, s) :- r)
rPair Boomerang
  TextsError
  [Lang]
  (AuthenticationMethod :- ([Lang] :- r))
  ((AuthenticationMethod, [Lang]) :- r)
-> Boomerang
     TextsError [Lang] r (AuthenticationMethod :- ([Lang] :- r))
-> Boomerang
     TextsError [Lang] r ((AuthenticationMethod, [Lang]) :- r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Boomerang
  TextsError
  [Lang]
  (Lang :- ([Lang] :- r))
  (AuthenticationMethod :- ([Lang] :- r))
forall tok e r.
Boomerang e tok (Lang :- r) (AuthenticationMethod :- r)
rAuthenticationMethod Boomerang
  TextsError
  [Lang]
  (Lang :- ([Lang] :- r))
  (AuthenticationMethod :- ([Lang] :- r))
-> Boomerang
     TextsError [Lang] ([Lang] :- r) (Lang :- ([Lang] :- r))
-> Boomerang
     TextsError
     [Lang]
     ([Lang] :- r)
     (AuthenticationMethod :- ([Lang] :- r))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Boomerang TextsError [Lang] ([Lang] :- r) (Lang :- ([Lang] :- r))
forall r. Boomerang TextsError [Lang] r (Lang :- r)
anyText) Boomerang
  TextsError
  [Lang]
  ([Lang] :- r)
  (AuthenticationMethod :- ([Lang] :- r))
-> Boomerang TextsError [Lang] r ([Lang] :- r)
-> Boomerang
     TextsError [Lang] r (AuthenticationMethod :- ([Lang] :- r))
forall b c a.
Boomerang TextsError [Lang] b c
-> Boomerang TextsError [Lang] a b
-> Boomerang TextsError [Lang] a c
</> (Boomerang TextsError [Lang] r (Lang :- r)
-> Boomerang TextsError [Lang] ([Lang] :- r) ([Lang] :- r)
-> Boomerang TextsError [Lang] r ([Lang] :- r)
forall e tok r a.
Boomerang e tok r (a :- r)
-> Boomerang e tok ([a] :- r) ([a] :- r)
-> Boomerang e tok r ([a] :- r)
rListSep Boomerang TextsError [Lang] r (Lang :- r)
forall r. Boomerang TextsError [Lang] r (Lang :- r)
anyText Boomerang TextsError [Lang] ([Lang] :- r) ([Lang] :- r)
forall r. Boomerang TextsError [Lang] r r
eos)

instance PathInfo AuthenticateURL where
  fromPathSegments :: URLParser AuthenticateURL
fromPathSegments = Router () (AuthenticateURL :- ()) -> URLParser AuthenticateURL
forall url.
Boomerang TextsError [Lang] () (url :- ()) -> URLParser url
boomerangFromPathSegments Router () (AuthenticateURL :- ())
authenticateURL
  toPathSegments :: AuthenticateURL -> [Lang]
toPathSegments   = Router () (AuthenticateURL :- ()) -> AuthenticateURL -> [Lang]
forall url.
Boomerang TextsError [Lang] () (url :- ()) -> url -> [Lang]
boomerangToPathSegments   Router () (AuthenticateURL :- ())
authenticateURL

-- | helper function which converts a URL for an authentication
-- backend into an `AuthenticateURL`.
nestAuthenticationMethod :: (PathInfo methodURL) =>
                            AuthenticationMethod
                         -> RouteT methodURL m a
                         -> RouteT AuthenticateURL m a
nestAuthenticationMethod :: AuthenticationMethod
-> RouteT methodURL m a -> RouteT AuthenticateURL m a
nestAuthenticationMethod AuthenticationMethod
authenticationMethod =
  (methodURL -> AuthenticateURL)
-> RouteT methodURL m a -> RouteT AuthenticateURL m a
forall url1 url2 (m :: * -> *) a.
(url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a
nestURL ((methodURL -> AuthenticateURL)
 -> RouteT methodURL m a -> RouteT AuthenticateURL m a)
-> (methodURL -> AuthenticateURL)
-> RouteT methodURL m a
-> RouteT AuthenticateURL m a
forall a b. (a -> b) -> a -> b
$ \methodURL
methodURL -> Maybe (AuthenticationMethod, [Lang]) -> AuthenticateURL
AuthenticationMethods (Maybe (AuthenticationMethod, [Lang]) -> AuthenticateURL)
-> Maybe (AuthenticationMethod, [Lang]) -> AuthenticateURL
forall a b. (a -> b) -> a -> b
$ (AuthenticationMethod, [Lang])
-> Maybe (AuthenticationMethod, [Lang])
forall a. a -> Maybe a
Just (AuthenticationMethod
authenticationMethod, methodURL -> [Lang]
forall url. PathInfo url => url -> [Lang]
toPathSegments methodURL
methodURL)