Auth.hs

fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
fromMaybeT x y = fmap fromJust . runMaybeT $ y <|> lift x


instance (AllCTUnrender list a, HasServer sublayout)
      => 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
        let mheader = lookup "cookie" (requestHeaders request)
            mc = lookup "vendorToolApi" =<< fmap parseCookies mheader
            contentTypeH = fromMaybe "application/json" $ lookup hContentType $ requestHeaders request

        fromMaybeT (FailFatal $ serverErr' Forbidden) $ do
          jwt <- MaybeT $ return mc
          clms <- MaybeT $ liftIO $ 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
        -- case mc of
        --   Nothing -> return $ FailFatal $ serverErr' Forbidden
        --   Just jwt -> do
        --     mcs <- verifyClaims $ decodeUtf8 jwt
        --     case mcs of
        --       Nothing -> return $ FailFatal $ serverErr' Forbidden
        --       Just clms -> do
        --         let user = lookup "user" $ toList $ unregisteredClaims clms :: Maybe Value
        --         case user of
        --           Nothing -> return $ FailFatal $ serverErr' Forbidden
        --           Just user' -> do
        --             let usr = handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) (encode user')
        --             case usr of
        --               Nothing -> return $ FailFatal $ serverErr' Forbidden
        --               Just (Left e) -> return $ FailFatal err403
        --               Just (Right v) -> return $ Route v