From 850e5cc2d4ef96a2dd2a43c9b8d4c1355eb7a148 Mon Sep 17 00:00:00 2001
From: Igor Pashev <pashev.igor@gmail.com>
Date: Sat, 13 May 2017 23:09:56 +0300
Subject: Add end-point for checking access in a bunch

---
 src/Sproxy/Application.hs | 37 +++++++++++++++++++++++++++++++++++--
 1 file changed, 35 insertions(+), 2 deletions(-)

(limited to 'src/Sproxy/Application.hs')

diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs
index 7376657..5de9474 100644
--- a/src/Sproxy/Application.hs
+++ b/src/Sproxy/Application.hs
@@ -27,7 +27,7 @@ import Data.Word8 (_colon)
 import Foreign.C.Types (CTime(..))
 import Network.HTTP.Client.Conduit (bodyReaderSource)
 import Network.HTTP.Conduit (requestBodySourceChunkedIO, requestBodySourceIO)
-import Network.HTTP.Types (RequestHeaders, ResponseHeaders, methodGet)
+import Network.HTTP.Types (RequestHeaders, ResponseHeaders, methodGet, methodPost)
 import Network.HTTP.Types.Header ( hConnection,
   hContentLength, hContentType, hCookie, hLocation, hTransferEncoding )
 import Network.HTTP.Types.Status ( Status(..), badRequest400, forbidden403, found302,
@@ -39,6 +39,7 @@ import System.FilePath.Glob (Pattern, match)
 import System.Posix.Time (epochTime)
 import Text.InterpolatedString.Perl6 (qc)
 import Web.Cookie (Cookies, parseCookies, renderCookies)
+import qualified Data.Aeson as JSON
 import qualified Network.HTTP.Client as BE
 import qualified Network.Wai as W
 import qualified Web.Cookie as WC
@@ -48,7 +49,7 @@ import Sproxy.Application.Cookie ( AuthCookie(..), AuthUser,
   getGivenNameUtf8 )
 import Sproxy.Application.OAuth2.Common (OAuth2Client(..))
 import Sproxy.Config(BackendConf(..))
-import Sproxy.Server.DB (Database, userExists, userGroups)
+import Sproxy.Server.DB (Database, userAccess, userExists, userGroups)
 import qualified Sproxy.Application.State as State
 import qualified Sproxy.Logging as Log
 
@@ -81,12 +82,22 @@ sproxy key db oa2 backends = logException $ \req resp -> do
             ["robots.txt"] -> get robots req resp
             (".sproxy":proxy) ->
               case proxy of
+
                 ["logout"] -> get (logout key cookieName cookieDomain) req resp
+
                 ["oauth2", provider] ->
                     case HM.lookup provider oa2 of
                       Nothing -> notFound "OAuth2 provider" req resp
                       Just oa2c -> get (oauth2callback key db (provider, oa2c) be) req resp
+
+                ["access"] -> do
+                  now <- Just <$> epochTime
+                  case extractCookie key now cookieName req of
+                    Nothing -> authenticationRequired key oa2 req resp
+                    Just (authCookie, _) -> post (checkAccess db authCookie) req resp
+
                 _ -> notFound "proxy" req resp
+
             _ -> do
               now <- Just <$> epochTime
               case extractCookie key now cookieName req of
@@ -195,6 +206,20 @@ authorize db (authCookie, otherCookies) req = do
     setCookies cs = insert hCookie (toByteString . renderCookies $ cs)
 
 
+checkAccess :: Database -> AuthCookie -> W.Application
+checkAccess db authCookie req resp = do
+  let email = getEmail . acUser $ authCookie
+      domain = decodeUtf8 . fromJust $ requestDomain req
+  body <- W.strictRequestBody req
+  case JSON.eitherDecode' body of
+    Left err -> badRequest err req resp
+    Right inq -> do
+      Log.debug $ "access <<< " ++ show inq
+      tags <- userAccess db email domain inq
+      Log.debug $ "access >>> " ++ show tags
+      resp $ W.responseLBS ok200 [(hContentType, "application/json")] (JSON.encode tags)
+
+
 -- XXX If something seems strange, think about HTTP/1.1 <-> HTTP/1.0.
 -- FIXME For HTTP/1.0 backends we might need an option
 -- FIXME in config file. HTTP Client does HTTP/1.1 by default.
@@ -380,6 +405,14 @@ get app req resp
     resp $ W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed"
 
 
+post :: W.Middleware
+post app req resp
+  | W.requestMethod req == methodPost = app req resp
+  | otherwise = do
+    Log.warn $ "405 Method Not Allowed: " ++ showReq req
+    resp $ W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed"
+
+
 redirectURL :: W.Request -> Text -> ByteString
 redirectURL req provider =
   "https://" <> fromJust (W.requestHeaderHost req)
-- 
cgit v1.2.3