Servant type-safe auth

servant-auth

type Protect (r :: UserRole) = AuthProtect r

data AuthUser (r :: UserRole) = AuthUser { authUserName :: Text, authUserRole :: UserRole }
  deriving (Read, Show, Generic)

instance Store (AuthUser r)

encryptAuthUserIO :: Key -> AuthUser r -> IO ByteString
encryptAuthUserIO key user = encryptIO key $ encode user

encryptAuthUser :: Key -> IV -> AuthUser r -> ByteString
encryptAuthUser key iv user = encrypt key iv $ encode user

authHandlerFor :: forall (r :: UserRole) . Unproxy r => Config -> Proxy r -> AuthHandler Request (AuthUser r)
authHandlerFor cfg roleProxy = mkAuthHandler handler
  where
    handler :: Request -> Handler (AuthUser r)
    handler req =
      case decodeUser req of
        Just user ->
          case authUserRole user of
            AdminRole -> return user
            EmployeeRole ->
              if authUserRole user == unproxy roleProxy
              then return user
              else throwError err403
        Nothing -> throwError (err401 { errBody = "Missing/invalid auth header" })
    decodeUser :: Request -> Maybe (AuthUser r)
    decodeUser req = do
      authCookie <- lookup "auth-cookie" (requestHeaders req)
      decryptedCookie <- decrypt (encryptionKey cfg) authCookie
      hush $ decode decryptedCookie

type instance AuthServerData (AuthProtect r) = AuthUser r

authServerContext :: Config -> Context (AuthHandler Request (AuthUser 'AdminRole) ': AuthHandler Request (AuthUser 'EmployeeRole) ': '[])
authServerContext cfg = (authHandlerFor cfg Proxy) :. (authHandlerFor cfg Proxy) :. EmptyContext

class Unproxy (r :: UserRole) where
  unproxy :: Proxy r -> UserRole

instance Unproxy 'AdminRole where
  unproxy _ = AdminRole

instance Unproxy 'EmployeeRole where
  unproxy _ = EmployeeRole