{-|
Module: IHP.Controller.BasicAuth
Description: Very Simple Basic Auth
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Controller.BasicAuth (basicAuth) where

import IHP.Prelude
import IHP.ControllerSupport
import Network.HTTP.Types (status401)
import Network.Wai (responseLBS)
import Network.Wai.Middleware.HttpAuth (extractBasicAuth)
import Network.HTTP.Types.Header (hWWWAuthenticate)

-- | Adds basic http authentication
--
-- Mainly for protecting a site during external review.
-- Meant for use in the controller:
-- 
-- > beforeAction = basicAuth ... 
-- 
basicAuth :: (?context :: ControllerContext) => Text -> Text -> Text -> IO ()
basicAuth :: (?context::ControllerContext) => Text -> Text -> Text -> IO ()
basicAuth Text
uid Text
pw Text
realm = do
    let mein :: Maybe (ByteString, ByteString)
mein = (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
uid, Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
pw)
    let cred :: Maybe (ByteString, ByteString)
cred = Maybe (Maybe (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (ByteString, ByteString))
 -> Maybe (ByteString, ByteString))
-> Maybe (Maybe (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe (ByteString, ByteString))
-> Maybe ByteString -> Maybe (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe (ByteString, ByteString)
extractBasicAuth ((?context::ControllerContext) => ByteString -> Maybe ByteString
ByteString -> Maybe ByteString
getHeader ByteString
"Authorization")
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (ByteString, ByteString)
cred Maybe (ByteString, ByteString)
-> Maybe (ByteString, ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (ByteString, ByteString)
mein) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (?context::ControllerContext) => Response -> IO ()
Response -> IO ()
respondAndExit (Response -> IO ()) -> Response -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status401 [(HeaderName
hWWWAuthenticate,Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text
"Basic " Text -> Text -> Text
forall {a}. Semigroup a => a -> a -> a
++ (if Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Text
realm then Text
"" else Text
"realm=\"" Text -> Text -> Text
forall {a}. Semigroup a => a -> a -> a
++ Text
realm Text -> Text -> Text
forall {a}. Semigroup a => a -> a -> a
++ Text
"\", ") Text -> Text -> Text
forall {a}. Semigroup a => a -> a -> a
++ Text
"charset=\"UTF-8\""))] ByteString
""