module WebGear.Core.Trait.Auth.Common (
AuthorizationHeader,
getAuthorizationHeaderTrait,
Realm (..),
AuthToken (..),
respondUnauthorized,
) where
import Control.Arrow (returnA)
import Data.ByteString (ByteString, drop)
import Data.ByteString.Char8 (break)
import Data.CaseInsensitive (CI, mk, original)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Void (absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Core.Handler (Handler, unwitnessA, (>->))
import WebGear.Core.MIMETypes (PlainText (..))
import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Get (..), Sets, With)
import WebGear.Core.Trait.Body (Body, setBody)
import WebGear.Core.Trait.Header (RequestHeader (..), RequiredResponseHeader, setHeader)
import WebGear.Core.Trait.Status (Status, unauthorized401)
import Prelude hiding (break, drop)
type scheme = RequestHeader Optional Lenient "Authorization" (AuthToken scheme)
getAuthorizationHeaderTrait ::
forall scheme h ts.
(Get h (AuthorizationHeader scheme) Request) =>
h (Request `With` ts) (Maybe (Either Text (AuthToken scheme)))
= proc With Request ts
request -> do
Either Void (Maybe (Either Text (AuthToken scheme)))
result <- forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (Attribute t a))
getTrait (forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
RequestHeader e p name val
RequestHeader :: RequestHeader Optional Lenient "Authorization" (AuthToken scheme)) -< With Request ts
request
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Void -> a
absurd forall a. a -> a
id Either Void (Maybe (Either Text (AuthToken scheme)))
result
{-# INLINE getAuthorizationHeaderTrait #-}
newtype Realm = Realm ByteString
deriving newtype (Realm -> Realm -> Bool
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
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
Ord, Int -> Realm -> ShowS
[Realm] -> ShowS
Realm -> String
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]
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
forall a. (String -> a) -> IsString a
fromString :: String -> Realm
$cfromString :: String -> Realm
IsString)
data AuthToken (scheme :: Symbol) = AuthToken
{ forall (scheme :: Symbol). AuthToken scheme -> CI ByteString
authScheme :: CI ByteString
, forall (scheme :: Symbol). AuthToken scheme -> ByteString
authToken :: ByteString
}
instance (KnownSymbol scheme) => FromHttpApiData (AuthToken scheme) where
parseUrlPiece :: Text -> Either Text (AuthToken scheme)
parseUrlPiece = forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
{-# INLINE parseHeader #-}
parseHeader :: ByteString -> Either Text (AuthToken scheme)
parseHeader ByteString
hdr =
case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
hdr of
(ByteString
scm, ByteString
tok) ->
let actualScheme :: CI ByteString
actualScheme = forall s. FoldCase s => s -> CI s
mk ByteString
scm
expectedScheme :: CI ByteString
expectedScheme = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @scheme
in if CI ByteString
actualScheme forall a. Eq a => a -> a -> Bool
== CI ByteString
expectedScheme
then forall a b. b -> Either a b
Right (forall (scheme :: Symbol).
CI ByteString -> ByteString -> AuthToken scheme
AuthToken CI ByteString
actualScheme (Int -> ByteString -> ByteString
drop Int
1 ByteString
tok))
else forall a b. a -> Either a b
Left Text
"scheme mismatch"
respondUnauthorized ::
( Handler h m
, Sets
h
[ Status
, RequiredResponseHeader "Content-Type" Text
, RequiredResponseHeader "WWW-Authenticate" Text
, Body PlainText Text
]
Response
) =>
CI ByteString ->
Realm ->
h a Response
respondUnauthorized :: forall (h :: * -> * -> *) (m :: * -> *) a.
(Handler h m,
Sets
h
'[Status, RequiredResponseHeader "Content-Type" Text,
RequiredResponseHeader "WWW-Authenticate" Text,
Body PlainText Text]
Response) =>
CI ByteString -> Realm -> h a Response
respondUnauthorized CI ByteString
scheme (Realm ByteString
realm) = proc a
_ -> do
let headerVal :: Text
headerVal = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
original CI ByteString
scheme forall a. Semigroup a => a -> a -> a
<> ByteString
" realm=\"" forall a. Semigroup a => a -> a -> a
<> ByteString
realm forall a. Semigroup a => a -> a -> a
<> ByteString
"\""
(forall (h :: * -> * -> *).
Set h Status Response =>
h () (With Response '[Status])
unauthorized401 -< ())
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[Status]
resp -> forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
h
'[Body mt body, RequiredResponseHeader "Content-Type" Text]
Response,
MIMEType mt) =>
mt
-> h (With Response ts, body)
(With
Response
(Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody PlainText
PlainText -< (With Response '[Status]
resp, Text
"Unauthorized" :: Text))
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
Response
'[Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
Status]
resp -> forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Required name val) Response =>
h (With Response ts, val)
(With Response (ResponseHeader 'Required name val : ts))
setHeader @"WWW-Authenticate" -< (With
Response
'[Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
Status]
resp, Text
headerVal))
forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
Response
'[RequiredResponseHeader "WWW-Authenticate" Text,
Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
Status]
resp -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA -< With
Response
'[RequiredResponseHeader "WWW-Authenticate" Text,
Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
Status]
resp)
{-# INLINE respondUnauthorized #-}