{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Web.Eved.Auth
    where

import qualified Data.ByteString     as BS
import           Data.List.NonEmpty  (NonEmpty (..), nonEmpty)
import           Data.Text           (Text)
import qualified Data.Text           as T
import           Data.Text.Encoding  (decodeUtf8, encodeUtf8)
import qualified Network.HTTP.Client as HTTP
import           Network.HTTP.Types  (hAuthorization, unauthorized401)
import qualified Network.Wai         as Wai
import qualified Web.Eved.Client     as Client
import           Web.Eved.Internal
import qualified Web.Eved.Server     as Server

auth :: (Eved api m, EvedAuth api, Applicative f)
     => NonEmpty (f (AuthScheme a)) -> f (api b) -> f (api (a -> b))
auth :: NonEmpty (f (AuthScheme a)) -> f (api b) -> f (api (a -> b))
auth NonEmpty (f (AuthScheme a))
schemes f (api b)
next = NonEmpty (AuthScheme a) -> api b -> api (a -> b)
forall (api :: * -> *) a b.
EvedAuth api =>
NonEmpty (AuthScheme a) -> api b -> api (a -> b)
auth_ (NonEmpty (AuthScheme a) -> api b -> api (a -> b))
-> f (NonEmpty (AuthScheme a)) -> f (api b -> api (a -> b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (f (AuthScheme a)) -> f (NonEmpty (AuthScheme a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA NonEmpty (f (AuthScheme a))
schemes f (api b -> api (a -> b)) -> f (api b) -> f (api (a -> b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (api b)
next


class EvedAuth api where
    auth_ :: NonEmpty (AuthScheme a) -> api b -> api (a -> b)

data AuthResult a
    = AuthSuccess a
    | AuthFailure Text
    | AuthNeeded

data AuthScheme a = AuthScheme
    { AuthScheme a -> Request -> IO (AuthResult a)
authenticateRequest :: Wai.Request -> IO (AuthResult a)
    , AuthScheme a -> a -> Request -> Request
addCredentials      :: a -> HTTP.Request -> HTTP.Request
    }

data BasicAuth = BasicAuth
    { BasicAuth -> Text
basicAuthUsername :: Text
    , BasicAuth -> Text
basicAuthPassword :: Text
    }

basicAuth :: AuthScheme BasicAuth
basicAuth :: AuthScheme BasicAuth
basicAuth = AuthScheme :: forall a.
(Request -> IO (AuthResult a))
-> (a -> Request -> Request) -> AuthScheme a
AuthScheme
    { authenticateRequest :: Request -> IO (AuthResult BasicAuth)
authenticateRequest = \Request
req ->
        case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAuthorization ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req of
          Just ByteString
authHeader ->
            let (Text
authType, Text
rest) = Text -> Text -> (Text, Text)
T.breakOn Text
" " (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
authHeader
            in
            if Text -> Text
T.toLower Text
authType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"basic" then
               let (Text
username, Text
rest') = Text -> Text -> (Text, Text)
T.breakOn Text
":" (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
rest
                   password :: Text
password = Int -> Text -> Text
T.drop Int
1 Text
rest'
               in AuthResult BasicAuth -> IO (AuthResult BasicAuth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult BasicAuth -> IO (AuthResult BasicAuth))
-> AuthResult BasicAuth -> IO (AuthResult BasicAuth)
forall a b. (a -> b) -> a -> b
$ BasicAuth -> AuthResult BasicAuth
forall a. a -> AuthResult a
AuthSuccess (Text -> Text -> BasicAuth
BasicAuth Text
username Text
password)
            else
               AuthResult BasicAuth -> IO (AuthResult BasicAuth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult BasicAuth
forall a. AuthResult a
AuthNeeded
          Maybe ByteString
Nothing ->
              AuthResult BasicAuth -> IO (AuthResult BasicAuth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult BasicAuth
forall a. AuthResult a
AuthNeeded
    , addCredentials :: BasicAuth -> Request -> Request
addCredentials = \BasicAuth
creds ->
        ByteString -> ByteString -> Request -> Request
HTTP.applyBasicAuth
            (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ BasicAuth -> Text
basicAuthUsername BasicAuth
creds)
            (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ BasicAuth -> Text
basicAuthPassword BasicAuth
creds)
    }


instance EvedAuth Client.EvedClient where
    auth_ :: NonEmpty (AuthScheme a) -> EvedClient b -> EvedClient (a -> b)
auth_ (AuthScheme a
scheme :| [AuthScheme a]
_) EvedClient b
next = (Request -> a -> b) -> EvedClient (a -> b)
forall a. (Request -> a) -> EvedClient a
Client.EvedClient ((Request -> a -> b) -> EvedClient (a -> b))
-> (Request -> a -> b) -> EvedClient (a -> b)
forall a b. (a -> b) -> a -> b
$ \Request
req a
a ->
        EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
Client.client EvedClient b
next (Request -> b) -> Request -> b
forall a b. (a -> b) -> a -> b
$ AuthScheme a -> a -> Request -> Request
forall a. AuthScheme a -> a -> Request -> Request
addCredentials AuthScheme a
scheme a
a Request
req

instance EvedAuth (Server.EvedServerT m) where
    auth_ :: NonEmpty (AuthScheme a)
-> EvedServerT m b -> EvedServerT m (a -> b)
auth_ NonEmpty (AuthScheme a)
schemes EvedServerT m b
next = ((forall a. m a -> IO a)
 -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall (m :: * -> *) a.
((forall a. m a -> IO a) -> [Text] -> RequestData a -> Application)
-> EvedServerT m a
Server.EvedServerT (((forall a. m a -> IO a)
  -> [Text] -> RequestData (a -> b) -> Application)
 -> EvedServerT m (a -> b))
-> ((forall a. m a -> IO a)
    -> [Text] -> RequestData (a -> b) -> Application)
-> EvedServerT m (a -> b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
nt [Text]
path RequestData (a -> b)
action Request
req Response -> IO ResponseReceived
resp ->
        Request -> NonEmpty (AuthScheme a) -> IO (AuthResult a)
forall a. Request -> NonEmpty (AuthScheme a) -> IO (AuthResult a)
go Request
req NonEmpty (AuthScheme a)
schemes IO (AuthResult a)
-> (AuthResult a -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              AuthSuccess a
a -> EvedServerT m b
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData b
-> Application
forall (m :: * -> *) a.
EvedServerT m a
-> (forall a. m a -> IO a)
-> [Text]
-> RequestData a
-> Application
Server.unEvedServerT EvedServerT m b
next forall a. m a -> IO a
nt [Text]
path (((a -> b) -> b) -> RequestData (a -> b) -> RequestData b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) RequestData (a -> b)
action) Request
req Response -> IO ResponseReceived
resp
              AuthResult a
_             -> Response -> IO ResponseReceived
resp (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
Wai.responseLBS Status
unauthorized401 [] ByteString
"Unauthorized"


         where
             go :: Request -> NonEmpty (AuthScheme a) -> IO (AuthResult a)
go Request
request (AuthScheme a
s :| [AuthScheme a]
rest) =
                 AuthScheme a -> Request -> IO (AuthResult a)
forall a. AuthScheme a -> Request -> IO (AuthResult a)
authenticateRequest AuthScheme a
s Request
request IO (AuthResult a)
-> (AuthResult a -> IO (AuthResult a)) -> IO (AuthResult a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   AuthSuccess a
a -> AuthResult a -> IO (AuthResult a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult a -> IO (AuthResult a))
-> AuthResult a -> IO (AuthResult a)
forall a b. (a -> b) -> a -> b
$ a -> AuthResult a
forall a. a -> AuthResult a
AuthSuccess a
a
                   AuthFailure Text
err -> AuthResult a -> IO (AuthResult a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult a -> IO (AuthResult a))
-> AuthResult a -> IO (AuthResult a)
forall a b. (a -> b) -> a -> b
$ Text -> AuthResult a
forall a. Text -> AuthResult a
AuthFailure Text
err
                   AuthResult a
AuthNeeded -> IO (AuthResult a)
-> (NonEmpty (AuthScheme a) -> IO (AuthResult a))
-> Maybe (NonEmpty (AuthScheme a))
-> IO (AuthResult a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthResult a -> IO (AuthResult a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult a -> IO (AuthResult a))
-> AuthResult a -> IO (AuthResult a)
forall a b. (a -> b) -> a -> b
$ Text -> AuthResult a
forall a. Text -> AuthResult a
AuthFailure Text
"No matching AuthScheme found")
                                       (Request -> NonEmpty (AuthScheme a) -> IO (AuthResult a)
go Request
request)
                                       ([AuthScheme a] -> Maybe (NonEmpty (AuthScheme a))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [AuthScheme a]
rest)