{-# LANGUAGE DuplicateRecordFields #-}
module WebGear.Core.Trait.Auth.Basic (
BasicAuth' (..),
BasicAuth,
Realm (..),
Username (..),
Password (..),
Credentials (..),
BasicAuthError (..),
basicAuth,
basicAuth',
optionalBasicAuth,
optionalBasicAuth',
) where
import Control.Arrow (ArrowChoice, arr)
import Data.ByteString (ByteString)
import Data.String (IsString)
import Data.Void (Void, absurd)
import GHC.TypeLits (Symbol)
import WebGear.Core.Handler
import WebGear.Core.Modifiers (Existence (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait
import WebGear.Core.Trait.Auth.Common
newtype BasicAuth' (x :: Existence) (scheme :: Symbol) m e a = BasicAuth'
{
forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
BasicAuth' x scheme m e a -> Credentials -> m (Either e a)
toBasicAttribute :: Credentials -> m (Either e a)
}
type BasicAuth = BasicAuth' Required "Basic"
newtype Username = Username ByteString
deriving newtype (Username -> Username -> Bool
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
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
Ord, Int -> Username -> ShowS
[Username] -> ShowS
Username -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Username] -> ShowS
$cshowList :: [Username] -> ShowS
show :: Username -> String
$cshow :: Username -> String
showsPrec :: Int -> Username -> ShowS
$cshowsPrec :: Int -> Username -> ShowS
Show, ReadPrec [Username]
ReadPrec Username
Int -> ReadS Username
ReadS [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, String -> Username
forall a. (String -> a) -> IsString a
fromString :: String -> Username
$cfromString :: String -> Username
IsString)
newtype Password = Password ByteString
deriving newtype (Password -> Password -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c== :: Password -> Password -> Bool
Eq, Eq Password
Password -> Password -> Bool
Password -> Password -> Ordering
Password -> Password -> Password
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 :: Password -> Password -> Password
$cmin :: Password -> Password -> Password
max :: Password -> Password -> Password
$cmax :: Password -> Password -> Password
>= :: Password -> Password -> Bool
$c>= :: Password -> Password -> Bool
> :: Password -> Password -> Bool
$c> :: Password -> Password -> Bool
<= :: Password -> Password -> Bool
$c<= :: Password -> Password -> Bool
< :: Password -> Password -> Bool
$c< :: Password -> Password -> Bool
compare :: Password -> Password -> Ordering
$ccompare :: Password -> Password -> Ordering
Ord, Int -> Password -> ShowS
[Password] -> ShowS
Password -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Password] -> ShowS
$cshowList :: [Password] -> ShowS
show :: Password -> String
$cshow :: Password -> String
showsPrec :: Int -> Password -> ShowS
$cshowsPrec :: Int -> Password -> ShowS
Show, ReadPrec [Password]
ReadPrec Password
Int -> ReadS Password
ReadS [Password]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Password]
$creadListPrec :: ReadPrec [Password]
readPrec :: ReadPrec Password
$creadPrec :: ReadPrec Password
readList :: ReadS [Password]
$creadList :: ReadS [Password]
readsPrec :: Int -> ReadS Password
$creadsPrec :: Int -> ReadS Password
Read, String -> Password
forall a. (String -> a) -> IsString a
fromString :: String -> Password
$cfromString :: String -> Password
IsString)
data Credentials = Credentials
{ Credentials -> Username
credentialsUsername :: !Username
, Credentials -> Password
credentialsPassword :: !Password
}
deriving stock (Credentials -> Credentials -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Credentials -> Credentials -> Bool
$c/= :: Credentials -> Credentials -> Bool
== :: Credentials -> Credentials -> Bool
$c== :: Credentials -> Credentials -> Bool
Eq, Eq Credentials
Credentials -> Credentials -> Bool
Credentials -> Credentials -> Ordering
Credentials -> Credentials -> Credentials
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 :: Credentials -> Credentials -> Credentials
$cmin :: Credentials -> Credentials -> Credentials
max :: Credentials -> Credentials -> Credentials
$cmax :: Credentials -> Credentials -> Credentials
>= :: Credentials -> Credentials -> Bool
$c>= :: Credentials -> Credentials -> Bool
> :: Credentials -> Credentials -> Bool
$c> :: Credentials -> Credentials -> Bool
<= :: Credentials -> Credentials -> Bool
$c<= :: Credentials -> Credentials -> Bool
< :: Credentials -> Credentials -> Bool
$c< :: Credentials -> Credentials -> Bool
compare :: Credentials -> Credentials -> Ordering
$ccompare :: Credentials -> Credentials -> Ordering
Ord, Int -> Credentials -> ShowS
[Credentials] -> ShowS
Credentials -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Credentials] -> ShowS
$cshowList :: [Credentials] -> ShowS
show :: Credentials -> String
$cshow :: Credentials -> String
showsPrec :: Int -> Credentials -> ShowS
$cshowsPrec :: Int -> Credentials -> ShowS
Show, ReadPrec [Credentials]
ReadPrec Credentials
Int -> ReadS Credentials
ReadS [Credentials]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Credentials]
$creadListPrec :: ReadPrec [Credentials]
readPrec :: ReadPrec Credentials
$creadPrec :: ReadPrec Credentials
readList :: ReadS [Credentials]
$creadList :: ReadS [Credentials]
readsPrec :: Int -> ReadS Credentials
$creadsPrec :: Int -> ReadS Credentials
Read)
data BasicAuthError e
=
| BasicAuthSchemeMismatch
| BasicAuthCredsBadFormat
| BasicAuthAttributeError e
deriving stock (BasicAuthError e -> BasicAuthError e -> Bool
forall e. Eq e => BasicAuthError e -> BasicAuthError e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BasicAuthError e -> BasicAuthError e -> Bool
$c/= :: forall e. Eq e => BasicAuthError e -> BasicAuthError e -> Bool
== :: BasicAuthError e -> BasicAuthError e -> Bool
$c== :: forall e. Eq e => BasicAuthError e -> BasicAuthError e -> Bool
Eq, Int -> BasicAuthError e -> ShowS
forall e. Show e => Int -> BasicAuthError e -> ShowS
forall e. Show e => [BasicAuthError e] -> ShowS
forall e. Show e => BasicAuthError e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BasicAuthError e] -> ShowS
$cshowList :: forall e. Show e => [BasicAuthError e] -> ShowS
show :: BasicAuthError e -> String
$cshow :: forall e. Show e => BasicAuthError e -> String
showsPrec :: Int -> BasicAuthError e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> BasicAuthError e -> ShowS
Show, ReadPrec [BasicAuthError e]
ReadPrec (BasicAuthError e)
ReadS [BasicAuthError e]
forall e. Read e => ReadPrec [BasicAuthError e]
forall e. Read e => ReadPrec (BasicAuthError e)
forall e. Read e => Int -> ReadS (BasicAuthError e)
forall e. Read e => ReadS [BasicAuthError e]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BasicAuthError e]
$creadListPrec :: forall e. Read e => ReadPrec [BasicAuthError e]
readPrec :: ReadPrec (BasicAuthError e)
$creadPrec :: forall e. Read e => ReadPrec (BasicAuthError e)
readList :: ReadS [BasicAuthError e]
$creadList :: forall e. Read e => ReadS [BasicAuthError e]
readsPrec :: Int -> ReadS (BasicAuthError e)
$creadsPrec :: forall e. Read e => Int -> ReadS (BasicAuthError e)
Read)
instance Trait (BasicAuth' Required scheme m e a) Request where
type Attribute (BasicAuth' Required scheme m e a) Request = a
instance TraitAbsence (BasicAuth' Required scheme m e a) Request where
type Absence (BasicAuth' Required scheme m e a) Request = BasicAuthError e
instance Trait (BasicAuth' Optional scheme m e a) Request where
type Attribute (BasicAuth' Optional scheme m e a) Request = Either (BasicAuthError e) a
instance TraitAbsence (BasicAuth' Optional scheme m e a) Request where
type Absence (BasicAuth' Optional scheme m e a) Request = Void
basicAuthMiddleware ::
(Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) =>
BasicAuth' x scheme m e t ->
h (Linked req Request, Absence (BasicAuth' x scheme m e t) Request) Response ->
Middleware h req (BasicAuth' x scheme m e t : req)
basicAuthMiddleware :: forall (h :: * -> * -> *) (x :: Existence) (scheme :: Symbol)
(m :: * -> *) e t (req :: [*]).
(Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) =>
BasicAuth' x scheme m e t
-> h (Linked req Request,
Absence (BasicAuth' x scheme m e t) Request)
Response
-> Middleware h req (BasicAuth' x scheme m e t : req)
basicAuthMiddleware BasicAuth' x scheme m e t
authCfg h (Linked req Request, Absence (BasicAuth' x scheme m e t) Request)
Response
errorHandler RequestHandler h (BasicAuth' x scheme m e t : req)
nextHandler =
proc Linked req Request
request -> do
Either
(Absence (BasicAuth' x scheme m e t) Request)
(Linked (BasicAuth' x scheme m e t : req) Request)
result <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe BasicAuth' x scheme m e t
authCfg -< Linked req Request
request
case Either
(Absence (BasicAuth' x scheme m e t) Request)
(Linked (BasicAuth' x scheme m e t : req) Request)
result of
Left Absence (BasicAuth' x scheme m e t) Request
err -> h (Linked req Request, Absence (BasicAuth' x scheme m e t) Request)
Response
errorHandler -< (Linked req Request
request, Absence (BasicAuth' x scheme m e t) Request
err)
Right Linked (BasicAuth' x scheme m e t : req) Request
val -> RequestHandler h (BasicAuth' x scheme m e t : req)
nextHandler -< Linked (BasicAuth' x scheme m e t : req) Request
val
{-# INLINE basicAuthMiddleware #-}
basicAuth ::
forall m e t h req.
(Get h (BasicAuth' Required "Basic" m e t) Request, ArrowChoice h) =>
BasicAuth m e t ->
h (Linked req Request, BasicAuthError e) Response ->
Middleware h req (BasicAuth m e t : req)
basicAuth :: forall (m :: * -> *) e t (h :: * -> * -> *) (req :: [*]).
(Get h (BasicAuth' 'Required "Basic" m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Required "Basic" m e t
-> h (Linked req Request, BasicAuthError e) Response
-> Middleware h req (BasicAuth' 'Required "Basic" m e t : req)
basicAuth = forall (scheme :: Symbol) (m :: * -> *) e t (h :: * -> * -> *)
(req :: [*]).
(Get h (BasicAuth' 'Required scheme m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Required scheme m e t
-> h (Linked req Request, BasicAuthError e) Response
-> Middleware h req (BasicAuth' 'Required scheme m e t : req)
basicAuth'
{-# INLINE basicAuth #-}
basicAuth' ::
forall scheme m e t h req.
(Get h (BasicAuth' Required scheme m e t) Request, ArrowChoice h) =>
BasicAuth' Required scheme m e t ->
h (Linked req Request, BasicAuthError e) Response ->
Middleware h req (BasicAuth' Required scheme m e t : req)
basicAuth' :: forall (scheme :: Symbol) (m :: * -> *) e t (h :: * -> * -> *)
(req :: [*]).
(Get h (BasicAuth' 'Required scheme m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Required scheme m e t
-> h (Linked req Request, BasicAuthError e) Response
-> Middleware h req (BasicAuth' 'Required scheme m e t : req)
basicAuth' = forall (h :: * -> * -> *) (x :: Existence) (scheme :: Symbol)
(m :: * -> *) e t (req :: [*]).
(Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) =>
BasicAuth' x scheme m e t
-> h (Linked req Request,
Absence (BasicAuth' x scheme m e t) Request)
Response
-> Middleware h req (BasicAuth' x scheme m e t : req)
basicAuthMiddleware
{-# INLINE basicAuth' #-}
optionalBasicAuth ::
forall m e t h req.
(Get h (BasicAuth' Optional "Basic" m e t) Request, ArrowChoice h) =>
BasicAuth' Optional "Basic" m e t ->
Middleware h req (BasicAuth' Optional "Basic" m e t : req)
optionalBasicAuth :: forall (m :: * -> *) e t (h :: * -> * -> *) (req :: [*]).
(Get h (BasicAuth' 'Optional "Basic" m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Optional "Basic" m e t
-> Middleware h req (BasicAuth' 'Optional "Basic" m e t : req)
optionalBasicAuth = forall (scheme :: Symbol) (m :: * -> *) e t (h :: * -> * -> *)
(req :: [*]).
(Get h (BasicAuth' 'Optional scheme m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Optional scheme m e t
-> Middleware h req (BasicAuth' 'Optional scheme m e t : req)
optionalBasicAuth'
{-# INLINE optionalBasicAuth #-}
optionalBasicAuth' ::
forall scheme m e t h req.
(Get h (BasicAuth' Optional scheme m e t) Request, ArrowChoice h) =>
BasicAuth' Optional scheme m e t ->
Middleware h req (BasicAuth' Optional scheme m e t : req)
optionalBasicAuth' :: forall (scheme :: Symbol) (m :: * -> *) e t (h :: * -> * -> *)
(req :: [*]).
(Get h (BasicAuth' 'Optional scheme m e t) Request,
ArrowChoice h) =>
BasicAuth' 'Optional scheme m e t
-> Middleware h req (BasicAuth' 'Optional scheme m e t : req)
optionalBasicAuth' BasicAuth' 'Optional scheme m e t
cfg = forall (h :: * -> * -> *) (x :: Existence) (scheme :: Symbol)
(m :: * -> *) e t (req :: [*]).
(Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) =>
BasicAuth' x scheme m e t
-> h (Linked req Request,
Absence (BasicAuth' x scheme m e t) Request)
Response
-> Middleware h req (BasicAuth' x scheme m e t : req)
basicAuthMiddleware BasicAuth' 'Optional scheme m e t
cfg forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
{-# INLINE optionalBasicAuth' #-}