Allow serving over UNIX domain socket

Author: bgamari

hoogle.cabal

@@ -74,6 +74,7 @@ library
         js-flot,
         js-jquery,
         mmap,
+        network,
         process-extras,
         resourcet,
         safe >= 0.3.20,
@@ -85,6 +86,7 @@ library
         time >= 1.5,
         tls,
         transformers,
+        streaming-commons,
         uniplate,
         utf8-string >= 0.3.1,
         vector,

src/Action/CmdLine.hs

@@ -11,6 +11,9 @@ module Action.CmdLine(
     ServerOpts(..),
     ReplayOpts(..),
     TestOpts(..),
+    -- * Endpoints
+    ServerEndpoint(..),
+    showEndpoint,
     -- * Parsing command line
     getCmdLine, defaultDatabaseLang,
     -- * Verbosity
@@ -67,7 +70,7 @@ data GenerateOpts
 
 data ServerOpts
     = ServerOpts
-        { port :: Int
+        { endpoint :: ServerEndpoint
         , database :: FilePath
         , cdn :: String
         , logs :: FilePath
@@ -76,7 +79,6 @@ data ServerOpts
         , links :: Bool
         , scope :: String
         , home :: String
-        , host :: String
         , https :: Bool
         , cert :: FilePath
         , key :: FilePath
@@ -106,6 +108,14 @@ data Mode
     | Replay ReplayOpts
     | Test TestOpts
 
+data ServerEndpoint
+    = UnixSocket FilePath
+    | TcpSocket String Int
+
+showEndpoint :: ServerEndpoint -> String
+showEndpoint (TcpSocket host port) = "port " <> show port <> " on host " <> host
+showEndpoint (UnixSocket sock) = "socket " <> sock
+
 defaultDatabaseLang :: IO FilePath
 defaultDatabaseLang = do
     xdgLocation <- getXdgDirectory XdgData "hoogle"
@@ -212,9 +222,20 @@ generateOpts = do
     debug <- switch (long "debug" <> help "Generate debug information")
     return $ GenerateOpts {..}
 
+unixEndpoint :: Parser ServerEndpoint
+unixEndpoint =
+    UnixSocket <$> option str (long "socket" <> metavar "PATH" <> help "UNIX socket")
+
+tcpEndpoint :: Parser ServerEndpoint
+tcpEndpoint =
+    TcpSocket <$> host <*> port
+  where
+    host = option str (long "host" <> value "*" <> help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host).")
+    port = option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number")
+
 serverOpts :: Parser ServerOpts
 serverOpts = do
-    port <- option auto (long "port" <> short 'p' <> value 8080 <> metavar "PORT" <> help "Port number")
+    endpoint <- unixEndpoint <|> tcpEndpoint
     database <- databaseFlag
     cdn <- option str (value "" <> metavar "URL" <> help "URL prefix to use")
     logs <- logsFlag
@@ -223,7 +244,6 @@ serverOpts = do
     scope <- scopeFlag
     links <- switch (long "links" <> help "Display extra links")
     home <- option str (long "home" <> value "https://hoogle.haskell.org" <> metavar "URL" <> help "Set the URL linked to by the Hoogle logo.")
-    host <- option str (long "host" <> value "" <> help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host).")
     https <- switch (long "https" <> help "Start an https server (use --cert and --key to specify paths to the .pem files)")
     cert <- option str (value "cert.pem" <> metavar "FILE" <> help "Path to the certificate pem file (when running an https server)")
     key <- option str (long "key" <> short 'k' <> value "key.pem" <> metavar "FILE" <> help "Path to the key pem file (when running an https server)")

src/Action/Server.hs

@@ -54,7 +54,7 @@ actionServer verbosity cmd@ServerOpts{..} = do
     -- so I can get good error messages
     hSetBuffering stdout LineBuffering
     hSetBuffering stderr LineBuffering
-    putStrLn $ "Server started on port " ++ show port
+    putStrLn $ "Server started on " ++ showEndpoint endpoint
     putStr "Reading log..." >> hFlush stdout
     time <- offsetTime
     log <- logCreate (if logs == "" then Left stdout else Right logs) $

src/General/Web.hs

@@ -1,17 +1,20 @@
 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards, DeriveFunctor #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module General.Web(
     Input(..),
     Output(..), readInput, server, general_web_test
     ) where
 
+import Data.Streaming.Network (bindPath, bindPortTCP)
 import Network.Wai.Handler.Warp hiding (Port, Handle)
 import Network.Wai.Handler.WarpTLS
 
 import Action.CmdLine
 import Network.Wai.Logger
 import Network.Wai
 import Control.DeepSeq
+import Network.Socket (Socket, close)
 import Network.HTTP.Types (parseQuery, decodePathSegments)
 import Network.HTTP.Types.Status
 import qualified Data.Text as Text
@@ -81,25 +84,37 @@ forceBS (OutputFile x) = rnf x `seq` LBS.empty
 instance NFData Output where
     rnf x = forceBS x `seq` ()
 
+runServer
+    :: ServerOpts
+    -> Application
+    -> IO ()
+runServer opts app =
+    withEndpointSocket (local opts) (endpoint opts) $ \sock ->
+        if https opts
+           then runTLSSocket (tlsSettings (cert opts) (key opts)) settings sock app
+           else runSettingsSocket settings sock app
+  where
+    settings = setOnExceptionResponse exceptionResponseForDebug defaultSettings
+
+withEndpointSocket
+    :: Bool   -- ^ local
+    -> ServerEndpoint
+    -> (Socket -> IO a)
+    -> IO a
+withEndpointSocket _ (UnixSocket sock) =
+    bracket (bindPath sock) close
+withEndpointSocket local (TcpSocket host port) =
+    bracket (bindPortTCP port host') close
+  where
+    host' = fromString $
+      if | "" <- host
+         , local -> "127.0.0.1"
+         | "" <- host -> "*"
+         | otherwise -> host
+
 server :: Log -> ServerOpts -> (Input -> IO Output) -> IO ()
-server log ServerOpts{..} act = do
-    let
-        host' = fromString $
-                  if host == "" then
-                    if local then
-                      "127.0.0.1"
-                    else
-                      "*"
-                  else
-                    host
-        set = setOnExceptionResponse exceptionResponseForDebug
-            . setHost host'
-            . setPort port $
-            defaultSettings
-        runServer :: Application -> IO ()
-        runServer = if https then runTLS (tlsSettings cert key) set
-                             else runSettings set
-        secH = if no_security_headers then []
+server log opts@ServerOpts{..} act = do
+    let secH = if no_security_headers then []
                                       else [
              -- The CSP is giving additional instructions to the browser.
              ("Content-Security-Policy",
@@ -163,9 +178,9 @@ server log ServerOpts{..} act = do
              -- call happens.
              ("Strict-Transport-Security", "max-age=31536000; includeSubDomains")]
 
-    logAddMessage log $ "Server starting on port " ++ show port ++ " and host/IP " ++ show host'
+    logAddMessage log $ "Server starting on " <> showEndpoint endpoint
 
-    runServer $ \req reply -> do
+    runServer opts $ \req reply -> do
         let pq = BS.unpack $ rawPathInfo req <> rawQueryString req
         putStrLn pq
         (time, res) <- duration $ case readInput pq of