Custom combinator which accesses the Auth Context

01 readme.markdown

Problem Description

I'm working on an JSON/HTTP backend that uses cookie/access token based authentication, modelled after https://haskell-servant.readthedocs.io/en/stable/tutorial/Authentication.html#generalized-authentication

Now I would like to add role based authorization to the mix. The User datatype that I use in my AuthHandler has a role attribute.

As far as I understand it, the user object is added to the context when the authentication handler runs. So I would like to access this user object.

Unfortunately, I can't really wrap my head around HasContextEntry and getContextEntry - I only manage to produce compile errors, mostly something like this:

    Could not deduce (HasContextEntry context val0)
      arising from a use of ‘getContextEntry’
    from the context (FromHttpApiData String,
                      HasServer api context,
                      HasContextEntry context (AuthHandler Request User))
      bound by the instance declaration

My main issue is the TODO in Authorization.hs - what do I need to do to fetch the user object from the context?

Thanks in advance for any pointers :-))

02 Authorization.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module Servant.Extra.Authorization where

import           User.Model
import           User.Role                                  (Role (..))

import           Data.Typeable
import           Network.Wai                                (Request)
import           Prelude                                    ()
import           Prelude.Compat
import           Servant
import           Servant.Server.Experimental.Auth           (AuthHandler (..))
-- import           Servant.Server.Experimental.Auth           (AuthHandler (..),
--                                                              AuthServerData)
import           Servant.Server.Internal.RoutingApplication



data RoleBasedAuthorization (authRole :: Role)
    deriving Typeable


instance ( FromHttpApiData String
         , HasServer api context
         , HasContextEntry context (AuthHandler Request User)
         )
      => HasServer (RoleBasedAuthorization authRole :> api) context where

  type ServerT (RoleBasedAuthorization authRole :> api) m =
    Maybe String -> ServerT api m

  route Proxy context _ {- subserver -} =
    let
      -- TODO: WHAT DO I NEED TO DO TO GET THE USER OBJECT HERE??
    in route (Proxy :: Proxy api) context (emptyDelayed $ FailFatal err400)
    -- (passToServer subserver param)

03 Auth.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}

module Auth where

import           ScreenPal.Util                   (UUIDAsString)
import           User.Model                       as User
import qualified User.SQL
import           Util.SQLStatementMap

import           Control.Applicative
import           Control.Monad.IO.Class           (liftIO)
import qualified Crypto.PasswordStore             as PasswordStore (verifyPassword)
import qualified Data.ByteString.Char8            as BSC8
import           Data.Text                        (Text, isPrefixOf, pack,
                                                   splitOn, strip, unpack)
import           Data.Text.Encoding               (decodeUtf8)
import           Database.HDBC                    (IConnection)
import           Debug.Trace                      (trace)
import           Network.Wai
import           Servant                          (ServantErr, throwError)
import           Servant.API.BasicAuth            (BasicAuthData (BasicAuthData))
import           Servant.API.Experimental.Auth    (AuthProtect)
import           Servant.Server                   (BasicAuthCheck (BasicAuthCheck),
                                                   BasicAuthResult (Authorized, BadPassword, NoSuchUser),
                                                   Context ((:.), EmptyContext),
                                                   Handler, err401, err403,
                                                   errBody)
import           Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
                                                   mkAuthHandler)


-- | We need to supply our handlers with the right Context. In this case,
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
-- to the BasicAuth HasServer handlers.
basicAuthServerContext ::
  IConnection connection =>
  DbConnection connection
  -> Context (BasicAuthCheck User ': '[])
basicAuthServerContext dbConnection =
  (basicAuthCheck dbConnection) :. EmptyContext


-- | The context that will be made available to request handlers. We supply the
-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
-- of 'AuthProtect' can extract the handler and run it on the request.
accessTokenAuthContext ::
  IConnection connection =>
  DbConnection connection
  -> Context (AuthHandler Request User ': '[])
accessTokenAuthContext dbConnection =
  (accessTokenAuthHandler dbConnection) :. EmptyContext


-- | We need to specify the data returned after authentication
type instance AuthServerData (AuthProtect "cookie-auth") = User

-- | The auth handler wraps a function from Request -> Handler User
-- we look for a Cookie and pass the value of the cookie to `lookupUserByAccessToken`.
accessTokenAuthHandler ::
  IConnection connection =>
  DbConnection connection
  -> AuthHandler Request User
accessTokenAuthHandler dbConnection =
  let handler req =
        -- TODO Maybe use the cookie combinator from
        -- https://github.com/seanhess/serials/blob/master/server/Serials/Lib/ServantCookie.hs
        -- instead of this (until Servant comes up with a solution for reading
        -- cookies properly)
        case readAccessTokenFromRequest req of
              Nothing -> throwError (err401 { errBody = "Missing access token" })
              Just token -> lookupUserByAccessToken dbConnection token
  in mkAuthHandler handler


readAccessTokenFromRequest :: Request -> Maybe String
readAccessTokenFromRequest req =
  let headers = requestHeaders req
      cookieByteString = (lookup "Cookie" headers) <|> (lookup "cookie" headers)
      cookieString = fmap BSC8.unpack cookieByteString
      cookieText = fmap pack cookieString
  in readAccessTokenFromCookie cookieText


readAccessTokenFromCookie :: Maybe Text -> Maybe String
readAccessTokenFromCookie cookieText' =
  let individualCookies = fmap (splitOn ";") cookieText'
      individualTrimmedCookies = fmap (\cookies -> map strip cookies) individualCookies
      filtered = fmap (filter (isPrefixOf "screenpal-access-token")) individualTrimmedCookies
      fullTokenString = fmap head filtered
      splitTokenString = fmap (splitOn "=") fullTokenString
      tokenValue = fmap (head . tail) splitTokenString
  in fmap unpack tokenValue


-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
basicAuthCheck ::
  IConnection connection =>
  DbConnection connection
  -> BasicAuthCheck User
basicAuthCheck dbConnection =
  let check (BasicAuthData username' passwd) = do
             withTransaction dbConnection $ \transactedConnection ->
               basicAuthCheckIO transactedConnection username' passwd
  in BasicAuthCheck check


basicAuthCheckIO ::
  IConnection connection =>
  DbConnection connection
  -> BSC8.ByteString
  -> BSC8.ByteString
  -> IO (BasicAuthResult User)
basicAuthCheckIO dbConnection username' passwordFromRequest = do
  let usernameFromRequest = decodeUtf8 username'
  maybeUser <- User.SQL.userByNameForLogin dbConnection
                                  (unpack $ usernameFromRequest)
  case maybeUser of
     Nothing -> return $ NoSuchUser -- user not found in db
     Just user -> if PasswordStore.verifyPassword
                       passwordFromRequest
                       (User.password user)
                  then return $ Authorized user
                  else return $ BadPassword


-- | A method that, when given an access token, will return a User.
lookupUserByAccessToken ::
  IConnection connection =>
  DbConnection connection
  -> String
  -> Handler User
lookupUserByAccessToken dbConnection token = do
  result <- liftIO $
            withTransaction dbConnection $ \transactedConnection ->
              lookupIOUserByAccessToken transactedConnection token
  case result of
    Right user -> return user
    Left err -> throwError err


lookupIOUserByAccessToken ::
  IConnection connection =>
  DbConnection connection
  -> String
  -> IO (Either ServantErr User)
lookupIOUserByAccessToken dbConnection token = do
  maybeUser <- User.SQL.userByAccessTokenForSignIn dbConnection token
  case maybeUser of
    Just user -> return $ Right $ user
    Nothing   -> return $ Left $ err403 { errBody = "Invalid access token" }


-- | A function to check if the user is from the same account as the data that
-- | is about to being accessed by the current request.
checkAccountId :: UUIDAsString -> User -> Bool
checkAccountId accId authUser =
  let
    authenticatedAccountId = User.accountId authUser
    result = accId == authenticatedAccountId
  in
    if result then True
    else
      trace
        ("Rejecting attempt to access data from account {" ++
        accId ++
        "} when authenticated for account {" ++
        authenticatedAccountId ++
        "}.")
        False

04 Main.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import qualified AccessToken.SQL          (prepareStatements)
import qualified Account.SQL              (prepareStatements)
import qualified Api
import qualified Auth                     (accessTokenAuthContext)
import qualified Budget.SQL               (prepareStatements)
import qualified ConfirmEMail.SQL         (prepareStatements)
import qualified Entry.SQL                (prepareStatements)
import qualified Invite.SQL               (prepareStatements)
import qualified User.SQL                 (prepareStatements)
import qualified Util.Config              as Config
import           Util.Localisation
import qualified Util.Migration           as Migration
import           Util.SQLStatementMap
import           Util.Template

import           Control.Exception        (bracket)
import           Control.Monad.Catch      (Handler)
import           Control.Retry
import qualified Data.Map.Strict          as Map
import           Data.Monoid              ((<>))
import           Database.HDBC            hiding (run)
import           Database.HDBC.PostgreSQL as PostgreSQL (Connection,
                                                         connectPostgreSQL)
import           Network.Wai
import           Network.Wai.Handler.Warp
import           Servant                  hiding (Handler)
import           Servant.EDE


main :: IO ()
main = do
  (dbConfig, eMailConfig) <- Config.readConfig
  parsedTranslations <- parseLocalisationComplete
  Migration.upgradeDatabase dbConfig
  withPostgreSQL dbConfig
    (initialize parsedTranslations eMailConfig)


initialize ::
  IConnection connection =>
  Translations
  -> Config.EMailConfig
  -> connection
  -> IO ()
initialize parsedTranslations eMailConfig connection = do
  putStrLn "Compiling EDE templates..."
  templateErrors :: [TemplateError] <-
    loadTemplates Api.api (edeFilters parsedTranslations) "backend/templates"
  if null templateErrors
    then putStrLn "EDE templates have been compiled successfully."
    else do echoTemplateErrors templateErrors
            error "There have been errors during EDE template compilation, \
                  \exiting."
  putStrLn "Compiling prepared SQL statements..."
  dbConnection <- prepareStatements connection
  let missingStatementIDs = findMissingStatements $ stmts dbConnection
  if null missingStatementIDs
    then putStrLn "Prepared SQL statements have been compiled successfully."
    else error ("Missing StatementIDs in compiled prepared SQL statements: \n" ++
               (show missingStatementIDs) ++ "\n Exiting.")
  run 1207 {- $ corsMiddleware -} $ app parsedTranslations eMailConfig dbConnection


withPostgreSQL ::
  Config.DbConfig
  -> (PostgreSQL.Connection -> IO a)
  -> IO a
withPostgreSQL dbConfig =
  bracket (connectToPostgres dbConfig) disconnect


-- Connects to PostgreSQL. When the connection fails, the connection attempt
-- will be retried every 0.5 seconds with 600 retries max (that is, it tries for
-- 5 minutes)
connectToPostgres ::
  Config.DbConfig
  -> IO PostgreSQL.Connection
connectToPostgres dbConfig =
  let
    -- delay is in microseconds/μs (millionth of a second,
    -- 1000 μs = 1 millisecond)
    delay = 500000 -- 1/2 second
    policy :: RetryPolicyM IO =
      constantDelay delay <> limitRetries 600
    reportSqlError :: Bool -> SqlError -> RetryStatus -> IO ()
    reportSqlError retriedOrCrashed err retryStatus = do
       putStrLn $ defaultLogMsg retriedOrCrashed err retryStatus
    retryOnAnySqlError :: SqlError -> IO Bool
    retryOnAnySqlError _ = return True
    retryOnAnyStatus :: RetryStatus -> Handler IO Bool
    retryOnAnyStatus = logRetries retryOnAnySqlError reportSqlError
    connectUrl = "host="      ++ (Config.dbHost     dbConfig) ++
                 " dbname="   ++ (Config.db         dbConfig) ++
                 " user="     ++ (Config.dbUser     dbConfig) ++
                 " password=" ++ (Config.dbPassword dbConfig)
    connect _ =
       PostgreSQL.connectPostgreSQL connectUrl
 in
    recovering
       policy
       [retryOnAnyStatus]
       connect


prepareStatements ::
  IConnection connection =>
  connection
  -> IO (DbConnection connection)
prepareStatements cn = do
  let dbConnection = DbConnection
                     { conn = cn
                     , stmts = Map.empty
                     }
  AccessToken.SQL.prepareStatements dbConnection
  >>= Account.SQL.prepareStatements
  >>= Budget.SQL.prepareStatements
  >>= ConfirmEMail.SQL.prepareStatements
  >>= Entry.SQL.prepareStatements
  >>= Invite.SQL.prepareStatements
  >>= User.SQL.prepareStatements
  >>= return


app ::
  IConnection connection =>
  Translations
  -> Config.EMailConfig
  -> DbConnection connection
  -> Application
app parsedTranslations eMailConfig dbConnection =
  serveWithContext Api.api
    (Auth.accessTokenAuthContext dbConnection)
    (Api.rootServer parsedTranslations eMailConfig dbConnection)