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 qualified Network.HTTP.Types as HTTP
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Core.Handler (Handler, unlinkA)
import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Get (..), Linked, Sets)
import WebGear.Core.Trait.Body (Body, respondA)
import WebGear.Core.Trait.Header (Header (..), RequiredHeader, setHeader)
import WebGear.Core.Trait.Status (Status)
import Prelude hiding (break, drop)
type scheme = Header Optional Lenient "Authorization" (AuthToken scheme)
getAuthorizationHeaderTrait ::
forall scheme h ts.
Get h (AuthorizationHeader scheme) Request =>
h (Linked ts Request) (Maybe (Either Text (AuthToken scheme)))
= proc Linked ts Request
request -> do
Either Void (Maybe (Either Text (AuthToken scheme)))
result <- forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Attribute t a))
getTrait (forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header :: Header Optional Lenient "Authorization" (AuthToken scheme)) -< Linked ts Request
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
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
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
, RequiredHeader "Content-Type" Text
, RequiredHeader "WWW-Authenticate" Text
, Body Text
]
Response
) =>
CI ByteString ->
Realm ->
h a Response
respondUnauthorized :: forall (h :: * -> * -> *) (m :: * -> *) a.
(Handler h m,
Sets
h
'[Status, RequiredHeader "Content-Type" Text,
RequiredHeader "WWW-Authenticate" Text, Body 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 :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (Linked ts Response) Response
unlinkA
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall (name :: Symbol) val a (h :: * -> * -> *) (res :: [*]).
Set h (Header 'Required 'Strict name val) Response =>
h a (Linked res Response)
-> h (val, a)
(Linked (Header 'Required 'Strict name val : res) Response)
setHeader @"WWW-Authenticate" (forall body (h :: * -> * -> *).
Sets
h
'[Status, Body body, RequiredHeader "Content-Type" Text]
Response =>
Status
-> MediaType
-> h body
(Linked
'[RequiredHeader "Content-Type" Text, Body body, Status] Response)
respondA Status
HTTP.unauthorized401 MediaType
"text/plain")
-<
(Text
headerVal, Text
"Unauthorized" :: Text)