sproxy2 1.95.0 → 1.96.0
raw patch · 19 files changed
+959/−779 lines, 19 files
Files
- ChangeLog.md +14/−0
- LICENSE +1/−0
- sproxy.example.yml +7/−2
- sproxy2.cabal +5/−2
- src/Main.hs +14/−11
- src/Sproxy/Application.hs +276/−210
- src/Sproxy/Application/Access.hs +8/−10
- src/Sproxy/Application/Cookie.hs +36/−36
- src/Sproxy/Application/OAuth2.hs +11/−8
- src/Sproxy/Application/OAuth2/Common.hs +21/−24
- src/Sproxy/Application/OAuth2/Google.hs +64/−58
- src/Sproxy/Application/OAuth2/LinkedIn.hs +67/−60
- src/Sproxy/Application/OAuth2/Yandex.hs +83/−0
- src/Sproxy/Application/State.hs +10/−15
- src/Sproxy/Config.hs +67/−72
- src/Sproxy/Logging.hs +38/−31
- src/Sproxy/Server.hs +84/−97
- src/Sproxy/Server/DB.hs +117/−96
- src/Sproxy/Server/DB/DataFile.hs +36/−47
ChangeLog.md view
@@ -1,5 +1,18 @@ For differences with the original Sproxy scroll down. +1.96.0+======++ * Added support for Yandex (https://tech.yandex.com/oauth/).++ * Encode full URL (including protocol) into the state parameter,+ not just path. This makes it possible to work with OAuth2 providers+ that do not support multiple callback URL, like Yandex.++ * Fixed POST requests for tokens with Google and LinkedIn. They+ were mistakenly using URL paramaters instead of URL-encoded bodies.++ 1.95.0 ====== @@ -7,6 +20,7 @@ * Respond with 502 (Bad Gateway) on any backend error. Previously it was 500 (Internal Server Error).+ 1.94.1 ======
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2016, Zalora South East Asia Pte. Ltd+Copyright (c) 2017, Igor Pashev <pashev.igor@gmail.com> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
sproxy.example.yml view
@@ -99,7 +99,7 @@ # and existing data in the internal database. # Useful for development or some simple deployments. # Cannot be used with the `database` option.-# For example see the datafile.yml.example+# For example see the datafile.example.yml # # datafile: /path/data.yml @@ -121,7 +121,8 @@ # client_id - OAuth2 client ID. # client_secret - OAuth2 client secret. #-# Example:+# Examples:+# # oauth2: # google: # client_id: "XXXXXXXXXXXX-YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY.apps.googleusercontent.com"@@ -130,6 +131,10 @@ # linkedin: # client_id: "xxxxxxxxxxxxxx" # client_secret: !include "/run/keys/xxxxxxxxxxxxxx"+#+# yandex:+# client_id: xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx+# client_secret: yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy # # # oauth2:
sproxy2.cabal view
@@ -1,5 +1,5 @@ name: sproxy2-version: 1.95.0+version: 1.96.0 synopsis: Secure HTTP proxy for authenticating users via OAuth2 description: Sproxy is secure by default. No requests makes it to the backend@@ -10,7 +10,9 @@ license-file: LICENSE author: Igor Pashev <pashev.igor@gmail.com> maintainer: Igor Pashev <pashev.igor@gmail.com>-copyright: 2016, Zalora South East Asia Pte. Ltd+copyright:+ 2016-2017, Zalora South East Asia Pte. Ltd;+ 2017, Igor Pashev <pashev.igor@gmail.com> category: Databases, Web build-type: Simple cabal-version: >= 1.20@@ -38,6 +40,7 @@ Sproxy.Application.OAuth2.Common Sproxy.Application.OAuth2.Google Sproxy.Application.OAuth2.LinkedIn+ Sproxy.Application.OAuth2.Yandex Sproxy.Application.State Sproxy.Config Sproxy.Logging
src/Main.hs view
@@ -1,20 +1,24 @@ {-# LANGUAGE QuasiQuotes #-}-module Main (- main-) where +module Main+ ( main+ ) where+ import Data.Maybe (fromJust) import Data.Version (showVersion) import Paths_sproxy2 (version) -- from cabal+import qualified System.Console.Docopt.NoTH as O import System.Environment (getArgs) import Text.InterpolatedString.Perl6 (qc)-import qualified System.Console.Docopt.NoTH as O import Sproxy.Server (server) usage :: String-usage = "sproxy2 " ++ showVersion version ++- " - HTTP proxy for authenticating users via OAuth2" ++ [qc|+usage =+ "sproxy2 " +++ showVersion version +++ " - HTTP proxy for authenticating users via OAuth2" +++ [qc| Usage: sproxy2 [options]@@ -30,8 +34,7 @@ doco <- O.parseUsageOrExit usage args <- O.parseArgsOrExit doco =<< getArgs if args `O.isPresent` O.longOption "help"- then putStrLn $ O.usage doco- else do- let configFile = fromJust . O.getArg args $ O.longOption "config"- server configFile-+ then putStrLn $ O.usage doco+ else do+ let configFile = fromJust . O.getArg args $ O.longOption "config"+ server configFile
src/Sproxy/Application.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-module Sproxy.Application (- sproxy-, redirect-) where +module Sproxy.Application+ ( sproxy+ , redirect+ ) where+ import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder.ByteString (fromByteString)-import Control.Exception (Exception, Handler(..), SomeException, catches, displayException)+import Control.Exception+ (Exception, Handler(..), SomeException, catches, displayException)+import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString as BS (break, intercalate) import Data.ByteString.Char8 (pack, unpack)@@ -16,7 +19,8 @@ import Data.Conduit (Flush(Chunk), mapOutput) import Data.HashMap.Strict as HM (HashMap, foldrWithKey, lookup) import Data.List (find, partition)-import Data.Map as Map (delete, fromListWith, insert, insertWith, toList)+import Data.Map as Map+ (delete, fromListWith, insert, insertWith, toList) import Data.Maybe (fromJust, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text)@@ -25,34 +29,38 @@ import Data.Word (Word16) import Data.Word8 (_colon) import Foreign.C.Types (CTime(..))+import qualified Network.HTTP.Client as BE import Network.HTTP.Client.Conduit (bodyReaderSource)-import Network.HTTP.Conduit (requestBodySourceChunkedIO, requestBodySourceIO)-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(..), badGateway502, badRequest400, forbidden403,- found302, internalServerError500, methodNotAllowed405, movedPermanently301,- networkAuthenticationRequired511, notFound404, ok200, seeOther303, temporaryRedirect307 )+import Network.HTTP.Conduit+ (requestBodySourceChunkedIO, requestBodySourceIO)+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(..), badGateway502, badRequest400, forbidden403, found302,+ internalServerError500, methodNotAllowed405, movedPermanently301,+ networkAuthenticationRequired511, notFound404, ok200, seeOther303,+ temporaryRedirect307) import Network.Socket (NameInfoFlag(NI_NUMERICHOST), getNameInfo)-import Network.Wai.Conduit (sourceRequestBody, responseSource)+import qualified Network.Wai as W+import Network.Wai.Conduit (responseSource, sourceRequestBody) 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 -import Sproxy.Application.Cookie ( AuthCookie(..), AuthUser,- cookieDecode, cookieEncode, getEmail, getEmailUtf8, getFamilyNameUtf8,- getGivenNameUtf8 )+import Sproxy.Application.Cookie+ (AuthCookie(..), AuthUser, cookieDecode, cookieEncode, getEmail,+ getEmailUtf8, getFamilyNameUtf8, getGivenNameUtf8) import Sproxy.Application.OAuth2.Common (OAuth2Client(..))-import Sproxy.Config(BackendConf(..))-import Sproxy.Server.DB (Database, userAccess, userExists, userGroups) import qualified Sproxy.Application.State as State+import Sproxy.Config (BackendConf(..)) import qualified Sproxy.Logging as Log-+import Sproxy.Server.DB+ (Database, userAccess, userExists, userGroups) redirect :: Word16 -> W.Application redirect p req resp =@@ -61,151 +69,182 @@ Just domain -> do Log.info $ "redirecting to " ++ show location ++ ": " ++ showReq req resp $ W.responseBuilder status [(hLocation, location)] mempty- where- status = if W.requestMethod req == methodGet then movedPermanently301 else temporaryRedirect307- newhost = if p == 443 then domain else domain <> ":" <> pack (show p)- location = "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req---sproxy :: ByteString -> Database -> HashMap Text OAuth2Client -> [(Pattern, BackendConf, BE.Manager)] -> W.Application-sproxy key db oa2 backends = logException $ \req resp -> do- Log.debug $ "sproxy <<< " ++ showReq req- case requestDomain req of- Nothing -> badRequest "missing host" req resp- Just domain ->- case find (\(p, _, _) -> match p (unpack domain)) backends of- Nothing -> notFound "backend" req resp- Just (_, be, mgr) -> do- let cookieName = pack $ beCookieName be- cookieDomain = pack <$> beCookieDomain be- case W.pathInfo req of- ["robots.txt"] -> get robots req resp- (".sproxy":proxy) ->- case proxy of-- ["logout"] -> get (logout key cookieName cookieDomain) req resp+ where status =+ if W.requestMethod req == methodGet+ then movedPermanently301+ else temporaryRedirect307+ newhost =+ if p == 443+ then domain+ else domain <> ":" <> pack (show p)+ location =+ "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req - ["oauth2", provider] ->+sproxy ::+ ByteString+ -> Database+ -> HashMap Text OAuth2Client+ -> [(Pattern, BackendConf, BE.Manager)]+ -> W.Application+sproxy key db oa2 backends =+ logException $ \req resp -> do+ Log.debug $ "sproxy <<< " ++ showReq req+ case requestDomain req of+ Nothing -> badRequest "missing host" req resp+ Just domain ->+ case find (\(p, _, _) -> match p (unpack domain)) backends of+ Nothing -> notFound "backend" req resp+ Just (_, be, mgr) -> do+ let cookieName = pack $ beCookieName be+ cookieDomain = pack <$> beCookieDomain be+ case W.pathInfo req of+ ["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- Nothing -> authenticationRequired key oa2 req resp- Just cs@(authCookie, _) ->- authorize db cs req >>= \case- Nothing -> forbidden authCookie req resp- Just req' -> forward mgr 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+ Nothing -> authenticationRequired key oa2 req resp+ Just cs@(authCookie, _) ->+ authorize db cs req >>= \case+ Nothing -> forbidden authCookie req resp+ Just req' -> forward mgr req' resp robots :: W.Application-robots _ resp = resp $- W.responseLBS ok200 [(hContentType, "text/plain; charset=utf-8")]- "User-agent: *\nDisallow: /"-+robots _ resp =+ resp $+ W.responseLBS+ ok200+ [(hContentType, "text/plain; charset=utf-8")]+ "User-agent: *\nDisallow: /" -oauth2callback :: ByteString -> Database -> (Text, OAuth2Client) -> BackendConf -> W.Application+oauth2callback ::+ ByteString+ -> Database+ -> (Text, OAuth2Client)+ -> BackendConf+ -> W.Application oauth2callback key db (provider, oa2c) be req resp = case param "code" of- Nothing -> badRequest "missing auth code" req resp- Just code -> + Nothing -> badRequest "missing auth code" req resp+ Just code -> case param "state" of- Nothing -> badRequest "missing auth state" req resp+ Nothing -> badRequest "missing auth state" req resp Just state -> case State.decode key state of- Left msg -> badRequest ("invalid state: " ++ msg) req resp- Right path -> do+ Left msg -> badRequest ("invalid state: " ++ msg) req resp+ Right url -> do au <- oauth2Authenticate oa2c code (redirectURL req provider) let email = getEmail au Log.info $ "login " ++ show email ++ " by " ++ show provider exists <- userExists db email- if exists then authenticate key be au path req resp- else userNotFound au req resp+ if exists+ then authenticate key be au url req resp+ else userNotFound au req resp where param p = do (_, v) <- find ((==) p . fst) $ W.queryString req v - -- XXX: RFC6265: the user agent MUST NOT attach more than one Cookie header field-extractCookie :: ByteString -> Maybe CTime -> ByteString -> W.Request -> Maybe (AuthCookie, Cookies)+extractCookie ::+ ByteString+ -> Maybe CTime+ -> ByteString+ -> W.Request+ -> Maybe (AuthCookie, Cookies) extractCookie key now name req = do- (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req+ (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req (auth, others) <- discriminate cookies case cookieDecode key auth of Left _ -> Nothing- Right cookie -> if maybe True (acExpiry cookie >) now- then Just (cookie, others) else Nothing- where discriminate cs =- case partition ((==) name . fst) $ parseCookies cs of- ((_, x):_, xs) -> Just (x, xs)- _ -> Nothing-+ Right cookie ->+ if maybe True (acExpiry cookie >) now+ then Just (cookie, others)+ else Nothing+ where+ discriminate cs =+ case partition ((==) name . fst) $ parseCookies cs of+ ((_, x):_, xs) -> Just (x, xs)+ _ -> Nothing -authenticate :: ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application-authenticate key be user path req resp = do+authenticate ::+ ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application+authenticate key be user url _req resp = do now <- epochTime let domain = pack <$> beCookieDomain be expiry = now + CTime (beCookieMaxAge be)- authCookie = AuthCookie { acUser = user, acExpiry = expiry }- cookie = WC.def {- WC.setCookieName = pack $ beCookieName be- , WC.setCookieHttpOnly = True- , WC.setCookiePath = Just "/"- , WC.setCookieSameSite = Nothing- , WC.setCookieSecure = True- , WC.setCookieValue = cookieEncode key authCookie- , WC.setCookieDomain = domain- , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ expiry- }- resp $ W.responseLBS seeOther303 [- (hLocation, "https://" <> fromJust (W.requestHeaderHost req) <> path)- , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)- ] ""-+ authCookie = AuthCookie {acUser = user, acExpiry = expiry}+ cookie =+ WC.def+ { WC.setCookieName = pack $ beCookieName be+ , WC.setCookieHttpOnly = True+ , WC.setCookiePath = Just "/"+ , WC.setCookieSameSite = Nothing+ , WC.setCookieSecure = True+ , WC.setCookieValue = cookieEncode key authCookie+ , WC.setCookieDomain = domain+ , WC.setCookieExpires =+ Just . posixSecondsToUTCTime . realToFrac $ expiry+ }+ resp $+ W.responseLBS+ seeOther303+ [ (hLocation, url)+ , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)+ ]+ "" -authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request)+authorize ::+ Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request) authorize db (authCookie, otherCookies) req = do- let- user = acUser authCookie- domain = decodeUtf8 . fromJust $ requestDomain req- email = getEmail user- emailUtf8 = getEmailUtf8 user- familyUtf8 = getFamilyNameUtf8 user- givenUtf8 = getGivenNameUtf8 user- method = decodeUtf8 $ W.requestMethod req- path = decodeUtf8 $ W.rawPathInfo req+ let user = acUser authCookie+ domain = decodeUtf8 . fromJust $ requestDomain req+ email = getEmail user+ emailUtf8 = getEmailUtf8 user+ familyUtf8 = getFamilyNameUtf8 user+ givenUtf8 = getGivenNameUtf8 user+ method = decodeUtf8 $ W.requestMethod req+ path = decodeUtf8 $ W.rawPathInfo req grps <- userGroups db email domain path method- if null grps then return Nothing- else do- ip <- pack . fromJust . fst <$> getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req)- return . Just $ req {- W.requestHeaders = toList $- insert "From" emailUtf8 $- insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $- insert "X-Given-Name" givenUtf8 $- insert "X-Family-Name" familyUtf8 $- insert "X-Forwarded-Proto" "https" $- insertWith (flip combine) "X-Forwarded-For" ip $- setCookies otherCookies $- fromListWith combine $ W.requestHeaders req- }+ if null grps+ then return Nothing+ else do+ ip <-+ pack . fromJust . fst <$>+ getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req)+ return . Just $+ req+ { W.requestHeaders =+ toList $+ insert "From" emailUtf8 $+ insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $+ insert "X-Given-Name" givenUtf8 $+ insert "X-Family-Name" familyUtf8 $+ insert "X-Forwarded-Proto" "https" $+ insertWith (flip combine) "X-Forwarded-For" ip $+ setCookies otherCookies $+ fromListWith combine $ W.requestHeaders req+ } where combine a b = a <> "," <> b setCookies [] = delete hCookie setCookies cs = insert hCookie (toByteString . renderCookies $ cs) - checkAccess :: Database -> AuthCookie -> W.Application checkAccess db authCookie req resp = do let email = getEmail . acUser $ authCookie@@ -217,77 +256,96 @@ 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)-+ 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. forward :: BE.Manager -> W.Application forward mgr req resp = do- let beReq = BE.defaultRequest+ let beReq =+ BE.defaultRequest { BE.method = W.requestMethod req , BE.path = W.rawPathInfo req , BE.queryString = W.rawQueryString req , BE.requestHeaders = modifyRequestHeaders $ W.requestHeaders req , BE.redirectCount = 0 , BE.decompress = const False- , BE.requestBody = case W.requestBodyLength req of- W.ChunkedBody -> requestBodySourceChunkedIO (sourceRequestBody req)- W.KnownLength l -> requestBodySourceIO (fromIntegral l) (sourceRequestBody req)+ , BE.requestBody =+ case W.requestBodyLength req of+ W.ChunkedBody ->+ requestBodySourceChunkedIO (sourceRequestBody req)+ W.KnownLength l ->+ requestBodySourceIO (fromIntegral l) (sourceRequestBody req) }- msg = unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq)+ msg =+ unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq) Log.debug $ "BACKEND <<< " ++ msg ++ " " ++ show (BE.requestHeaders beReq) BE.withResponse beReq mgr $ \res -> do- let status = BE.responseStatus res- headers = BE.responseHeaders res- body = mapOutput (Chunk . fromByteString) . bodyReaderSource $ BE.responseBody res- logging = if statusCode status `elem` [ 400, 500 ] then- Log.warn else Log.debug- logging $ "BACKEND >>> " ++ show (statusCode status) ++ " on " ++ msg ++ " " ++ show headers ++ "\n"- resp $ responseSource status (modifyResponseHeaders headers) body-+ let status = BE.responseStatus res+ headers = BE.responseHeaders res+ body =+ mapOutput (Chunk . fromByteString) . bodyReaderSource $+ BE.responseBody res+ logging =+ if statusCode status `elem` [400, 500]+ then Log.warn+ else Log.debug+ logging $+ "BACKEND >>> " +++ show (statusCode status) ++ " on " ++ msg ++ " " ++ show headers ++ "\n"+ resp $ responseSource status (modifyResponseHeaders headers) body modifyRequestHeaders :: RequestHeaders -> RequestHeaders modifyRequestHeaders = filter (\(n, _) -> n `notElem` ban) where ban =- [- hConnection- , hContentLength -- XXX This is set automtically before sending request to backend+ [ hConnection+ , hContentLength -- XXX This is set automtically before sending request to backend , hTransferEncoding -- XXX Likewise ] - modifyResponseHeaders :: ResponseHeaders -> ResponseHeaders modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban) where ban =- [- hConnection+ [ hConnection -- XXX WAI docs say we MUST NOT add (keep) Content-Length, Content-Range, and Transfer-Encoding, -- XXX but we use streaming body, which may add Transfer-Encoding only. -- XXX Thus we keep Content-* headers. , hTransferEncoding ] --authenticationRequired :: ByteString -> HashMap Text OAuth2Client -> W.Application+authenticationRequired ::+ ByteString -> HashMap Text OAuth2Client -> W.Application authenticationRequired key oa2 req resp = do Log.info $ "511 Unauthenticated: " ++ showReq req- resp $ W.responseLBS networkAuthenticationRequired511 [(hContentType, "text/html; charset=utf-8")] page+ resp $+ W.responseLBS+ networkAuthenticationRequired511+ [(hContentType, "text/html; charset=utf-8")]+ page where- path = if W.requestMethod req == methodGet- then W.rawPathInfo req <> W.rawQueryString req- else "/"- state = State.encode key path+ path =+ if W.requestMethod req == methodGet+ then W.rawPathInfo req <> W.rawQueryString req+ else "/"+ state =+ State.encode key $+ "https://" <> fromJust (W.requestHeaderHost req) <> path authLink :: Text -> OAuth2Client -> ByteString -> ByteString- authLink provider oa2c html = + authLink provider oa2c html = let u = oauth2AuthorizeURL oa2c state (redirectURL req provider) d = pack $ oauth2Description oa2c in [qc|{html}<p><a href="{u}">Authenticate with {d}</a></p>|] authHtml = foldrWithKey authLink "" oa2- page = fromStrict [qc|+ page =+ fromStrict+ [qc| <!DOCTYPE html> <html lang="en"> <head>@@ -301,14 +359,16 @@ </html> |] - forbidden :: AuthCookie -> W.Application forbidden ac req resp = do Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req- resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page+ resp $+ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page where email = getEmailUtf8 . acUser $ ac- page = fromStrict [qc|+ page =+ fromStrict+ [qc| <!DOCTYPE html> <html lang="en"> <head>@@ -323,14 +383,16 @@ </html> |] - userNotFound :: AuthUser -> W.Application userNotFound au _ resp = do Log.info $ "404 User not found: " ++ show email- resp $ W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page+ resp $+ W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page where email = getEmailUtf8 au- page = fromStrict [qc|+ page =+ fromStrict+ [qc| <!DOCTYPE html> <html lang="en"> <head>@@ -345,98 +407,102 @@ </html> |] - logout :: ByteString -> ByteString -> Maybe ByteString -> W.Application logout key cookieName cookieDomain req resp = do let host = fromJust $ W.requestHeaderHost req case extractCookie key Nothing cookieName req of- Nothing -> resp $ W.responseLBS found302 [ (hLocation, "https://" <> host) ] ""- Just _ -> do- let cookie = WC.def {- WC.setCookieName = cookieName+ Nothing ->+ resp $ W.responseLBS found302 [(hLocation, "https://" <> host)] ""+ Just _ -> do+ let cookie =+ WC.def+ { WC.setCookieName = cookieName , WC.setCookieHttpOnly = True , WC.setCookiePath = Just "/" , WC.setCookieSameSite = Just WC.sameSiteStrict , WC.setCookieSecure = True , WC.setCookieValue = "goodbye" , WC.setCookieDomain = cookieDomain- , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ CTime 0+ , WC.setCookieExpires =+ Just . posixSecondsToUTCTime . realToFrac $ CTime 0 }- resp $ W.responseLBS found302 [- (hLocation, "https://" <> host)- , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)- ] ""-+ resp $+ W.responseLBS+ found302+ [ (hLocation, "https://" <> host)+ , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)+ ]+ "" -badRequest ::String -> W.Application+badRequest :: String -> W.Application badRequest msg req resp = do Log.warn $ "400 Bad Request (" ++ msg ++ "): " ++ showReq req resp $ W.responseLBS badRequest400 [] "Bad Request" --notFound ::String -> W.Application+notFound :: String -> W.Application notFound msg req resp = do Log.warn $ "404 Not Found (" ++ msg ++ "): " ++ showReq req resp $ W.responseLBS notFound404 [] "Not Found" - logException :: W.Middleware logException app req resp =- catches (app req resp) [- Handler badGateway,- Handler internalError- ]+ catches (app req resp) [Handler badGateway, Handler internalError] where internalError :: SomeException -> IO W.ResponseReceived internalError = response internalServerError500- badGateway :: BE.HttpException -> IO W.ResponseReceived badGateway = response badGateway502- response :: Exception e => Status -> e -> IO W.ResponseReceived response st e = do- Log.error $ show (statusCode st) ++ " " ++ unpack (statusMessage st)- ++ ": " ++ displayException e ++ " on " ++ showReq req- resp $ W.responseLBS st [(hContentType, "text/plain")] (fromStrict $ statusMessage st)--+ Log.error $+ show (statusCode st) +++ " " +++ unpack (statusMessage st) +++ ": " ++ displayException e ++ " on " ++ showReq req+ resp $+ W.responseLBS+ st+ [(hContentType, "text/plain")]+ (fromStrict $ statusMessage st) get :: W.Middleware get app req resp | W.requestMethod req == methodGet = app req resp | otherwise = do Log.warn $ "405 Method Not Allowed: " ++ showReq req- resp $ W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed"-+ 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"-+ resp $+ W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed" redirectURL :: W.Request -> Text -> ByteString redirectURL req provider =- "https://" <> fromJust (W.requestHeaderHost req)- <> "/.sproxy/oauth2/" <> encodeUtf8 provider-+ "https://" <> fromJust (W.requestHeaderHost req) <> "/.sproxy/oauth2/" <>+ encodeUtf8 provider requestDomain :: W.Request -> Maybe ByteString requestDomain req = do h <- W.requestHeaderHost req return . fst . BS.break (== _colon) $ h - -- XXX: make sure not to reveal the cookie, which can be valid (!) showReq :: W.Request -> String-showReq req = - unpack ( W.requestMethod req <> " "- <> fromMaybe "<no host>" (W.requestHeaderHost req)- <> W.rawPathInfo req <> W.rawQueryString req <> " " )- ++ show (W.httpVersion req) ++ " "- ++ show (fromMaybe "-" $ W.requestHeaderReferer req) ++ " "- ++ show (fromMaybe "-" $ W.requestHeaderUserAgent req)- ++ " from " ++ show (W.remoteHost req)-+showReq req =+ unpack+ (W.requestMethod req <> " " <>+ fromMaybe "<no host>" (W.requestHeaderHost req) <>+ W.rawPathInfo req <>+ W.rawQueryString req <>+ " ") +++ show (W.httpVersion req) +++ " " +++ show (fromMaybe "-" $ W.requestHeaderReferer req) +++ " " +++ show (fromMaybe "-" $ W.requestHeaderUserAgent req) +++ " from " ++ show (W.remoteHost req)
src/Sproxy/Application/Access.hs view
@@ -1,23 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Sproxy.Application.Access (- Inquiry-, Question(..)-) where+module Sproxy.Application.Access+ ( Inquiry+ , Question(..)+ ) where import Data.Aeson (FromJSON) import Data.HashMap.Strict (HashMap) import Data.Text (Text) import GHC.Generics (Generic) --data Question = Question {- path :: Text-, method :: Text-} deriving (Generic, Show)+data Question = Question+ { path :: Text+ , method :: Text+ } deriving (Generic, Show) instance FromJSON Question type Inquiry = HashMap Text Question-
src/Sproxy/Application/Cookie.hs view
@@ -1,56 +1,57 @@ {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Application.Cookie (- AuthCookie(..)-, AuthUser-, cookieDecode-, cookieEncode-, getEmail-, getEmailUtf8-, getFamilyNameUtf8-, getGivenNameUtf8-, newUser-, setFamilyName-, setGivenName-) where +module Sproxy.Application.Cookie+ ( AuthCookie(..)+ , AuthUser+ , cookieDecode+ , cookieEncode+ , getEmail+ , getEmailUtf8+ , getFamilyNameUtf8+ , getGivenNameUtf8+ , newUser+ , setFamilyName+ , setGivenName+ ) where+ import Data.ByteString (ByteString)-import Data.Text (Text, toLower, strip)+import qualified Data.Serialize as DS+import Data.Text (Text, strip, toLower) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Foreign.C.Types (CTime(..))-import qualified Data.Serialize as DS import qualified Sproxy.Application.State as State -data AuthUser = AuthUser {- auEmail :: ByteString-, auGivenName :: ByteString-, auFamilyName :: ByteString-}+data AuthUser = AuthUser+ { auEmail :: ByteString+ , auGivenName :: ByteString+ , auFamilyName :: ByteString+ } -data AuthCookie = AuthCookie {- acUser :: AuthUser-, acExpiry :: CTime-}+data AuthCookie = AuthCookie+ { acUser :: AuthUser+ , acExpiry :: CTime+ } instance DS.Serialize AuthCookie where put c = DS.put (auEmail u, auGivenName u, auFamilyName u, x)- where u = acUser c- x = (\(CTime i) -> i) $ acExpiry c+ where+ u = acUser c+ x = (\(CTime i) -> i) $ acExpiry c get = do (e, n, f, x) <- DS.get- return AuthCookie {- acUser = AuthUser { auEmail = e, auGivenName = n, auFamilyName = f }+ return+ AuthCookie+ { acUser = AuthUser {auEmail = e, auGivenName = n, auFamilyName = f} , acExpiry = CTime x } - cookieDecode :: ByteString -> ByteString -> Either String AuthCookie cookieDecode key d = State.decode key d >>= DS.decode cookieEncode :: ByteString -> AuthCookie -> ByteString cookieEncode key = State.encode key . DS.encode - getEmail :: AuthUser -> Text getEmail = decodeUtf8 . auEmail @@ -63,17 +64,16 @@ getFamilyNameUtf8 :: AuthUser -> ByteString getFamilyNameUtf8 = auFamilyName - newUser :: Text -> AuthUser-newUser email = AuthUser {- auEmail = encodeUtf8 . toLower . strip $ email+newUser email =+ AuthUser+ { auEmail = encodeUtf8 . toLower . strip $ email , auGivenName = "" , auFamilyName = "" } setGivenName :: Text -> AuthUser -> AuthUser-setGivenName given au = au{ auGivenName = encodeUtf8 . strip $ given }+setGivenName given au = au {auGivenName = encodeUtf8 . strip $ given} setFamilyName :: Text -> AuthUser -> AuthUser-setFamilyName family au = au{ auFamilyName = encodeUtf8 . strip $ family }-+setFamilyName family au = au {auFamilyName = encodeUtf8 . strip $ family}
src/Sproxy/Application/OAuth2.hs view
@@ -1,18 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Application.OAuth2 (- providers-) where +module Sproxy.Application.OAuth2+ ( providers+ ) where+ import Data.HashMap.Strict (HashMap, fromList) import Data.Text (Text) import Sproxy.Application.OAuth2.Common (OAuth2Provider) import qualified Sproxy.Application.OAuth2.Google as Google import qualified Sproxy.Application.OAuth2.LinkedIn as LinkedIn+import qualified Sproxy.Application.OAuth2.Yandex as Yandex providers :: HashMap Text OAuth2Provider-providers = fromList [- ("google" , Google.provider)- , ("linkedin" , LinkedIn.provider)- ]-+providers =+ fromList+ [ ("google", Google.provider)+ , ("linkedin", LinkedIn.provider)+ , ("yandex", Yandex.provider)+ ]
src/Sproxy/Application/OAuth2/Common.hs view
@@ -1,40 +1,37 @@ {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Application.OAuth2.Common (- AccessTokenBody(..)-, OAuth2Client(..)-, OAuth2Provider-) where +module Sproxy.Application.OAuth2.Common+ ( AccessTokenBody(..)+ , OAuth2Client(..)+ , OAuth2Provider+ ) where+ import Control.Applicative (empty)-import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:))-import Data.ByteString(ByteString)+import Data.Aeson (FromJSON, Value(Object), (.:), parseJSON)+import Data.ByteString (ByteString) import Data.Text (Text) import Sproxy.Application.Cookie (AuthUser) -data OAuth2Client = OAuth2Client {- oauth2Description :: String-, oauth2AuthorizeURL- :: ByteString -- state- -> ByteString -- redirect url- -> ByteString-, oauth2Authenticate- :: ByteString -- code- -> ByteString -- redirect url- -> IO AuthUser-}+data OAuth2Client = OAuth2Client+ { oauth2Description :: String+ , oauth2AuthorizeURL :: ByteString -- state+ -> ByteString -- redirect url+ -> ByteString+ , oauth2Authenticate :: ByteString -- code+ -> ByteString -- redirect url+ -> IO AuthUser+ } type OAuth2Provider = (ByteString, ByteString) -> OAuth2Client -- | RFC6749. We ignore optional token_type ("Bearer" from Google, omitted by LinkedIn) -- and expires_in because we don't use them, *and* expires_in creates troubles: -- it's an integer from Google and string from LinkedIn (sic!)-data AccessTokenBody = AccessTokenBody {- accessToken :: Text-} deriving (Eq, Show)+data AccessTokenBody = AccessTokenBody+ { accessToken :: Text+ } deriving (Eq, Show) instance FromJSON AccessTokenBody where- parseJSON (Object v) = AccessTokenBody- <$> v .: "access_token"+ parseJSON (Object v) = AccessTokenBody <$> v .: "access_token" parseJSON _ = empty-
src/Sproxy/Application/OAuth2/Google.hs view
@@ -1,81 +1,87 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Application.OAuth2.Google (- provider-) where +module Sproxy.Application.OAuth2.Google+ ( provider+ ) where+ import Control.Applicative (empty) import Control.Exception (Exception, throwIO)-import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))+import Data.Aeson+ (FromJSON, Value(Object), (.:), decode, parseJSON) import Data.ByteString.Lazy (ByteString) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Typeable (Typeable)-import Network.HTTP.Types (hContentType)-import Network.HTTP.Types.URI (urlEncode) import qualified Network.HTTP.Conduit as H--import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName)-import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)+import Network.HTTP.Types.URI (urlEncode) +import Sproxy.Application.Cookie+ (newUser, setFamilyName, setGivenName)+import Sproxy.Application.OAuth2.Common+ (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) provider :: OAuth2Provider provider (client_id, client_secret) =- OAuth2Client {- oauth2Description = "Google"- , oauth2AuthorizeURL = \state redirect_uri ->- "https://accounts.google.com/o/oauth2/v2/auth"- <> "?scope=" <> urlEncode True "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile"- <> "&client_id=" <> urlEncode True client_id- <> "&prompt=select_account"- <> "&redirect_uri=" <> urlEncode True redirect_uri- <> "&response_type=code"- <> "&state=" <> urlEncode True state-- , oauth2Authenticate = \code redirect_uri -> do- let treq = H.setQueryString [- ("client_id" , Just client_id)- , ("client_secret" , Just client_secret)- , ("code" , Just code)- , ("grant_type" , Just "authorization_code")- , ("redirect_uri" , Just redirect_uri)- ] $ (H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token") {- H.requestHeaders = [- (hContentType, "application/x-www-form-urlencoded")- ]- }- mgr <- H.newManager H.tlsManagerSettings- tresp <- H.httpLbs treq mgr- case decode $ H.responseBody tresp of- Nothing -> throwIO $ GoogleException tresp- Just atResp -> do- ureq <- H.parseRequest $ unpack ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> accessToken atResp)- uresp <- H.httpLbs ureq mgr- case decode $ H.responseBody uresp of- Nothing -> throwIO $ GoogleException uresp- Just u -> return $ setFamilyName (familyName u) $- setGivenName (givenName u) $- newUser (email u)+ OAuth2Client+ { oauth2Description = "Google"+ , oauth2AuthorizeURL =+ \state redirect_uri ->+ "https://accounts.google.com/o/oauth2/v2/auth" <> "?scope=" <>+ urlEncode+ True+ "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" <>+ "&client_id=" <>+ urlEncode True client_id <>+ "&prompt=select_account" <>+ "&redirect_uri=" <>+ urlEncode True redirect_uri <>+ "&response_type=code" <>+ "&state=" <>+ urlEncode True state+ , oauth2Authenticate =+ \code redirect_uri -> do+ let treq =+ H.urlEncodedBody+ [ ("client_id", client_id)+ , ("client_secret", client_secret)+ , ("code", code)+ , ("grant_type", "authorization_code")+ , ("redirect_uri", redirect_uri)+ ] $+ H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token"+ mgr <- H.newManager H.tlsManagerSettings+ tresp <- H.httpLbs treq mgr+ case decode $ H.responseBody tresp of+ Nothing -> throwIO $ GoogleException tresp+ Just atResp -> do+ ureq <-+ H.parseRequest $+ unpack+ ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <>+ accessToken atResp)+ uresp <- H.httpLbs ureq mgr+ case decode $ H.responseBody uresp of+ Nothing -> throwIO $ GoogleException uresp+ Just u ->+ return $+ setFamilyName (familyName u) $+ setGivenName (givenName u) $ newUser (email u) } --data GoogleException = GoogleException (H.Response ByteString)+data GoogleException =+ GoogleException (H.Response ByteString) deriving (Show, Typeable) - instance Exception GoogleException --data GoogleUserInfo = GoogleUserInfo {- email :: Text-, givenName :: Text-, familyName :: Text-} deriving (Eq, Show)+data GoogleUserInfo = GoogleUserInfo+ { email :: Text+ , givenName :: Text+ , familyName :: Text+ } deriving (Eq, Show) instance FromJSON GoogleUserInfo where- parseJSON (Object v) = GoogleUserInfo- <$> v .: "email"- <*> v .: "given_name"- <*> v .: "family_name"+ parseJSON (Object v) =+ GoogleUserInfo <$> v .: "email" <*> v .: "given_name" <*> v .: "family_name" parseJSON _ = empty-
src/Sproxy/Application/OAuth2/LinkedIn.hs view
@@ -1,84 +1,91 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Application.OAuth2.LinkedIn (- provider-) where +module Sproxy.Application.OAuth2.LinkedIn+ ( provider+ ) where+ import Control.Applicative (empty) import Control.Exception (Exception, throwIO)-import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))+import Data.Aeson+ (FromJSON, Value(Object), (.:), decode, parseJSON) import Data.ByteString.Lazy (ByteString) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable)-import Network.HTTP.Types (hContentType)-import Network.HTTP.Types.URI (urlEncode) import qualified Network.HTTP.Conduit as H--import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName)-import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)+import Network.HTTP.Types.URI (urlEncode) +import Sproxy.Application.Cookie+ (newUser, setFamilyName, setGivenName)+import Sproxy.Application.OAuth2.Common+ (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) provider :: OAuth2Provider provider (client_id, client_secret) =- OAuth2Client {- oauth2Description = "LinkedIn"- , oauth2AuthorizeURL = \state redirect_uri ->- "https://www.linkedin.com/oauth/v2/authorization"- <> "?scope=r_basicprofile%20r_emailaddress"- <> "&client_id=" <> urlEncode True client_id- <> "&redirect_uri=" <> urlEncode True redirect_uri- <> "&response_type=code"- <> "&state=" <> urlEncode True state-- , oauth2Authenticate = \code redirect_uri -> do- let treq = H.setQueryString [- ("client_id" , Just client_id)- , ("client_secret" , Just client_secret)- , ("code" , Just code)- , ("grant_type" , Just "authorization_code")- , ("redirect_uri" , Just redirect_uri)- ] $ (H.parseRequest_ "POST https://www.linkedin.com/oauth/v2/accessToken") {- H.requestHeaders = [- (hContentType, "application/x-www-form-urlencoded")- ]- }- mgr <- H.newManager H.tlsManagerSettings- tresp <- H.httpLbs treq mgr- case decode $ H.responseBody tresp of- Nothing -> throwIO $ LinkedInException tresp- Just atResp -> do- let ureq = (H.parseRequest_ "https://api.linkedin.com/v1/people/\- \~:(email-address,first-name,last-name)?format=json") {- H.requestHeaders = [ ("Authorization", "Bearer " <> encodeUtf8 (accessToken atResp)) ]- }- uresp <- H.httpLbs ureq mgr- case decode $ H.responseBody uresp of- Nothing -> throwIO $ LinkedInException uresp- Just u -> return $ setFamilyName (lastName u) $- setGivenName (firstName u) $- newUser (emailAddress u)+ OAuth2Client+ { oauth2Description = "LinkedIn"+ , oauth2AuthorizeURL =+ \state redirect_uri ->+ "https://www.linkedin.com/oauth/v2/authorization" <>+ "?scope=r_basicprofile%20r_emailaddress" <>+ "&client_id=" <>+ urlEncode True client_id <>+ "&redirect_uri=" <>+ urlEncode True redirect_uri <>+ "&response_type=code" <>+ "&state=" <>+ urlEncode True state+ , oauth2Authenticate =+ \code redirect_uri -> do+ let treq =+ H.urlEncodedBody+ [ ("client_id", client_id)+ , ("client_secret", client_secret)+ , ("code", code)+ , ("grant_type", "authorization_code")+ , ("redirect_uri", redirect_uri)+ ] $+ H.parseRequest_+ "POST https://www.linkedin.com/oauth/v2/accessToken"+ mgr <- H.newManager H.tlsManagerSettings+ tresp <- H.httpLbs treq mgr+ case decode $ H.responseBody tresp of+ Nothing -> throwIO $ LinkedInException tresp+ Just atResp -> do+ let ureq =+ (H.parseRequest_+ "https://api.linkedin.com/v1/people/\+ \~:(email-address,first-name,last-name)?format=json")+ { H.requestHeaders =+ [ ( "Authorization"+ , "Bearer " <> encodeUtf8 (accessToken atResp))+ ]+ }+ uresp <- H.httpLbs ureq mgr+ case decode $ H.responseBody uresp of+ Nothing -> throwIO $ LinkedInException uresp+ Just u ->+ return $+ setFamilyName (lastName u) $+ setGivenName (firstName u) $ newUser (emailAddress u) } --data LinkedInException = LinkedInException (H.Response ByteString)+data LinkedInException =+ LinkedInException (H.Response ByteString) deriving (Show, Typeable) - instance Exception LinkedInException --data LinkedInUserInfo = LinkedInUserInfo {- emailAddress :: Text-, firstName :: Text-, lastName :: Text-} deriving (Eq, Show)+data LinkedInUserInfo = LinkedInUserInfo+ { emailAddress :: Text+ , firstName :: Text+ , lastName :: Text+ } deriving (Eq, Show) instance FromJSON LinkedInUserInfo where- parseJSON (Object v) = LinkedInUserInfo- <$> v .: "emailAddress"- <*> v .: "firstName"- <*> v .: "lastName"+ parseJSON (Object v) =+ LinkedInUserInfo <$> v .: "emailAddress" <*> v .: "firstName" <*>+ v .: "lastName" parseJSON _ = empty-
+ src/Sproxy/Application/OAuth2/Yandex.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Sproxy.Application.OAuth2.Yandex+ ( provider+ ) where++import Control.Applicative (empty)+import Control.Exception (Exception, throwIO)+import Data.Aeson+ (FromJSON, Value(Object), (.:), decode, parseJSON)+import Data.ByteString.Lazy (ByteString)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Typeable (Typeable)+import qualified Network.HTTP.Conduit as H+import Network.HTTP.Types.URI (urlEncode)++import Sproxy.Application.Cookie+ (newUser, setFamilyName, setGivenName)+import Sproxy.Application.OAuth2.Common+ (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)++provider :: OAuth2Provider+provider (client_id, client_secret) =+ OAuth2Client+ { oauth2Description = "Yandex"+ , oauth2AuthorizeURL =+ \state _redirect_uri ->+ "https://oauth.yandex.ru/authorize" <> "?state=" <> urlEncode True state <>+ "&client_id=" <>+ urlEncode True client_id <>+ "&response_type=code" <>+ "&force_confirm=yes"+ , oauth2Authenticate =+ \code _redirect_uri -> do+ let treq =+ H.urlEncodedBody+ [ ("grant_type", "authorization_code")+ , ("client_id", client_id)+ , ("client_secret", client_secret)+ , ("code", code)+ ] $+ H.parseRequest_ "POST https://oauth.yandex.ru/token"+ mgr <- H.newManager H.tlsManagerSettings+ tresp <- H.httpLbs treq mgr+ case decode $ H.responseBody tresp of+ Nothing -> throwIO $ YandexException tresp+ Just atResp -> do+ let ureq =+ (H.parseRequest_ "https://login.yandex.ru/info?format=json")+ { H.requestHeaders =+ [ ( "Authorization"+ , "OAuth " <> encodeUtf8 (accessToken atResp))+ ]+ }+ uresp <- H.httpLbs ureq mgr+ case decode $ H.responseBody uresp of+ Nothing -> throwIO $ YandexException uresp+ Just u ->+ return $+ setFamilyName (lastName u) $+ setGivenName (firstName u) $ newUser (defaultEmail u)+ }++data YandexException =+ YandexException (H.Response ByteString)+ deriving (Show, Typeable)++instance Exception YandexException++data YandexUserInfo = YandexUserInfo+ { defaultEmail :: Text+ , firstName :: Text+ , lastName :: Text+ } deriving (Eq, Show)++instance FromJSON YandexUserInfo where+ parseJSON (Object v) =+ YandexUserInfo <$> v .: "default_email" <*> v .: "first_name" <*>+ v .: "last_name"+ parseJSON _ = empty
src/Sproxy/Application/State.hs view
@@ -1,30 +1,25 @@-module Sproxy.Application.State (- decode-, encode-) where+module Sproxy.Application.State+ ( decode+ , encode+ ) where import Data.ByteString (ByteString)-import Data.ByteString.Lazy (fromStrict, toStrict)-import Data.Digest.Pure.SHA (hmacSha1, bytestringDigest) import qualified Data.ByteString.Base64 as Base64+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Digest.Pure.SHA (bytestringDigest, hmacSha1) import qualified Data.Serialize as DS - -- FIXME: Compress / decompress ?-- encode :: ByteString -> ByteString -> ByteString encode key payload = Base64.encode . DS.encode $ (payload, digest key payload) - decode :: ByteString -> ByteString -> Either String ByteString decode key d = do (payload, dgst) <- DS.decode =<< Base64.decode d if dgst /= digest key payload- then Left "junk"- else Right payload- + then Left "junk"+ else Right payload digest :: ByteString -> ByteString -> ByteString-digest key payload = toStrict . bytestringDigest $ hmacSha1 (fromStrict key) (fromStrict payload)-+digest key payload =+ toStrict . bytestringDigest $ hmacSha1 (fromStrict key) (fromStrict payload)
src/Sproxy/Config.hs view
@@ -1,94 +1,89 @@ {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Config (- BackendConf(..)-, ConfigFile(..)-, OAuth2Conf(..)-) where +module Sproxy.Config+ ( BackendConf(..)+ , ConfigFile(..)+ , OAuth2Conf(..)+ ) where+ import Control.Applicative (empty) import Data.Aeson (FromJSON, parseJSON) import Data.HashMap.Strict (HashMap) import Data.Int (Int64) import Data.Text (Text) import Data.Word (Word16)-import Data.Yaml (Value(Object), (.:), (.:?), (.!=))+import Data.Yaml (Value(Object), (.!=), (.:), (.:?)) import Sproxy.Logging (LogLevel(Debug)) -data ConfigFile = ConfigFile {- cfListen :: Word16-, cfSsl :: Bool-, cfUser :: String-, cfHome :: FilePath-, cfLogLevel :: LogLevel-, cfSslCert :: Maybe FilePath-, cfSslKey :: Maybe FilePath-, cfSslCertChain :: [FilePath]-, cfKey :: Maybe String-, cfListen80 :: Maybe Bool-, cfHttpsPort :: Maybe Word16-, cfBackends :: [BackendConf]-, cfOAuth2 :: HashMap Text OAuth2Conf-, cfDataFile :: Maybe FilePath-, cfDatabase :: Maybe String-, cfPgPassFile :: Maybe FilePath-, cfHTTP2 :: Bool-} deriving (Show)+data ConfigFile = ConfigFile+ { cfListen :: Word16+ , cfSsl :: Bool+ , cfUser :: String+ , cfHome :: FilePath+ , cfLogLevel :: LogLevel+ , cfSslCert :: Maybe FilePath+ , cfSslKey :: Maybe FilePath+ , cfSslCertChain :: [FilePath]+ , cfKey :: Maybe String+ , cfListen80 :: Maybe Bool+ , cfHttpsPort :: Maybe Word16+ , cfBackends :: [BackendConf]+ , cfOAuth2 :: HashMap Text OAuth2Conf+ , cfDataFile :: Maybe FilePath+ , cfDatabase :: Maybe String+ , cfPgPassFile :: Maybe FilePath+ , cfHTTP2 :: Bool+ } deriving (Show) instance FromJSON ConfigFile where- parseJSON (Object m) = ConfigFile <$>- m .:? "listen" .!= 443- <*> m .:? "ssl" .!= True- <*> m .:? "user" .!= "sproxy"- <*> m .:? "home" .!= "."- <*> m .:? "log_level" .!= Debug- <*> m .:? "ssl_cert"- <*> m .:? "ssl_key"- <*> m .:? "ssl_cert_chain" .!= []- <*> m .:? "key"- <*> m .:? "listen80"- <*> m .:? "https_port"- <*> m .: "backends"- <*> m .: "oauth2"- <*> m .:? "datafile"- <*> m .:? "database"- <*> m .:? "pgpassfile"- <*> m .:? "http2" .!= True+ parseJSON (Object m) =+ ConfigFile <$> m .:? "listen" .!= 443 <*> m .:? "ssl" .!= True <*>+ m .:? "user" .!= "sproxy" <*>+ m .:? "home" .!= "." <*>+ m .:? "log_level" .!= Debug <*>+ m .:? "ssl_cert" <*>+ m .:? "ssl_key" <*>+ m .:? "ssl_cert_chain" .!= [] <*>+ m .:? "key" <*>+ m .:? "listen80" <*>+ m .:? "https_port" <*>+ m .: "backends" <*>+ m .: "oauth2" <*>+ m .:? "datafile" <*>+ m .:? "database" <*>+ m .:? "pgpassfile" <*>+ m .:? "http2" .!= True parseJSON _ = empty --data BackendConf = BackendConf {- beName :: String-, beAddress :: String-, bePort :: Maybe Word16-, beSocket :: Maybe FilePath-, beCookieName :: String-, beCookieDomain :: Maybe String-, beCookieMaxAge :: Int64-, beConnCount :: Int-} deriving (Show)+data BackendConf = BackendConf+ { beName :: String+ , beAddress :: String+ , bePort :: Maybe Word16+ , beSocket :: Maybe FilePath+ , beCookieName :: String+ , beCookieDomain :: Maybe String+ , beCookieMaxAge :: Int64+ , beConnCount :: Int+ } deriving (Show) instance FromJSON BackendConf where- parseJSON (Object m) = BackendConf <$>- m .:? "name" .!= "*"- <*> m .:? "address" .!= "127.0.0.1"- <*> m .:? "port"- <*> m .:? "socket"- <*> m .:? "cookie_name" .!= "sproxy"- <*> m .:? "cookie_domain"- <*> m .:? "cookie_max_age" .!= (7 * 24 * 60 * 60)- <*> m .:? "conn_count" .!= 32+ parseJSON (Object m) =+ BackendConf <$> m .:? "name" .!= "*" <*> m .:? "address" .!= "127.0.0.1" <*>+ m .:? "port" <*>+ m .:? "socket" <*>+ m .:? "cookie_name" .!= "sproxy" <*>+ m .:? "cookie_domain" <*>+ m .:? "cookie_max_age" .!= (7 * 24 * 60 * 60) <*>+ m .:? "conn_count" .!= 32 parseJSON _ = empty --data OAuth2Conf = OAuth2Conf {- oa2ClientId :: String-, oa2ClientSecret :: String-} deriving (Show)+data OAuth2Conf = OAuth2Conf+ { oa2ClientId :: String+ , oa2ClientSecret :: String+ } deriving (Show) instance FromJSON OAuth2Conf where- parseJSON (Object m) = OAuth2Conf <$>- m .: "client_id"- <*> m .: "client_secret"+ parseJSON (Object m) =+ OAuth2Conf <$> m .: "client_id" <*> m .: "client_secret" parseJSON _ = empty-
src/Sproxy/Logging.hs view
@@ -1,12 +1,12 @@-module Sproxy.Logging (- LogLevel(..)-, debug-, error-, info-, level-, start-, warn-) where+module Sproxy.Logging+ ( LogLevel(..)+ , debug+ , error+ , info+ , level+ , start+ , warn+ ) where import Prelude hiding (error) @@ -15,13 +15,13 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Monad (forever, when) import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as JSON import Data.Char (toLower) import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Data.Text as T import System.IO (hPrint, stderr) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe)-import qualified Data.Aeson as JSON-import qualified Data.Text as T start :: LogLevel -> IO () start None = return ()@@ -34,16 +34,15 @@ info :: String -> IO () info = send . Message Info -warn:: String -> IO ()+warn :: String -> IO () warn = send . Message Warning -error:: String -> IO ()+error :: String -> IO () error = send . Message Error debug :: String -> IO () debug = send . Message Debug - send :: Message -> IO () send msg@(Message l _) = do lvl <- level@@ -62,38 +61,46 @@ level :: IO LogLevel level = readIORef logLevel --data LogLevel = None | Error | Warning | Info | Debug+data LogLevel+ = None+ | Error+ | Warning+ | Info+ | Debug deriving (Enum, Ord, Eq) instance Show LogLevel where- show None = "NONE"- show Error = "ERROR"+ show None = "NONE"+ show Error = "ERROR" show Warning = "WARN"- show Info = "INFO"- show Debug = "DEBUG"+ show Info = "INFO"+ show Debug = "DEBUG" instance Read LogLevel where readsPrec _ s- | l == "none" = [ (None, "") ]- | l == "error" = [ (Error, "") ]- | l == "warn" = [ (Warning, "") ]- | l == "info" = [ (Info, "") ]- | l == "debug" = [ (Debug, "") ]- | otherwise = [ ]- where l = map toLower s+ | l == "none" = [(None, "")]+ | l == "error" = [(Error, "")]+ | l == "warn" = [(Warning, "")]+ | l == "info" = [(Info, "")]+ | l == "debug" = [(Debug, "")]+ | otherwise = []+ where+ l = map toLower s instance ToJSON LogLevel where toJSON = JSON.String . T.pack . show instance FromJSON LogLevel where parseJSON (JSON.String s) =- maybe (fail $ "unknown log level: " ++ show s) return (readMaybe . T.unpack $ s)+ maybe+ (fail $ "unknown log level: " ++ show s)+ return+ (readMaybe . T.unpack $ s) parseJSON _ = empty --data Message = Message LogLevel String+data Message =+ Message LogLevel+ String instance Show Message where show (Message lvl str) = show lvl ++ ": " ++ str-
src/Sproxy/Server.hs view
@@ -1,6 +1,6 @@-module Sproxy.Server (- server-) where+module Sproxy.Server+ ( server+ ) where import Control.Concurrent (forkIO) import Control.Exception (bracketOnError)@@ -11,136 +11,128 @@ import Data.Text (Text) import Data.Word (Word16) import Data.Yaml.Include (decodeFileEither)-import Network.HTTP.Client (Manager, ManagerSettings(..), defaultManagerSettings, newManager, socketConnection)+import Network.HTTP.Client+ (Manager, ManagerSettings(..), defaultManagerSettings, newManager,+ socketConnection) import Network.HTTP.Client.Internal (Connection)-import Network.Socket ( Socket, Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix),- SocketOption(ReuseAddr), SocketType(Stream), bind, close, connect, inet_addr,- listen, maxListenQueue, setSocketOption, socket )+import Network.Socket+ (Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix),+ Socket, SocketOption(ReuseAddr), SocketType(Stream), bind, close,+ connect, inet_addr, listen, maxListenQueue, setSocketOption,+ socket) import Network.Wai (Application)-import Network.Wai.Handler.WarpTLS (tlsSettingsChain, runTLSSocket)-import Network.Wai.Handler.Warp ( Settings, defaultSettings, runSettingsSocket,- setHTTP2Disabled, setOnException )+import Network.Wai.Handler.Warp+ (Settings, defaultSettings, runSettingsSocket, setHTTP2Disabled,+ setOnException)+import Network.Wai.Handler.WarpTLS (runTLSSocket, tlsSettingsChain) import System.Entropy (getEntropy) import System.Environment (setEnv) import System.Exit (exitFailure) import System.FilePath.Glob (compile) import System.IO (hPutStrLn, stderr)-import System.Posix.User ( GroupEntry(..), UserEntry(..),- getAllGroupEntries, getRealUserID,- getUserEntryForName, setGroupID, setGroups, setUserID )+import System.Posix.User+ (GroupEntry(..), UserEntry(..), getAllGroupEntries, getRealUserID,+ getUserEntryForName, setGroupID, setGroups, setUserID) -import Sproxy.Application (sproxy, redirect)-import Sproxy.Application.OAuth2.Common (OAuth2Client)-import Sproxy.Config (BackendConf(..), ConfigFile(..), OAuth2Conf(..))+import Sproxy.Application (redirect, sproxy) import qualified Sproxy.Application.OAuth2 as OAuth2+import Sproxy.Application.OAuth2.Common (OAuth2Client)+import Sproxy.Config+ (BackendConf(..), ConfigFile(..), OAuth2Conf(..)) import qualified Sproxy.Logging as Log import qualified Sproxy.Server.DB as DB - {- TODO: - Log.error && exitFailure should be replaced - by Log.fatal && wait for logger thread to print && exitFailure -}- server :: FilePath -> IO () server configFile = do cf <- readConfigFile configFile Log.start $ cfLogLevel cf- sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 bind sock $ SockAddrInet (fromIntegral $ cfListen cf) 0-- maybe80 <- if fromMaybe (443 == cfListen cf) (cfListen80 cf)- then do- sock80 <- socket AF_INET Stream 0- setSocketOption sock80 ReuseAddr 1- bind sock80 $ SockAddrInet 80 0- return (Just sock80)- else- return Nothing-+ maybe80 <-+ if fromMaybe (443 == cfListen cf) (cfListen80 cf)+ then do+ sock80 <- socket AF_INET Stream 0+ setSocketOption sock80 ReuseAddr 1+ bind sock80 $ SockAddrInet 80 0+ return (Just sock80)+ else return Nothing uid <- getRealUserID when (0 == uid) $ do let user = cfUser cf Log.info $ "switching to user " ++ show user u <- getUserEntryForName user- groupIDs <- map groupID . filter (elem user . groupMembers)- <$> getAllGroupEntries+ groupIDs <-+ map groupID . filter (elem user . groupMembers) <$> getAllGroupEntries setGroups groupIDs setGroupID $ userGroupID u setUserID $ userID u- ds <- newDataSource cf db <- DB.start (cfHome cf) ds-- key <- maybe- (Log.info "using new random key" >> getEntropy 32)- (return . pack)- (cfKey cf)-- let- settings =- (if cfHTTP2 cf then id else setHTTP2Disabled) $- setOnException (\_ _ -> return ())- defaultSettings-- oauth2clients <- HM.fromList <$> mapM newOAuth2Client (HM.toList (cfOAuth2 cf))-+ key <-+ maybe+ (Log.info "using new random key" >> getEntropy 32)+ (return . pack)+ (cfKey cf)+ let settings =+ (if cfHTTP2 cf+ then id+ else setHTTP2Disabled) $+ setOnException (\_ _ -> return ()) defaultSettings+ oauth2clients <-+ HM.fromList <$> mapM newOAuth2Client (HM.toList (cfOAuth2 cf)) backends <-- mapM (\be -> do- m <- newBackendManager be- return (compile $ beName be, be, m)- ) $ cfBackends cf--+ mapM+ (\be -> do+ m <- newBackendManager be+ return (compile $ beName be, be, m)) $+ cfBackends cf warpServer <- newServer cf- case maybe80 of- Nothing -> return ()+ Nothing -> return () Just sock80 -> do let httpsPort = fromMaybe (cfListen cf) (cfHttpsPort cf) Log.info "listening on port 80 (HTTP redirect)" listen sock80 maxListenQueue void . forkIO $ runSettingsSocket settings sock80 (redirect httpsPort)- -- XXX 2048 is from bindPortTCP from streaming-commons used internally by runTLS. -- XXX Since we don't call runTLS, we listen socket here with the same options. Log.info $ "proxy listening on port " ++ show (cfListen cf) listen sock (max 2048 maxListenQueue) warpServer settings sock (sproxy key db oauth2clients backends) - newDataSource :: ConfigFile -> IO (Maybe DB.DataSource) newDataSource cf = case (cfDataFile cf, cfDatabase cf) of (Nothing, Just str) -> do case cfPgPassFile cf of Nothing -> return ()- Just f -> do+ Just f -> do Log.info $ "pgpassfile: " ++ show f setEnv "PGPASSFILE" f return . Just $ DB.PostgreSQL str-- (Just f, Nothing) -> return . Just $ DB.File f-- (Nothing, Nothing) -> return Nothing+ (Just f, Nothing) -> return . Just $ DB.File f+ (Nothing, Nothing) -> return Nothing _ -> do Log.error "only one data source can be used" exitFailure - newOAuth2Client :: (Text, OAuth2Conf) -> IO (Text, OAuth2Client) newOAuth2Client (name, cfg) = case HM.lookup name OAuth2.providers of- Nothing -> do Log.error $ "OAuth2 provider " ++ show name ++ " is not supported"- exitFailure+ Nothing -> do+ Log.error $ "OAuth2 provider " ++ show name ++ " is not supported"+ exitFailure Just provider -> do Log.info $ "oauth2: adding " ++ show name return (name, provider (client_id, client_secret))- where client_id = pack $ oa2ClientId cfg- client_secret = pack $ oa2ClientSecret cfg-+ where+ client_id = pack $ oa2ClientId cfg+ client_secret = pack $ oa2ClientSecret cfg newBackendManager :: BackendConf -> IO Manager newBackendManager be = do@@ -149,20 +141,18 @@ (Just f, Nothing) -> do Log.info $ "backend `" ++ beName be ++ "' on UNIX socket " ++ f return $ openUnixSocketConnection f- (Nothing, Just n) -> do- Log.info $ "backend `" ++ beName be ++ "' on " ++ beAddress be ++ ":" ++ show n+ Log.info $+ "backend `" ++ beName be ++ "' on " ++ beAddress be ++ ":" ++ show n return $ openTCPConnection (beAddress be) n- _ -> do- Log.error "either backend port number or UNIX socket path is required."- exitFailure-- newManager defaultManagerSettings {- managerRawConnection = return $ \_ _ _ -> openConn- , managerConnCount = beConnCount be- }-+ Log.error "either backend port number or UNIX socket path is required."+ exitFailure+ newManager+ defaultManagerSettings+ { managerRawConnection = return $ \_ _ _ -> openConn+ , managerConnCount = beConnCount be+ } newServer :: ConfigFile -> IO (Settings -> Socket -> Application -> IO ()) newServer cf@@ -170,33 +160,31 @@ case (cfSslKey cf, cfSslCert cf) of (Just k, Just c) -> return $ runTLSSocket (tlsSettingsChain c (cfSslCertChain cf) k)- _ -> do Log.error "missings SSL certificate"- exitFailure+ _ -> do+ Log.error "missings SSL certificate"+ exitFailure | otherwise = do- Log.warn "not using SSL!"- return runSettingsSocket-+ Log.warn "not using SSL!"+ return runSettingsSocket openUnixSocketConnection :: FilePath -> IO Connection openUnixSocketConnection f = bracketOnError- (socket AF_UNIX Stream 0)- close- (\s -> do- connect s (SockAddrUnix f)- socketConnection s 8192)-+ (socket AF_UNIX Stream 0)+ close+ (\s -> do+ connect s (SockAddrUnix f)+ socketConnection s 8192) openTCPConnection :: String -> Word16 -> IO Connection openTCPConnection addr port = bracketOnError- (socket AF_INET Stream 0)- close- (\s -> do- a <- inet_addr addr- connect s (SockAddrInet (fromIntegral port) a)- socketConnection s 8192)-+ (socket AF_INET Stream 0)+ close+ (\s -> do+ a <- inet_addr addr+ connect s (SockAddrInet (fromIntegral port) a)+ socketConnection s 8192) readConfigFile :: FilePath -> IO ConfigFile readConfigFile f = do@@ -206,4 +194,3 @@ hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show e exitFailure Right cf -> return cf-
src/Sproxy/Server/DB.hs view
@@ -1,72 +1,83 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-module Sproxy.Server.DB (- Database-, DataSource(..)-, userAccess-, userExists-, userGroups-, start-) where +module Sproxy.Server.DB+ ( Database+ , DataSource(..)+ , userAccess+ , userExists+ , userGroups+ , start+ ) where+ import Control.Concurrent (forkIO, threadDelay) import Control.Exception (SomeException, bracket, catch, finally) import Control.Monad (filterM, forever, void) import Data.ByteString.Char8 (pack)+import qualified Data.HashMap.Strict as HM import Data.Pool (Pool, createPool, withResource) import Data.Text (Text, toLower, unpack) import Data.Yaml (decodeFileEither)-import Database.SQLite.Simple (NamedParam((:=)))-import Text.InterpolatedString.Perl6 (q, qc)-import qualified Data.HashMap.Strict as HM import qualified Database.PostgreSQL.Simple as PG+import Database.SQLite.Simple (NamedParam((:=))) import qualified Database.SQLite.Simple as SQLite+import Text.InterpolatedString.Perl6 (q, qc) -import Sproxy.Server.DB.DataFile ( DataFile(..), GroupMember(..),- GroupPrivilege(..), PrivilegeRule(..) ) import qualified Sproxy.Application.Access as A import qualified Sproxy.Logging as Log-+import Sproxy.Server.DB.DataFile+ (DataFile(..), GroupMember(..), GroupPrivilege(..),+ PrivilegeRule(..)) type Database = Pool SQLite.Connection -data DataSource = PostgreSQL String | File FilePath+data DataSource+ = PostgreSQL String+ | File FilePath {- TODO: - Hash remote tables and update the local only when the remote change - Switch to REGEX - Generalize sync procedures for different tables -}- start :: FilePath -> Maybe DataSource -> IO Database start home ds = do Log.info $ "home directory: " ++ show home- db <- createPool - (do c <- SQLite.open $ home ++ "/sproxy.sqlite3"- lvl <- Log.level- SQLite.setTrace c (if lvl == Log.Debug then Just $ Log.debug . unpack else Nothing)- return c)- SQLite.close- 1 -- stripes- 3600 -- keep alive (seconds). FIXME: no much sense as it's a local file- 128 -- max connections. FIXME: make configurable?-+ db <-+ createPool+ (do c <- SQLite.open $ home ++ "/sproxy.sqlite3"+ lvl <- Log.level+ SQLite.setTrace+ c+ (if lvl == Log.Debug+ then Just $ Log.debug . unpack+ else Nothing)+ return c)+ SQLite.close+ 1 -- stripes+ 3600 -- keep alive (seconds). FIXME: no much sense as it's a local file+ 128 -- max connections. FIXME: make configurable? withResource db $ \c -> SQLite.execute_ c "PRAGMA journal_mode=WAL" populate db ds return db - userExists :: Database -> Text -> IO Bool userExists db email = do- r <- withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c- "SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"- [ ":email" := email ]+ r <-+ withResource db $ \c ->+ fmap SQLite.fromOnly <$>+ SQLite.queryNamed+ c+ "SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"+ [":email" := email] return $ head r - userGroups_ :: SQLite.Connection -> Text -> Text -> Text -> Text -> IO [Text] userGroups_ c email domain path method =- fmap SQLite.fromOnly <$> SQLite.queryNamed c [q|+ fmap SQLite.fromOnly <$>+ SQLite.queryNamed+ c+ [q| SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group" = gp."group" WHERE :email LIKE gm.email AND gp.domain = :domain@@ -77,12 +88,12 @@ AND method = :method ORDER BY length(path) - length(replace(path, '/', '')) DESC LIMIT 1 )- |] [ ":email" := email -- XXX always in lower case- , ":domain" := toLower domain- , ":path" := path- , ":method" := method -- XXX case-sensitive by RFC2616- ]-+ |]+ [ ":email" := email -- XXX always in lower case+ , ":domain" := toLower domain+ , ":path" := path+ , ":method" := method -- XXX case-sensitive by RFC2616+ ] userAccess :: Database -> Text -> Text -> A.Inquiry -> IO [Text] userAccess db email domain inq = do@@ -90,80 +101,85 @@ not . null <$> userGroups_ c email domain (A.path qn) (A.method qn) map fst <$> withResource db (\c -> filterM (permitted c) (HM.toList inq)) - userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text] userGroups db email domain path method = withResource db $ \c -> userGroups_ c email domain path method - populate :: Database -> Maybe DataSource -> IO ()- populate db Nothing = do Log.warn "db: no data source defined"- withResource db $ \c -> SQLite.withTransaction c $ do- createGroupMember c- createGroupPrivilege c- createPrivilegeRule c-+ withResource db $ \c ->+ SQLite.withTransaction c $ do+ createGroupMember c+ createGroupPrivilege c+ createPrivilegeRule c populate db (Just (File f)) = do Log.info $ "db: reading " ++ show f r <- decodeFileEither f case r of- Left e -> Log.error $ f ++ ": " ++ show e+ Left e -> Log.error $ f ++ ": " ++ show e Right df ->- withResource db $ \c -> SQLite.withTransaction c $ do- refreshGroupMembers c $ \st ->- mapM_ (\gm -> submit st (gmGroup gm, toLower $ gmEmail gm)- ) (groupMember df)-- refreshGroupPrivileges c $ \st ->- mapM_ (\gp -> submit st (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp)- ) (groupPrivilege df)-- refreshPrivilegeRule c $ \st ->- mapM_ (\pr -> submit st (toLower $ prDomain pr, prPrivilege pr, prPath pr, prMethod pr)- ) (privilegeRule df)--+ withResource db $ \c ->+ SQLite.withTransaction c $ do+ refreshGroupMembers c $ \st ->+ mapM_+ (\gm -> submit st (gmGroup gm, toLower $ gmEmail gm))+ (groupMember df)+ refreshGroupPrivileges c $ \st ->+ mapM_+ (\gp ->+ submit st (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp))+ (groupPrivilege df)+ refreshPrivilegeRule c $ \st ->+ mapM_+ (\pr ->+ submit+ st+ ( toLower $ prDomain pr+ , prPrivilege pr+ , prPath pr+ , prMethod pr))+ (privilegeRule df) populate db (Just (PostgreSQL connstr)) =- void . forkIO . forever . flip finally (7 `minutes` threadDelay)- . logException $ do+ void .+ forkIO . forever . flip finally (7 `minutes` threadDelay) . logException $ do Log.info $ "db: synchronizing with " ++ show connstr- withResource db $ \c -> SQLite.withTransaction c $- bracket (PG.connectPostgreSQL $ pack connstr) PG.close $- \pg -> PG.withTransaction pg $ do-+ withResource db $ \c ->+ SQLite.withTransaction c $+ bracket (PG.connectPostgreSQL $ pack connstr) PG.close $ \pg ->+ PG.withTransaction pg $ do Log.info "db: syncing group_member" refreshGroupMembers c $ \st ->- PG.forEach_ pg- [q|SELECT "group", lower(email) FROM group_member|] $ \r ->- submit st (r :: (Text, Text))+ PG.forEach_ pg [q|SELECT "group", lower(email) FROM group_member|] $ \r ->+ submit st (r :: (Text, Text)) count c "group_member"- Log.info "db: syncing group_privilege" refreshGroupPrivileges c $ \st ->- PG.forEach_ pg+ PG.forEach_+ pg [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r ->- submit st (r :: (Text, Text, Text))+ submit st (r :: (Text, Text, Text)) count c "group_privilege"- Log.info "db: syncing privilege_rule" refreshPrivilegeRule c $ \st ->- PG.forEach_ pg+ PG.forEach_+ pg [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r ->- submit st (r :: (Text, Text, Text, Text))+ submit st (r :: (Text, Text, Text, Text)) count c "privilege_rule" - -- FIXME short-cut for https://github.com/nurpax/sqlite-simple/issues/50 -- FIXME nextRow is the only way to execute a prepared statement -- FIXME with bound parameters, but we don't expect any results. submit :: SQLite.ToRow values => SQLite.Statement -> values -> IO ()-submit st v = SQLite.withBind st v $ void (SQLite.nextRow st :: IO (Maybe [Int]))-+submit st v =+ SQLite.withBind st v $ void (SQLite.nextRow st :: IO (Maybe [Int])) createGroupMember :: SQLite.Connection -> IO ()-createGroupMember c = SQLite.execute_ c [q|+createGroupMember c =+ SQLite.execute_+ c+ [q| CREATE TABLE IF NOT EXISTS group_member ( "group" TEXT, email TEXT,@@ -175,13 +191,16 @@ refreshGroupMembers c a = do SQLite.execute_ c "DROP TABLE IF EXISTS group_member" createGroupMember c- SQLite.withStatement c+ SQLite.withStatement+ c [q|INSERT INTO group_member("group", email) VALUES (?, ?)|] a - createGroupPrivilege :: SQLite.Connection -> IO ()-createGroupPrivilege c = SQLite.execute_ c [q|+createGroupPrivilege c =+ SQLite.execute_+ c+ [q| CREATE TABLE IF NOT EXISTS group_privilege ( "group" TEXT, domain TEXT,@@ -190,17 +209,21 @@ ) |] -refreshGroupPrivileges :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO ()+refreshGroupPrivileges ::+ SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () refreshGroupPrivileges c a = do SQLite.execute_ c "DROP TABLE IF EXISTS group_privilege" createGroupPrivilege c- SQLite.withStatement c+ SQLite.withStatement+ c [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|] a - createPrivilegeRule :: SQLite.Connection -> IO ()-createPrivilegeRule c = SQLite.execute_ c [q|+createPrivilegeRule c =+ SQLite.execute_+ c+ [q| CREATE TABLE IF NOT EXISTS privilege_rule ( domain TEXT, privilege TEXT,@@ -210,26 +233,24 @@ ) |] -refreshPrivilegeRule :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO ()+refreshPrivilegeRule ::+ SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () refreshPrivilegeRule c a = do SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule" createPrivilegeRule c- SQLite.withStatement c+ SQLite.withStatement+ c [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|] a - count :: SQLite.Connection -> String -> IO () count c table = do- r <- fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|]+ r <-+ fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|] Log.info $ "db: " ++ table ++ " rows: " ++ show (head r :: Integer) - logException :: IO () -> IO ()-logException a = catch a $ \e ->- Log.error $ "db: " ++ show (e :: SomeException)-+logException a = catch a $ \e -> Log.error $ "db: " ++ show (e :: SomeException) minutes :: Int -> (Int -> IO ()) -> IO () minutes us f = f $ us * 60 * 1000000-
src/Sproxy/Server/DB/DataFile.hs view
@@ -1,69 +1,58 @@ {-# LANGUAGE OverloadedStrings #-}-module Sproxy.Server.DB.DataFile (- DataFile(..)-, GroupMember(..)-, GroupPrivilege(..)-, PrivilegeRule(..)-) where +module Sproxy.Server.DB.DataFile+ ( DataFile(..)+ , GroupMember(..)+ , GroupPrivilege(..)+ , PrivilegeRule(..)+ ) where+ import Control.Applicative (empty) import Data.Aeson (FromJSON, parseJSON) import Data.Text (Text) import Data.Yaml (Value(Object), (.:)) --data DataFile = DataFile {- groupMember :: [GroupMember]-, groupPrivilege :: [GroupPrivilege]-, privilegeRule :: [PrivilegeRule]-} deriving (Show)+data DataFile = DataFile+ { groupMember :: [GroupMember]+ , groupPrivilege :: [GroupPrivilege]+ , privilegeRule :: [PrivilegeRule]+ } deriving (Show) instance FromJSON DataFile where- parseJSON (Object m) = DataFile <$>- m .: "group_member"- <*> m .: "group_privilege"- <*> m .: "privilege_rule"+ parseJSON (Object m) =+ DataFile <$> m .: "group_member" <*> m .: "group_privilege" <*>+ m .: "privilege_rule" parseJSON _ = empty --data GroupMember = GroupMember {- gmGroup :: Text-, gmEmail :: Text-} deriving (Show)+data GroupMember = GroupMember+ { gmGroup :: Text+ , gmEmail :: Text+ } deriving (Show) instance FromJSON GroupMember where- parseJSON (Object m) = GroupMember <$>- m .: "group"- <*> m .: "email"+ parseJSON (Object m) = GroupMember <$> m .: "group" <*> m .: "email" parseJSON _ = empty --data GroupPrivilege = GroupPrivilege {- gpGroup :: Text-, gpDomain :: Text-, gpPrivilege :: Text-} deriving (Show)+data GroupPrivilege = GroupPrivilege+ { gpGroup :: Text+ , gpDomain :: Text+ , gpPrivilege :: Text+ } deriving (Show) instance FromJSON GroupPrivilege where- parseJSON (Object m) = GroupPrivilege <$>- m .: "group"- <*> m .: "domain"- <*> m .: "privilege"+ parseJSON (Object m) =+ GroupPrivilege <$> m .: "group" <*> m .: "domain" <*> m .: "privilege" parseJSON _ = empty --data PrivilegeRule = PrivilegeRule {- prDomain :: Text-, prPrivilege :: Text-, prPath :: Text-, prMethod :: Text-} deriving (Show)+data PrivilegeRule = PrivilegeRule+ { prDomain :: Text+ , prPrivilege :: Text+ , prPath :: Text+ , prMethod :: Text+ } deriving (Show) instance FromJSON PrivilegeRule where- parseJSON (Object m) = PrivilegeRule <$>- m .: "domain"- <*> m .: "privilege"- <*> m .: "path"- <*> m .: "method"+ parseJSON (Object m) =+ PrivilegeRule <$> m .: "domain" <*> m .: "privilege" <*> m .: "path" <*>+ m .: "method" parseJSON _ = empty-