module Web.Minion.Auth.Basic where

import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.ByteString qualified as Bytes
import Data.ByteString.Base64 qualified as Bytes.Base64
import Data.Function ((&))
import Data.String (IsString (..))
import Data.String.Conversions (ConvertibleStrings (convertString))
import Network.HTTP.Types.Header qualified as Http
import Network.Wai qualified as Wai
import Web.Minion

newtype BasicAuthSettings m a = BasicAuthSettings
  { forall (m :: * -> *) a.
BasicAuthSettings m a -> MakeError -> BasicAuth -> m (AuthResult a)
check :: MakeError -> BasicAuth -> m (AuthResult a)
  }

data BasicAuth = BasicAuth
  { BasicAuth -> Username
username :: Username
  , BasicAuth -> Password
password :: Password
  }
  deriving (BasicAuth -> BasicAuth -> Bool
(BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool) -> Eq BasicAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BasicAuth -> BasicAuth -> Bool
== :: BasicAuth -> BasicAuth -> Bool
$c/= :: BasicAuth -> BasicAuth -> Bool
/= :: BasicAuth -> BasicAuth -> Bool
Eq, Eq BasicAuth
Eq BasicAuth =>
(BasicAuth -> BasicAuth -> Ordering)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> BasicAuth)
-> (BasicAuth -> BasicAuth -> BasicAuth)
-> Ord BasicAuth
BasicAuth -> BasicAuth -> Bool
BasicAuth -> BasicAuth -> Ordering
BasicAuth -> BasicAuth -> BasicAuth
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 :: BasicAuth -> BasicAuth -> Ordering
compare :: BasicAuth -> BasicAuth -> Ordering
$c< :: BasicAuth -> BasicAuth -> Bool
< :: BasicAuth -> BasicAuth -> Bool
$c<= :: BasicAuth -> BasicAuth -> Bool
<= :: BasicAuth -> BasicAuth -> Bool
$c> :: BasicAuth -> BasicAuth -> Bool
> :: BasicAuth -> BasicAuth -> Bool
$c>= :: BasicAuth -> BasicAuth -> Bool
>= :: BasicAuth -> BasicAuth -> Bool
$cmax :: BasicAuth -> BasicAuth -> BasicAuth
max :: BasicAuth -> BasicAuth -> BasicAuth
$cmin :: BasicAuth -> BasicAuth -> BasicAuth
min :: BasicAuth -> BasicAuth -> BasicAuth
Ord)

newtype Username = Username {Username -> ByteString
rawUsername :: Bytes.ByteString}
  deriving (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)

instance IsString Username where
  fromString :: String -> Username
fromString = ByteString -> Username
Username (ByteString -> Username)
-> (String -> ByteString) -> String -> Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString

instance IsString Password where
  fromString :: String -> Password
fromString = ByteString -> Password
Password (ByteString -> Password)
-> (String -> ByteString) -> String -> Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
convertString

newtype Password = Password {Password -> ByteString
rawPassword :: Bytes.ByteString}
  deriving (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)

data Basic

instance (Monad m) => IsAuth Basic m a where
  type Settings Basic m a = BasicAuthSettings m a
  toAuth :: Settings Basic m a -> ErrorBuilder -> Request -> m (AuthResult a)
toAuth BasicAuthSettings{MakeError -> BasicAuth -> m (AuthResult a)
$sel:check:BasicAuthSettings :: forall (m :: * -> *) a.
BasicAuthSettings m a -> MakeError -> BasicAuth -> m (AuthResult a)
check :: MakeError -> BasicAuth -> m (AuthResult a)
..} ErrorBuilder
buildError Request
req = do
    Maybe BasicAuth
mbBasicAuth <- MaybeT m BasicAuth -> m (Maybe BasicAuth)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      ByteString
authHeader <- Request -> RequestHeaders
Wai.requestHeaders Request
req RequestHeaders
-> (RequestHeaders -> Maybe ByteString) -> Maybe ByteString
forall a b. a -> (a -> b) -> b
& HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
Http.hAuthorization Maybe ByteString
-> (Maybe ByteString -> MaybeT m ByteString) -> MaybeT m ByteString
forall a b. a -> (a -> b) -> b
& Maybe ByteString -> MaybeT m ByteString
forall {a}. Maybe a -> MaybeT m a
hoistMaybe
      ByteString
base64 <- ByteString -> ByteString -> Maybe ByteString
Bytes.stripPrefix ByteString
"Basic " ByteString
authHeader Maybe ByteString
-> (Maybe ByteString -> MaybeT m ByteString) -> MaybeT m ByteString
forall a b. a -> (a -> b) -> b
& Maybe ByteString -> MaybeT m ByteString
forall {a}. Maybe a -> MaybeT m a
hoistMaybe
      let decoded :: ByteString
decoded = ByteString
base64 ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& ByteString -> ByteString
Bytes.Base64.decodeLenient
      -- 58 is ':'
      [ByteString -> Username
Item [ByteString] -> Username
Username -> Username
username, ByteString -> Password
Item [ByteString] -> Password
Password -> Password
password] <- Word8 -> ByteString -> [ByteString]
Bytes.split Word8
58 ByteString
decoded [ByteString]
-> ([ByteString] -> Maybe [ByteString]) -> Maybe [ByteString]
forall a b. a -> (a -> b) -> b
& [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [ByteString]
-> (Maybe [ByteString] -> MaybeT m [ByteString])
-> MaybeT m [ByteString]
forall a b. a -> (a -> b) -> b
& Maybe [ByteString] -> MaybeT m [ByteString]
forall {a}. Maybe a -> MaybeT m a
hoistMaybe
      BasicAuth -> MaybeT m BasicAuth
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BasicAuth{Password
Username
$sel:username:BasicAuth :: Username
$sel:password:BasicAuth :: Password
username :: Username
password :: Password
..}
    m (AuthResult a)
-> (BasicAuth -> m (AuthResult a))
-> Maybe BasicAuth
-> m (AuthResult a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      do AuthResult a -> m (AuthResult a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult a
forall a. AuthResult a
Indefinite
      do MakeError -> BasicAuth -> m (AuthResult a)
check (ErrorBuilder
buildError Request
req)
      do Maybe BasicAuth
mbBasicAuth
   where
    hoistMaybe :: Maybe a -> MaybeT m a
hoistMaybe = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (Maybe a -> m (Maybe a)) -> Maybe a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure