-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Basic authentication support.
--
module WebGear.Middlewares.Auth.Basic
  ( BasicAuth
  , Realm (..)
  , Username (..)
  , Password (..)
  , Credentials (..)
  , BasicAuthError (..)
  , basicAuth
  ) where

import Control.Arrow (Kleisli (..))
import Control.Monad (when, (>=>))
import Control.Monad.Except (throwError)
import Data.ByteString (ByteString, intercalate)
import Data.ByteString.Base64 (decodeLenient)
import Data.ByteString.Char8 (split)
import Data.CaseInsensitive (CI, mk)
import Data.Proxy (Proxy (..))
import Data.String (IsString)

import WebGear.Trait (Has (..), Linked, Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), forbidden403,
                      requestHeader, setResponseHeader, unauthorized401)
import WebGear.Util (maybeToRight)


-- | Trait for HTTP basic authentication: https://tools.ietf.org/html/rfc7617
data BasicAuth

-- | The protection space for basic authentication
newtype Realm = Realm ByteString
  deriving newtype (Realm -> Realm -> Bool
(Realm -> Realm -> Bool) -> (Realm -> Realm -> Bool) -> Eq Realm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Realm -> Realm -> Bool
$c/= :: Realm -> Realm -> Bool
== :: Realm -> Realm -> Bool
$c== :: Realm -> Realm -> Bool
Eq, Eq Realm
Eq Realm
-> (Realm -> Realm -> Ordering)
-> (Realm -> Realm -> Bool)
-> (Realm -> Realm -> Bool)
-> (Realm -> Realm -> Bool)
-> (Realm -> Realm -> Bool)
-> (Realm -> Realm -> Realm)
-> (Realm -> Realm -> Realm)
-> Ord Realm
Realm -> Realm -> Bool
Realm -> Realm -> Ordering
Realm -> Realm -> Realm
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 :: Realm -> Realm -> Realm
$cmin :: Realm -> Realm -> Realm
max :: Realm -> Realm -> Realm
$cmax :: Realm -> Realm -> Realm
>= :: Realm -> Realm -> Bool
$c>= :: Realm -> Realm -> Bool
> :: Realm -> Realm -> Bool
$c> :: Realm -> Realm -> Bool
<= :: Realm -> Realm -> Bool
$c<= :: Realm -> Realm -> Bool
< :: Realm -> Realm -> Bool
$c< :: Realm -> Realm -> Bool
compare :: Realm -> Realm -> Ordering
$ccompare :: Realm -> Realm -> Ordering
$cp1Ord :: Eq Realm
Ord, Int -> Realm -> ShowS
[Realm] -> ShowS
Realm -> String
(Int -> Realm -> ShowS)
-> (Realm -> String) -> ([Realm] -> ShowS) -> Show Realm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Realm] -> ShowS
$cshowList :: [Realm] -> ShowS
show :: Realm -> String
$cshow :: Realm -> String
showsPrec :: Int -> Realm -> ShowS
$cshowsPrec :: Int -> Realm -> ShowS
Show, ReadPrec [Realm]
ReadPrec Realm
Int -> ReadS Realm
ReadS [Realm]
(Int -> ReadS Realm)
-> ReadS [Realm]
-> ReadPrec Realm
-> ReadPrec [Realm]
-> Read Realm
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Realm]
$creadListPrec :: ReadPrec [Realm]
readPrec :: ReadPrec Realm
$creadPrec :: ReadPrec Realm
readList :: ReadS [Realm]
$creadList :: ReadS [Realm]
readsPrec :: Int -> ReadS Realm
$creadsPrec :: Int -> ReadS Realm
Read, String -> Realm
(String -> Realm) -> IsString Realm
forall a. (String -> a) -> IsString a
fromString :: String -> Realm
$cfromString :: String -> Realm
IsString)

-- | Username for basic authentication. Valid usernames cannot contain
-- \':\' characters.
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
/= :: 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, 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
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]
(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, String -> Username
(String -> Username) -> IsString Username
forall a. (String -> a) -> IsString a
fromString :: String -> Username
$cfromString :: String -> Username
IsString)

-- | Password for basic authentication.
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
/= :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c== :: 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
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
$cp1Ord :: Eq 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
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]
(Int -> ReadS Password)
-> ReadS [Password]
-> ReadPrec Password
-> ReadPrec [Password]
-> Read 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
(String -> Password) -> IsString Password
forall a. (String -> a) -> IsString a
fromString :: String -> Password
$cfromString :: String -> Password
IsString)

-- | Basic authentication credentials retrieved from an HTTP request
data Credentials = Credentials
  { Credentials -> Username
credentialsUsername :: !Username
  , Credentials -> Password
credentialsPassword :: !Password
  }
  deriving (Credentials -> Credentials -> Bool
(Credentials -> Credentials -> Bool)
-> (Credentials -> Credentials -> Bool) -> Eq Credentials
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
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
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
$cp1Ord :: Eq 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
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]
(Int -> ReadS Credentials)
-> ReadS [Credentials]
-> ReadPrec Credentials
-> ReadPrec [Credentials]
-> Read 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)

-- | Error extracting credentials from an HTTP request
data BasicAuthError = AuthHeaderError        -- ^ Authorization header is missing or badly formatted
                    | AuthSchemeMismatch     -- ^ Authorization scheme is not "Basic"
                    deriving (BasicAuthError -> BasicAuthError -> Bool
(BasicAuthError -> BasicAuthError -> Bool)
-> (BasicAuthError -> BasicAuthError -> Bool) -> Eq BasicAuthError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BasicAuthError -> BasicAuthError -> Bool
$c/= :: BasicAuthError -> BasicAuthError -> Bool
== :: BasicAuthError -> BasicAuthError -> Bool
$c== :: BasicAuthError -> BasicAuthError -> Bool
Eq, Eq BasicAuthError
Eq BasicAuthError
-> (BasicAuthError -> BasicAuthError -> Ordering)
-> (BasicAuthError -> BasicAuthError -> Bool)
-> (BasicAuthError -> BasicAuthError -> Bool)
-> (BasicAuthError -> BasicAuthError -> Bool)
-> (BasicAuthError -> BasicAuthError -> Bool)
-> (BasicAuthError -> BasicAuthError -> BasicAuthError)
-> (BasicAuthError -> BasicAuthError -> BasicAuthError)
-> Ord BasicAuthError
BasicAuthError -> BasicAuthError -> Bool
BasicAuthError -> BasicAuthError -> Ordering
BasicAuthError -> BasicAuthError -> BasicAuthError
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 :: BasicAuthError -> BasicAuthError -> BasicAuthError
$cmin :: BasicAuthError -> BasicAuthError -> BasicAuthError
max :: BasicAuthError -> BasicAuthError -> BasicAuthError
$cmax :: BasicAuthError -> BasicAuthError -> BasicAuthError
>= :: BasicAuthError -> BasicAuthError -> Bool
$c>= :: BasicAuthError -> BasicAuthError -> Bool
> :: BasicAuthError -> BasicAuthError -> Bool
$c> :: BasicAuthError -> BasicAuthError -> Bool
<= :: BasicAuthError -> BasicAuthError -> Bool
$c<= :: BasicAuthError -> BasicAuthError -> Bool
< :: BasicAuthError -> BasicAuthError -> Bool
$c< :: BasicAuthError -> BasicAuthError -> Bool
compare :: BasicAuthError -> BasicAuthError -> Ordering
$ccompare :: BasicAuthError -> BasicAuthError -> Ordering
$cp1Ord :: Eq BasicAuthError
Ord, Int -> BasicAuthError -> ShowS
[BasicAuthError] -> ShowS
BasicAuthError -> String
(Int -> BasicAuthError -> ShowS)
-> (BasicAuthError -> String)
-> ([BasicAuthError] -> ShowS)
-> Show BasicAuthError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BasicAuthError] -> ShowS
$cshowList :: [BasicAuthError] -> ShowS
show :: BasicAuthError -> String
$cshow :: BasicAuthError -> String
showsPrec :: Int -> BasicAuthError -> ShowS
$cshowsPrec :: Int -> BasicAuthError -> ShowS
Show, ReadPrec [BasicAuthError]
ReadPrec BasicAuthError
Int -> ReadS BasicAuthError
ReadS [BasicAuthError]
(Int -> ReadS BasicAuthError)
-> ReadS [BasicAuthError]
-> ReadPrec BasicAuthError
-> ReadPrec [BasicAuthError]
-> Read BasicAuthError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BasicAuthError]
$creadListPrec :: ReadPrec [BasicAuthError]
readPrec :: ReadPrec BasicAuthError
$creadPrec :: ReadPrec BasicAuthError
readList :: ReadS [BasicAuthError]
$creadList :: ReadS [BasicAuthError]
readsPrec :: Int -> ReadS BasicAuthError
$creadsPrec :: Int -> ReadS BasicAuthError
Read)

instance Monad m => Trait BasicAuth Request m where
  type Attribute BasicAuth Request = Credentials
  type Absence BasicAuth Request = BasicAuthError

  toAttribute :: Request -> m (Result BasicAuth Request)
  toAttribute :: Request -> m (Result BasicAuth Request)
toAttribute Request
r = Result BasicAuth Request -> m (Result BasicAuth Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result BasicAuth Request -> m (Result BasicAuth Request))
-> Result BasicAuth Request -> m (Result BasicAuth Request)
forall a b. (a -> b) -> a -> b
$ (BasicAuthError -> Result BasicAuth Request)
-> (Credentials -> Result BasicAuth Request)
-> Either BasicAuthError Credentials
-> Result BasicAuth Request
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either BasicAuthError -> Result BasicAuth Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound Credentials -> Result BasicAuth Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (Either BasicAuthError Credentials -> Result BasicAuth Request)
-> Either BasicAuthError Credentials -> Result BasicAuth Request
forall a b. (a -> b) -> a -> b
$ do
    ByteString
h <- Request -> Either BasicAuthError ByteString
getAuthHeader Request
r
    (Scheme
scheme, ByteString
creds) <- ByteString -> Either BasicAuthError (Scheme, ByteString)
parseAuthHeader ByteString
h
    Bool -> Either BasicAuthError () -> Either BasicAuthError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Scheme
scheme Scheme -> Scheme -> Bool
forall a. Eq a => a -> a -> Bool
/= Scheme
"Basic") (Either BasicAuthError () -> Either BasicAuthError ())
-> Either BasicAuthError () -> Either BasicAuthError ()
forall a b. (a -> b) -> a -> b
$
      BasicAuthError -> Either BasicAuthError ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError BasicAuthError
AuthSchemeMismatch
    ByteString -> Either BasicAuthError Credentials
parseCreds ByteString
creds

type Scheme = CI ByteString
type EncodedPassword = ByteString

getAuthHeader :: Request -> Either BasicAuthError ByteString
getAuthHeader :: Request -> Either BasicAuthError ByteString
getAuthHeader Request
r = BasicAuthError
-> Maybe ByteString -> Either BasicAuthError ByteString
forall a b. a -> Maybe b -> Either a b
maybeToRight BasicAuthError
AuthHeaderError (Maybe ByteString -> Either BasicAuthError ByteString)
-> Maybe ByteString -> Either BasicAuthError ByteString
forall a b. (a -> b) -> a -> b
$ Scheme -> Request -> Maybe ByteString
requestHeader Scheme
"Authorization" Request
r

parseAuthHeader :: ByteString -> Either BasicAuthError (Scheme, EncodedPassword)
parseAuthHeader :: ByteString -> Either BasicAuthError (Scheme, ByteString)
parseAuthHeader ByteString
s =
  case Char -> ByteString -> [ByteString]
split Char
' ' ByteString
s of
    [ByteString
x, ByteString
y] -> (Scheme, ByteString) -> Either BasicAuthError (Scheme, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Scheme
forall s. FoldCase s => s -> CI s
mk ByteString
x, ByteString
y)
    [ByteString]
_      -> BasicAuthError -> Either BasicAuthError (Scheme, ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError BasicAuthError
AuthHeaderError

parseCreds :: EncodedPassword -> Either BasicAuthError Credentials
parseCreds :: ByteString -> Either BasicAuthError Credentials
parseCreds ByteString
enc =
  case Char -> ByteString -> [ByteString]
split Char
':' (ByteString -> ByteString
decodeLenient ByteString
enc) of
    []   -> BasicAuthError -> Either BasicAuthError Credentials
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError BasicAuthError
AuthHeaderError
    ByteString
u:[ByteString]
ps -> Credentials -> Either BasicAuthError Credentials
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Credentials -> Either BasicAuthError Credentials)
-> Credentials -> Either BasicAuthError Credentials
forall a b. (a -> b) -> a -> b
$ Username -> Password -> Credentials
Credentials (ByteString -> Username
Username ByteString
u) (ByteString -> Password
Password (ByteString -> Password) -> ByteString -> Password
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
intercalate ByteString
":" [ByteString]
ps)

-- | Middleware to add basic authentication protection for a handler.
--
-- Example usage:
--
-- > basicAuth "realm" isValidCredentials handler
--
-- This middleware returns a 401 response if no credentials are found
-- in the request. It returns a 403 response if credentials are
-- present but isValidCredentials returns False.
--
basicAuth :: forall m req a. MonadRouter m
          => Realm
          -> (Credentials -> m Bool)
          -> RequestMiddleware' m req (BasicAuth : req) a
basicAuth :: Realm
-> (Credentials -> m Bool)
-> RequestMiddleware' m req (BasicAuth : req) a
basicAuth (Realm ByteString
realm) Credentials -> m Bool
credCheck Handler' m (BasicAuth : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait BasicAuth a m =>
Linked ts a
-> m (Either (Absence BasicAuth a) (Linked (BasicAuth : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @BasicAuth (Linked req Request
 -> m (Either BasicAuthError (Linked (BasicAuth : req) Request)))
-> (Either BasicAuthError (Linked (BasicAuth : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (BasicAuthError -> m (Response a))
-> (Linked (BasicAuth : req) Request -> m (Response a))
-> Either BasicAuthError (Linked (BasicAuth : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either BasicAuthError -> m (Response a)
unauthorized (Linked (BasicAuth : req) Request
-> m (Linked (BasicAuth : req) Request)
validateCredentials (Linked (BasicAuth : req) Request
 -> m (Linked (BasicAuth : req) Request))
-> (Linked (BasicAuth : req) Request -> m (Response a))
-> Linked (BasicAuth : req) Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Handler' m (BasicAuth : req) a
-> Linked (BasicAuth : req) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (BasicAuth : req) a
handler)
  where
    unauthorized :: BasicAuthError -> m (Response a)
    unauthorized :: BasicAuthError -> m (Response a)
unauthorized = m (Response a) -> BasicAuthError -> m (Response a)
forall a b. a -> b -> a
const (m (Response a) -> BasicAuthError -> m (Response a))
-> m (Response a) -> BasicAuthError -> m (Response a)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse
      (Response ByteString -> m (Response a))
-> Response ByteString -> m (Response a)
forall a b. (a -> b) -> a -> b
$ Scheme -> ByteString -> Response ByteString -> Response ByteString
forall a. Scheme -> ByteString -> Response a -> Response a
setResponseHeader Scheme
"WWW-Authenticate" (ByteString
"Basic realm=\"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
realm ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\"")
      (Response ByteString -> Response ByteString)
-> Response ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Response ByteString
forall a. a -> Response a
unauthorized401 ByteString
"Unauthorized"

    validateCredentials :: Linked (BasicAuth : req) Request
                        -> m (Linked (BasicAuth : req) Request)
    validateCredentials :: Linked (BasicAuth : req) Request
-> m (Linked (BasicAuth : req) Request)
validateCredentials Linked (BasicAuth : req) Request
req = do
      Bool
valid <- Credentials -> m Bool
credCheck (Credentials -> m Bool) -> Credentials -> m Bool
forall a b. (a -> b) -> a -> b
$ Proxy BasicAuth
-> Linked (BasicAuth : req) Request -> Attribute BasicAuth Request
forall k (t :: k) (ts :: [*]) a.
Has t ts =>
Proxy t -> Linked ts a -> Attribute t a
get (Proxy BasicAuth
forall k (t :: k). Proxy t
Proxy @BasicAuth) Linked (BasicAuth : req) Request
req
      if Bool
valid
        then Linked (BasicAuth : req) Request
-> m (Linked (BasicAuth : req) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Linked (BasicAuth : req) Request
req
        else Response ByteString -> m (Linked (BasicAuth : req) Request)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Linked (BasicAuth : req) Request))
-> Response ByteString -> m (Linked (BasicAuth : req) Request)
forall a b. (a -> b) -> a -> b
$ ByteString -> Response ByteString
forall a. a -> Response a
forbidden403 ByteString
"Forbidden"