Merge pull request #144 from hakujin/unix-socket

Add scottySocketT and scottySocket, exposing Warp Unix socket support

Web/Scotty.hs

@@ -7,7 +7,7 @@
 -- the comments on each of these functions for more information.
 module Web.Scotty
     ( -- * scotty-to-WAI
-      scotty, scottyApp, scottyOpts, Options(..)
+      scotty, scottyApp, scottyOpts, scottySocket, Options(..)
       -- * Defining Middleware and Routes
       --
       -- | 'Middleware' and routes are run in the order in which they
@@ -41,6 +41,7 @@ import qualified Data.ByteString as BS
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.Text.Lazy (Text)
 
+import Network (Socket)
 import Network.HTTP.Types (Status, StdMethod)
 import Network.Wai (Application, Middleware, Request, StreamingBody)
 import Network.Wai.Handler.Warp (Port)
@@ -58,6 +59,13 @@ scotty p = Trans.scottyT p id id
 scottyOpts :: Options -> ScottyM () -> IO ()
 scottyOpts opts = Trans.scottyOptsT opts id id
 
+-- | Run a scotty application using the warp server, passing extra options,
+-- and listening on the provided socket. This allows the user to provide, for
+-- example, a Unix named socket, which can be used when reverse HTTP proxying
+-- into your application.
+scottySocket :: Options -> Socket -> ScottyM () -> IO ()
+scottySocket opts sock = Trans.scottySocketT opts sock id id
+
 -- | Turn a scotty application into a WAI 'Application', which can be
 -- run with any WAI handler.
 scottyApp :: ScottyM () -> IO Application

Web/Scotty/Trans.hs

@@ -11,7 +11,7 @@
 -- the comments on each of these functions for more information.
 module Web.Scotty.Trans
     ( -- * scotty-to-WAI
-      scottyT, scottyAppT, scottyOptsT, Options(..)
+      scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..)
       -- * Defining Middleware and Routes
       --
       -- | 'Middleware' and routes are run in the order in which they
@@ -47,13 +47,15 @@ import Control.Monad.IO.Class
 
 import Data.Default (def)
 
+import Network (Socket)
 import Network.HTTP.Types (status404, status500)
 import Network.Wai
-import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort)
+import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort)
 
 import Web.Scotty.Action
 import Web.Scotty.Route
 import Web.Scotty.Internal.Types hiding (Application, Middleware)
+import Web.Scotty.Util (socketDescription)
 import qualified Web.Scotty.Internal.Types as Scotty
 
 -- | Run a scotty application using the warp server.
@@ -79,6 +81,22 @@ scottyOptsT opts runM runActionToIO s = do
         liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)"
     liftIO . runSettings (settings opts) =<< scottyAppT runM runActionToIO s
 
+-- | Run a scotty application using the warp server, passing extra options, and
+-- listening on the provided socket.
+-- NB: scottySocket opts sock === scottySocketT opts sock id id
+scottySocketT :: (Monad m, MonadIO n)
+              => Options
+              -> Socket
+              -> (forall a. m a -> n a)
+              -> (m Response -> IO Response)
+              -> ScottyT e m ()
+              -> n ()
+scottySocketT opts sock runM runActionToIO s = do
+    when (verbose opts > 0) $ do
+        d <- liftIO $ socketDescription sock
+        liftIO $ putStrLn $ "Setting phasers to stun... (" ++ d ++ ") (ctrl-c to quit)"
+    liftIO . runSettingsSocket (settings opts) sock =<< scottyAppT runM runActionToIO s
+
 -- | Turn a scotty application into a WAI 'Application', which can be
 -- run with any WAI handler.
 -- NB: scottyApp === scottyAppT id id

Web/Scotty/Util.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Web.Scotty.Util
     ( lazyTextToStrictByteString
     , strictByteStringToLazyText
@@ -8,8 +9,11 @@ module Web.Scotty.Util
     , replace
     , add
     , addIfNotPresent
+    , socketDescription
     ) where
 
+import Network (Socket, PortID(..), socketPort)
+import Network.Socket (PortNumber(..))
 import Network.Wai
 
 import Network.HTTP.Types
@@ -59,3 +63,13 @@ addIfNotPresent k v = go
           go l@((x,y):r)
             | x == k    = l
             | otherwise = (x,y) : go r
+
+-- Assemble a description from the Socket's PortID.
+socketDescription :: Socket -> IO String
+socketDescription = fmap d . socketPort
+    where d p = case p of
+                    Service s -> "service " ++ s
+                    PortNumber (PortNum n) -> "port " ++ show n
+#ifndef WINDOWS
+                    UnixSocket u -> "unix socket " ++ u
+#endif

scotty.cabal

@@ -77,6 +77,7 @@ Library
                        http-types       >= 0.8.2    && < 0.9,
                        mtl              >= 2.1.2    && < 2.3,
                        monad-control    >= 1.0.0.0  && < 1.1,
+                       network          >= 2.6.0.2  && < 2.7,
                        regex-compat     >= 0.95.1   && < 0.96,
                        text             >= 0.11.3.1 && < 1.3,
                        transformers     >= 0.3.0.0  && < 0.5,
@@ -92,16 +93,19 @@ test-suite spec
   type:                exitcode-stdio-1.0
   default-language:    Haskell2010
   hs-source-dirs:      test
-  build-depends:       base,
-                       bytestring,
-                       text,
-                       http-types,
-                       lifted-base,
-                       wai,
+  build-depends:       async,
+                       base,
+                       data-default,
+                       directory,
                        hspec == 2.*,
                        hspec-wai >= 0.5,
-                       scotty
-  GHC-options:         -Wall -fno-warn-orphans
+                       http-types,
+                       lifted-base,
+                       network,
+                       scotty,
+                       text,
+                       wai
+  GHC-options:         -Wall -threaded -fno-warn-orphans
 
 source-repository head
   type:     git

test/Web/ScottySpec.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, CPP #-}
 module Web.ScottySpec (main, spec) where
 
 import           Test.Hspec
@@ -15,6 +15,14 @@ import qualified Control.Exception as E
 import           Web.Scotty as Scotty hiding (get, post, put, patch, delete, request)
 import qualified Web.Scotty as Scotty
 
+#ifndef WINDOWS
+import           Control.Concurrent.Async (withAsync)
+import           Data.Default (def)
+import           Network (listenOn, PortID(..))
+import           Network.Socket
+import           System.Directory (removeFile)
+#endif
+
 main :: IO ()
 main = hspec spec
 
@@ -127,3 +135,29 @@ spec = do
       withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> json (Just (5::Int))) $ do
         it "doesn't override a previously set Content-Type header" $ do
           get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]}
+
+-- Unix sockets not available on Windows
+#ifndef WINDOWS
+  describe "scottySocket" .
+    it "works with a unix socket" .
+      withServer (Scotty.get "/scotty" $ html "") .
+        E.bracket (socket AF_UNIX Stream 0) close $ \sock -> do
+          connect sock $ SockAddrUnix socketPath
+          _ <- send sock "GET /scotty HTTP/1.1\r\n\n"
+          r1 <- recv sock 1024
+          _ <- send sock "GET /four-oh-four HTTP/1.1\r\n\n"
+          r2 <- recv sock 1024
+          (take (length ok) r1, take (length no) r2) `shouldBe` (ok, no)
+  where ok = "HTTP/1.1 200 OK"
+        no = "HTTP/1.1 404 Not Found"
+
+socketPath :: FilePath
+socketPath = "/tmp/scotty-test.socket"
+
+withServer :: ScottyM () -> IO a -> IO a
+withServer actions inner = E.bracket
+  (listenOn $ UnixSocket socketPath)
+  (\sock -> close sock >> removeFile socketPath)
+  (\sock -> withAsync (Scotty.scottySocket def sock actions) $ const inner)
+#endif
+