Roles.hs

{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds,
             ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Gorilla.Auth.Roles where

import           Control.Monad.Trans                        (liftIO)
import           Control.Monad.Trans.Except                 (runExceptT)
import           Data.Proxy                                 (Proxy (Proxy))
import           Data.Typeable                              (Typeable)
import           GHC.Generics                               (Generic)
import           Network.Wai                                (Request)

import           Servant                                    ((:>))
import           Servant.API.Experimental.Auth
import           Servant.Client
import           Servant.Server.Experimental.Auth
import           Servant.Server.Internal                    (HasContextEntry, HasServer, ServerT, getContextEntry, route)
import           Servant.Server.Internal.RoutingApplication (DelayedIO, addAuthCheck, delayedFailFatal, withRequest)
import           Servant.Server.Internal.ServantErr         (Handler)

-- * Role Based Access Control
--
-- Provides API combinators to protect endpoints with role checks.
-- Use like this:
--
-- > type instance AuthServerData (AuthProtect "cookie-auth") = UserAccount
-- > type instance AuthCookieData = UserAccount
-- > type MyApi = UserInRole Roles "auth-cookie" :> "foo" :> GET [ String ]

-- | Combinator for handling roles
-- This combinator takes two types: The type of role which is allowed access to
-- the resource and a tag to infer the type of data that is retrieved from "Session"
data UserInRole (aRole :: k) (tag :: k') deriving (Typeable)

-- | Extracts the role of a user
newtype RoleChecker aRole usr =
  RoleChecker { unRoleChecker :: usr -> Handler (Proxy aRole) }
                             deriving (Generic, Typeable)

-- | Known orphan instance.
instance ( HasServer api context
         , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
         , HasContextEntry context (RoleChecker aRole (AuthServerData (AuthProtect tag)))
         ) => HasServer (UserInRole aRole tag :> api) context where

  type ServerT (UserInRole aRole tag :> api) m =
    ServerT api m

  route Proxy context subserver =
    route (Proxy :: Proxy api) context ((const <$> subserver) -- we don't use the output of the checker
                                        `addAuthCheck` withRequest roleCheck)
      where
        authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
        authHandler = unAuthHandler (getContextEntry context)

        roleChecker :: AuthServerData (AuthProtect tag) -> Handler (Proxy aRole)
        roleChecker = unRoleChecker (getContextEntry context)

        doCheck :: Request -> Handler (Proxy aRole)
        doCheck r = authHandler r >>= roleChecker

        roleCheck :: Request -> DelayedIO (Proxy aRole)
        roleCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . doCheck

instance ( HasClient api) => HasClient (UserInRole aRole tag :> api) where
  type Client (UserInRole aRole tag :> api)
    = AuthenticateReq (AuthProtect tag) -> Client api

  clientWithRoute Proxy req (AuthenticateReq (val,func)) =
    clientWithRoute (Proxy :: Proxy api) (func val req)


-- * Basic Roles

data AdminRole deriving Typeable
data UserRole deriving Typeable

-- | Extract role of some user type
class HasRoles a r where
  getRole :: a -> Maybe (Proxy r)

Support.hs

{-# LANGUAGE DataKinds, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}
module Gorilla.Auth.Support(module  Servant.Server.Experimental.Auth.Cookie
                           ,Authenticated, serveAuthenticated, serveIdentified
                           ,defaultCookieSettings, unsecureCookieSettings
                           ,ForAdmin, Authent, MaybeAuthent
                           ,module Gorilla.Auth.Roles) where

import           Control.Monad.Catch                     (catch)
import           Control.Monad.Trans
import           Data.ByteString
import           Data.Default
import           Data.Monoid
import           Data.Serialize
import           Gorilla.Auth.Roles
import           Network.Wai                             (Application, Request)
import           Servant                                 hiding ((:>))
import           Servant.Server.Experimental.Auth        (AuthHandler, AuthServerData, mkAuthHandler)
import           Servant.Server.Experimental.Auth.Cookie

type ForAdmin = UserInRole AdminRole "cookie-auth"
type Authent  = AuthProtect "cookie-auth"
type MaybeAuthent  = AuthProtect "maybe-cookie-auth"


defaultCookieSettings :: AuthCookieSettings
defaultCookieSettings = def

unsecureCookieSettings :: AuthCookieSettings
unsecureCookieSettings = def { acsCookieFlags  = ["HttpOnly"] }

type Authenticated a = Headers '[Header "set-cookie" ByteString] a

-- | Maps a possibly existing cookie content to user-defined datatype
type instance AuthServerData (AuthProtect "maybe-cookie-auth") = Maybe AuthCookieData

serveIdentified :: (Serialize AuthCookieData
                   ,HasServer layout '[AuthHandler Request (Maybe AuthCookieData)]) =>
                      AuthCookieSettings
                   -> ServerKey
                   -> Server layout
                   -> Proxy layout
                   -> Application
serveIdentified  settings serverKey app api =
  serveWithContext api
  ((injectUserAccount settings serverKey :: AuthHandler Request (Maybe AuthCookieData)) :. EmptyContext)
  app

-- | Cookie authentication handler.
injectUserAccount :: (Serialize AuthCookieData)
                     => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'
                  -> ServerKey             -- ^ 'ServerKey' to use
                  -> AuthHandler Request (Maybe AuthCookieData) -- ^
injectUserAccount acs sk = mkAuthHandler $ \request ->
                                             liftIO (getSession acs sk request
                                                     `catch` \ (e :: AuthCookieException) -> do
                                                        Prelude.putStrLn $ "Error while trying to extract session from cookie: " <> show e
                                                        return Nothing)


serveAuthenticated :: ( Serialize AuthCookieData
                      , HasServer layout '[ RoleChecker AdminRole AuthCookieData
                                          , AuthHandler Request AuthCookieData
                                          , AuthHandler Request (Maybe AuthCookieData)]
                      , HasRoles AuthCookieData AdminRole
                      ) =>
                      AuthCookieSettings
                   -> ServerKey
                   -> Server layout
                   -> Proxy layout
                   -> Application
serveAuthenticated settings serverKey app api = serveWithContext api
    ((hasAdminRole                              :: RoleChecker AdminRole AuthCookieData) :.
     (redirectAuthentication settings serverKey :: AuthHandler Request AuthCookieData) :.
     (injectUserAccount settings serverKey :: AuthHandler Request (Maybe AuthCookieData)) :. EmptyContext)
    app
  where
    hasAdminRole :: RoleChecker AdminRole AuthCookieData
    hasAdminRole = RoleChecker $
      \ usr -> case getRole usr of
                 Nothing -> throwError err403
                 Just p  -> return p

    -- | Cookie authentication handler.
    redirectAuthentication :: Serialize a
                              => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'
                           -> ServerKey             -- ^ 'ServerKey' to use
                           -> AuthHandler Request a -- ^
    redirectAuthentication acs sk = mkAuthHandler $ \request -> do
      msession <- liftIO (getSession acs sk request
                           `catch` \ (e :: AuthCookieException) -> do
                             Prelude.putStrLn $ "Error while trying to extract session from cookie: " <> show e
                             return Nothing)
      maybe redirectToAuthent return msession
        where
          redirectToAuthent = throwError $ err401 { errHeaders = [ ("location", "/index.html/#/authent") ] }

User.hs

{-# LANGUAGE DeriveGeneric, MultiParamTypeClasses, NamedFieldPuns, OverloadedLists, OverloadedStrings, RecordWildCards #-}
module Gorilla.Auth.User where

import           Data.Aeson
import           Data.ByteString    (ByteString)
import           Data.Monoid        ((<>))
import           Data.Proxy
import           Data.Serialize     (Serialize, get, put)
import           Data.String
import           Data.Text
import           Data.Text.Encoding
import           Data.Text.ToText
import           GHC.Generics
import           Gorilla.Auth.Roles (AdminRole, HasRoles (..))
import           Gorilla.Secret
import           Gorilla.Types
import           Gorilla.UUID
import           Servant            hiding (QueryParams)
import           Web.FormUrlEncoded

-- | Human-friendly identification of a user.
newtype UserName = UserName { name :: Text }
  deriving (Eq, Show, Read, Generic)

instance IsString UserName where
  fromString = UserName . pack

instance ToText UserName where
  toText = name

instance ToJSON UserName
instance FromJSON UserName

instance Serialize UserName where
  put (UserName t) = put (encodeUtf8 t)
  get              = UserName . decodeUtf8 <$> get

instance Identifiable UserName

-- | User-related information
data UserAccount = UserAccount { user_id            :: UUID
                               , user_name          :: UserName
                               , user_email_address :: MailAddress
                               , user_password      :: Maybe Encrypted
                               }
     deriving  (Eq, Show, Read, Generic)

instance ToJSON UserAccount
instance FromJSON UserAccount
instance Serialize UserAccount
instance Identifiable UserAccount where
  identify UserAccount{..} = identify user_name <> identify user_email_address

instance HasRoles UserAccount AdminRole where
  getRole UserAccount { user_email_address } =
    if  "@gorillaspace.co" `isSuffixOf` mailAddress user_email_address
    then Just Proxy
    else Nothing

isAdmin :: UserAccount -> Bool
isAdmin u
  | Just (Proxy :: Proxy AdminRole) <- getRole u = True
  | otherwise                                    = False
  
-- * Login

-- | Standard Login form
data LoginForm = LoginForm { lfUsername :: Text
                           , lfPassword :: ClearText
                           }
               deriving (Eq, Show, Generic)


instance ToJSON LoginForm
instance FromJSON LoginForm

instance FromForm LoginForm where
  fromForm d = do
    username <- parseUnique "username" d
    password <- parseUnique "password" d
    return LoginForm  { lfUsername = username
                      , lfPassword = ClearText password }

instance ToForm LoginForm where
  toForm LoginForm{..} = [("username", toQueryParam lfUsername), ("password", toQueryParam $ clearText lfPassword)]


instance ToHttpApiData ByteString where
  toQueryParam = decodeUtf8
  toHeader = id

instance FromHttpApiData ByteString where
  parseQueryParam = Right . encodeUtf8