Auth.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}


module Lib.Auth where


import Data.Typeable (Typeable)
import Data.Text ()
import Data.Text.Encoding (decodeUtf8)
import Data.Maybe (fromMaybe)
import Data.Aeson (encode)
import Network.Wai
import Network.HTTP.Types (hContentType)
import Servant
import Servant.Server.Internal.Router
import Servant.API.ContentTypes
import Servant.Server.Internal.RoutingApplication
import Data.String.Conversions (cs)
import Web.JWT (JWTClaimsSet(..))
import Control.Monad.Trans.Maybe
import Control.Monad.Reader
import Web.Cookie
import Data.Map.Lazy (toList)


import Lib.ErrorResponse
import Lib.Config
import Lib.Utils
import Lib.JWT


data Auth (contentTypes :: [*]) a
  deriving (Typeable)


instance (AllCTUnrender list a, HasServer sublayout, MonadReader AppConfig IO)
      => HasServer (Auth list a :> sublayout) where

  type ServerT (Auth list a :> sublayout) m =
    a -> ServerT sublayout m

  route Proxy subserver = WithRequest $ \ request ->
    route (Proxy :: Proxy sublayout) (addBodyCheck subserver (jwtCheck request))
    where
      jwtCheck :: Request -> IO (RouteResult a)
      jwtCheck request = do
        AppConfig _ as <- ask
        let mheader = lookup "cookie" (requestHeaders request)
            mc = lookup apiCookie =<< fmap parseCookies mheader
            contentTypeH = fromMaybe "application/json" $ lookup hContentType $ requestHeaders request

        fromMaybeT (return $ FailFatal $ serverErr' Forbidden) $ do
          jwt <- MaybeT $ return mc
          clms <- MaybeT $ verifyClaims $ decodeUtf8 jwt
          val <- MaybeT $ return $ lookup "user" $ toList $ unregisteredClaims clms
          user <- MaybeT $ return $ handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) (encode val)
          case user of
            Left e -> return $ FailFatal $ serverErr' Forbidden
            Right v -> return $ Route v