Auth.hs

{-|
Description: Auth hook for routing

A generic authentication hook for TsWeb routing. The goal here is to be able
to specify authentication requirements in a view's type, so that the routing
statically guarantees that a view can only be entered when session
preconditions are met. A full example of this is under the Example module of
this source tree, but a synopsis follows. Given a session/user definition like
so:

@
  data UserT f = User
    { _userId :: C f Int
    , _userLogin :: C f Text
    } deriving (Generic)
  ...
  data SessionDataT f = SessionData
    { _sdUser :: PrimaryKey UserT (Nullable f)
    , _sdRemember :: C f Bool
    } deriving (Generic)
  ...

  userP :: 'Data.Proxy.Proxy' User
  userP = Proxy
@

then we can define a logged-in 'Authorize' check as

@
instance Authorize SessionData User where
  checkAuth _ =
    _sdUser \<$\> 'Web.Spock.readSession' >>= \case
      UserId Nothing -> pure Nothing
      UserId (Just uid) ->
        'TsWeb.Db.queryMaybe' ('Database.Beam.select' $ q uid) >>= \case
          QSimply (Just user) -> pure $ Just user
          _ -> pure Nothing
    where
      q uid = do
        u <- 'Database.Beam.all_' $ _dbUser db
        'Database.Beam.guard_' $ _userId u ==. 'Database.Beam.val_' uid
        pure u
@

A view requiring an authenticated user would have a signature like

@
  authd :: ListContains n User xs => TsActionCtxT lts xs SessionData a
  authd = do
    user :: User <- 'TsWeb.Action.getExtra'
    ...
@

Finally, the route for only allowing logged-in users would look like

@
  'TsWeb.Routing.runroute' ro rw $ 'TsWeb.Routing.path' #authd "authd" $ `TsWeb.Routing.get' $ 'auth' userP authd
@

That view is statically defined to only be accessible to logged-in users; any
anonymous session will either go to an alternate (non-auth) view, or get a
404.
-}
module TsWeb.Routing.Auth where

import TsWeb.Types (Context(..), TsActionCtxT)
import TsWeb.Types.Db (ReadOnlyPool)

import Data.HVect (HVect((:&:)), ListContains)
import Data.Proxy (Proxy)
import Web.Spock (getContext)
import Web.Spock.Action (jumpNext, runInContext)

-- | A class for session data that needs to be statically verified against
-- routes. This could be checks for optional session info, or to validate the
-- value of that session information.
class Authorize sess perm where
  -- | Load a value out of the session or return Nothing. Used in the context
  -- of 'auth', the wrapped view will only be called when this returns Just; a
  -- Nothing value will cause the wrapped view to be skipped.
  checkAuth ::
       ListContains n ReadOnlyPool xs
    => Proxy perm
    -> TsActionCtxT lts xs sess (Maybe perm)

-- | Guarantee that the Spock session hold some verified piece of data. If the
-- requisite data can be loaded, then the view is called with the data in its
-- ctxExtras; otherwise 'Web.Spock.Action.jumpNext' is called and the view is
-- skipped.
auth ::
     (Authorize sess perm, ListContains n ReadOnlyPool xs, Authorize sess perm)
  => Proxy perm
  -> TsActionCtxT lts (perm ': xs) sess ()
  -> TsActionCtxT lts xs sess ()
auth proxy action =
  checkAuth proxy >>= \case
    Nothing -> jumpNext
    Just a -> do
      ctx <- getContext
      runInContext (ctx {ctxExtras = a :&: ctxExtras ctx}) action