module Web.Minion.Examples.BasicAuth (app) where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Reader (ReaderT (..), ask)
import Data.IORef (IORef, newIORef, readIORef)
import Data.List (elemIndex)
import Web.Minion
import Web.Minion.Auth.Basic
import Web.Minion.Error (codeOf, unauthorized)

type Env = IORef [BasicAuth]
type M = ReaderT Env IO

app :: IO (ApplicationM IO)
app :: IO (ApplicationM IO)
app = do
  IORef [BasicAuth]
users <-
    [BasicAuth] -> IO (IORef [BasicAuth])
forall a. a -> IO (IORef a)
newIORef
      [ Username -> Password -> BasicAuth
BasicAuth Username
"alice" Password
"123"
      , Username -> Password -> BasicAuth
BasicAuth Username
"bob" Password
"312"
      , Username -> Password -> BasicAuth
BasicAuth Username
"admin" Password
"admin"
      ]
  ApplicationM IO -> IO (ApplicationM IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApplicationM IO -> IO (ApplicationM IO))
-> ApplicationM IO -> IO (ApplicationM IO)
forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
resp -> ReaderT (IORef [BasicAuth]) IO ResponseReceived
-> IORef [BasicAuth] -> IO ResponseReceived
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> ApplicationM (ReaderT (IORef [BasicAuth]) IO)
forall (m :: * -> *) i.
(MonadIO m, MonadCatch m) =>
Router' i Void m -> ApplicationM m
serve Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
api Request
req Response -> IO ResponseReceived
resp) IORef [BasicAuth]
users

api :: Router Void M
api :: Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
api = Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
"api" (Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
 -> Router' Void Void (ReaderT (IORef [BasicAuth]) IO))
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
forall i ts (r :: * -> *).
(Router' i ts r -> Router' i ts r)
-> Router' i ts r -> Router' i ts r
/> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
"auth" (Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
 -> Router' Void Void (ReaderT (IORef [BasicAuth]) IO))
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
forall i ts (r :: * -> *).
(Router' i ts r -> Router' i ts r)
-> Router' i ts r -> Router' i ts r
/> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
"basic" (Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
 -> Router' Void Void (ReaderT (IORef [BasicAuth]) IO))
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
-> Router' Void Void (ReaderT (IORef [BasicAuth]) IO)
forall i ts (r :: * -> *).
(Router' i ts r -> Router' i ts r)
-> Router' i ts r -> Router' i ts r
/> ValueCombinator
  Void
  (WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId))
  Void
  (ReaderT (IORef [BasicAuth]) IO)
forall ts.
ValueCombinator
  Void
  (WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId))
  ts
  (ReaderT (IORef [BasicAuth]) IO)
myAuth ValueCombinator
  Void
  (WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId))
  Void
  (ReaderT (IORef [BasicAuth]) IO)
-> ValueCombinator
     Void
     (WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId))
     Void
     (ReaderT (IORef [BasicAuth]) IO)
forall i ts' (r :: * -> *) ts.
(Router' i ts' r -> Router' i ts r)
-> Router' i ts' r -> Router' i ts r
.> forall o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, ToResponse m o, CanRespond o,
 Introspection i 'Response o) =>
Method -> (DelayedArgs st ~> m o) -> Router' i ts m
handle @NoBody Method
GET DelayedArgs
  '[WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId)]
~> M NoBody
UserId -> M NoBody
forall {m :: * -> *}. MonadIO m => UserId -> m NoBody
endpoint
 where
  endpoint :: UserId -> m NoBody
endpoint (UserId Int
userId) = IO NoBody -> m NoBody
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Called " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
userId
    NoBody -> IO NoBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoBody
NoBody

newtype UserId = UserId Int

basicAuthSettings :: HList '[BasicAuthSettings M UserId]
basicAuthSettings :: HList '[BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId]
basicAuthSettings =
  BasicAuthSettings
    { $sel:check:BasicAuthSettings :: MakeError
-> BasicAuth -> ReaderT (IORef [BasicAuth]) IO (AuthResult UserId)
check = \MakeError
_ BasicAuth
ba -> do
        IORef [BasicAuth]
usersRef <- ReaderT (IORef [BasicAuth]) IO (IORef [BasicAuth])
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        [BasicAuth]
users <- IO [BasicAuth] -> ReaderT (IORef [BasicAuth]) IO [BasicAuth]
forall a. IO a -> ReaderT (IORef [BasicAuth]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [BasicAuth] -> ReaderT (IORef [BasicAuth]) IO [BasicAuth])
-> IO [BasicAuth] -> ReaderT (IORef [BasicAuth]) IO [BasicAuth]
forall a b. (a -> b) -> a -> b
$ IORef [BasicAuth] -> IO [BasicAuth]
forall a. IORef a -> IO a
readIORef IORef [BasicAuth]
usersRef
        AuthResult UserId
-> ReaderT (IORef [BasicAuth]) IO (AuthResult UserId)
forall a. a -> ReaderT (IORef [BasicAuth]) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthResult UserId
 -> ReaderT (IORef [BasicAuth]) IO (AuthResult UserId))
-> AuthResult UserId
-> ReaderT (IORef [BasicAuth]) IO (AuthResult UserId)
forall a b. (a -> b) -> a -> b
$ AuthResult UserId
-> (Int -> AuthResult UserId) -> Maybe Int -> AuthResult UserId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthResult UserId
forall a. AuthResult a
BadAuth (UserId -> AuthResult UserId
forall a. a -> AuthResult a
Authenticated (UserId -> AuthResult UserId)
-> (Int -> UserId) -> Int -> AuthResult UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> UserId
UserId) (Maybe Int -> AuthResult UserId) -> Maybe Int -> AuthResult UserId
forall a b. (a -> b) -> a -> b
$ BasicAuth -> [BasicAuth] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex BasicAuth
ba [BasicAuth]
users
    }
    BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId
-> HList '[]
-> HList
     '[BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId]
forall t (ts1 :: [*]). t -> HList ts1 -> HList (t : ts1)
:# HList '[]
HNil

myAuth :: ValueCombinator Void (WithReq M (Auth '[Basic] UserId)) ts M
myAuth :: forall ts.
ValueCombinator
  Void
  (WithReq (ReaderT (IORef [BasicAuth]) IO) (Auth '[Basic] UserId))
  ts
  (ReaderT (IORef [BasicAuth]) IO)
myAuth = forall (auths :: [*]) a (m :: * -> *) (ctx :: [*]) ts i.
(Introspection i 'Request (Auth auths a), UnwindAuth ctx auths m a,
 MonadThrow m) =>
m (HList ctx)
-> (MakeError -> AuthResult Void -> m Void)
-> ValueCombinator i (WithReq m (Auth auths a)) ts m
auth @'[Basic] @UserId (HList '[BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId]
-> M (HList
        '[BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId])
forall a. a -> ReaderT (IORef [BasicAuth]) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[BasicAuthSettings (ReaderT (IORef [BasicAuth]) IO) UserId]
basicAuthSettings) \MakeError
makeError -> \case
  AuthResult Void
_ -> do
    IO () -> M ()
forall a. IO a -> ReaderT (IORef [BasicAuth]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Unauthozied!"
    ServerError -> M Void
forall e a. (HasCallStack, Exception e) => e -> M a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerError -> M Void) -> ServerError -> M Void
forall a b. (a -> b) -> a -> b
$ MakeError
makeError (ServerError -> Status
codeOf ServerError
unauthorized) ByteString
forall a. Monoid a => a
mempty