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