From 4a9f329a6ea9bfa03352ca0d9dd1d556b93bec36 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Thu, 27 Oct 2016 22:57:34 +0300 Subject: Initial release (1.90.0) --- src/Sproxy/Server.hs | 190 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 190 insertions(+) create mode 100644 src/Sproxy/Server.hs (limited to 'src/Sproxy/Server.hs') diff --git a/src/Sproxy/Server.hs b/src/Sproxy/Server.hs new file mode 100644 index 0000000..bd2af17 --- /dev/null +++ b/src/Sproxy/Server.hs @@ -0,0 +1,190 @@ +module Sproxy.Server ( + server +) where + +import Control.Concurrent (forkIO) +import Control.Exception (bracketOnError) +import Control.Monad (void, when) +import Data.ByteString as BS (hGetLine, readFile) +import Data.ByteString.Char8 (pack) +import Data.HashMap.Strict as HM (fromList, lookup, toList) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Word (Word16) +import Data.Yaml (decodeFileEither) +import Network.HTTP.Client (Manager, ManagerSettings(..), defaultManagerSettings, newManager, socketConnection) +import Network.HTTP.Client.Internal (Connection) +import Network.Socket ( Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix), + SocketOption(ReuseAddr), SocketType(Stream), bind, close, connect, inet_addr, + listen, maxListenQueue, setSocketOption, socket ) +import Network.Wai.Handler.WarpTLS (tlsSettingsChain, runTLSSocket) +import Network.Wai.Handler.Warp (defaultSettings, setHTTP2Disabled, runSettingsSocket) +import System.Entropy (getEntropy) +import System.Environment (setEnv) +import System.Exit (exitFailure) +import System.FilePath.Glob (compile) +import System.IO (IOMode(ReadMode), hIsEOF, hPutStrLn, stderr, withFile) +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 qualified Sproxy.Application.OAuth2 as OAuth2 +import qualified Sproxy.Logging as Log +import qualified Sproxy.Server.DB as DB + + +server :: FilePath -> IO () +server configFile = do + cf <- readConfigFile configFile + Log.start $ cfLogLevel cf + Log.debug $ show 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 + + 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 + setGroups groupIDs + setGroupID $ userGroupID u + setUserID $ userID u + + case cfPgPassFile cf of + Nothing -> return () + Just f -> do + Log.info $ "pgpassfile: " ++ show f + setEnv "PGPASSFILE" f + + db <- DB.start (cfHome cf) (newDataSource cf) + + key <- maybe + (Log.info "using new random key" >> getEntropy 32) + (\f -> Log.info ("reading key from " ++ f) >> BS.readFile f) + (cfKey cf) + + case maybe80 of + Nothing -> return () + Just sock80 -> do + Log.info "listening on port 80 (HTTP redirect)" + listen sock80 maxListenQueue + void . forkIO $ runSettingsSocket defaultSettings sock80 (redirect $ cfListen cf) + + oauth2clients <- HM.fromList <$> mapM newOAuth2Client (HM.toList (cfOAuth2 cf)) + + backends <- + mapM (\be -> do + m <- newBackendManager be + return (compile $ beName be, be, m) + ) $ cfBackends cf + + let + settings = + (if cfHTTP2 cf then id else setHTTP2Disabled) + defaultSettings + + -- 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 $ "listening on port " ++ show (cfListen cf) ++ " (HTTPS)" + listen sock (max 2048 maxListenQueue) + runTLSSocket + (tlsSettingsChain (cfSslCert cf) (cfSslCertChain cf) (cfSslKey cf)) + settings + sock + (sproxy key db oauth2clients backends) + + +newDataSource :: ConfigFile -> Maybe DB.DataSource +newDataSource cf = + case cfDatabase cf of + Just str -> Just $ DB.PostgreSQL str + Nothing -> Nothing + + +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 + Just provider -> do + Log.info $ "oauth2: adding " ++ show name + client_secret <- withFile secret_file ReadMode $ \h -> do + empty <- hIsEOF h + if empty then do + Log.error $ "oauth2: empty secret file for " + ++ show name ++ ": " ++ show secret_file + return $ pack "" + else BS.hGetLine h + return (name, provider (pack client_id, client_secret)) + where client_id = oa2ClientId cfg + secret_file = oa2ClientSecret cfg + + +newBackendManager :: BackendConf -> IO Manager +newBackendManager be = do + openConn <- + case (beSocket be, bePort be) of + (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 + 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 + } + + +openUnixSocketConnection :: FilePath -> IO Connection +openUnixSocketConnection f = + bracketOnError + (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) + + +readConfigFile :: FilePath -> IO ConfigFile +readConfigFile f = do + r <- decodeFileEither f + case r of + Left e -> do + hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show e + exitFailure + Right cf -> return cf + -- cgit v1.2.3