{-# LANGUAGE CPP, OverloadedStrings, UnicodeSyntax #-}

module Network.Wai.Cli where

import qualified Network.Wai.Handler.CGI as CGI
import           Network.Wai.Handler.Warp hiding (run)
#ifdef WaiCliTLS
import           Network.Wai.Handler.WarpTLS
#endif
#ifdef WaiCliFastCGI
import qualified Network.Wai.Handler.FastCGI as FCGI
#endif
import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
#ifdef WaiCliUnix
import           Network.Wai (responseLBS, Application)
import           Network.HTTP.Types (serviceUnavailable503)
import           System.Posix.Env
import           System.Posix.Process
import           Foreign.C.Types(CInt(..))
import           System.Posix.Internals (setNonBlockingFD)
import           System.Posix.Signals (installHandler, sigTERM, Handler(CatchOnce))
import           Data.Streaming.Network (bindPath, bindPortTCP)
import           Control.Monad
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Class
import           Control.Monad.Trans (liftIO)
import           Control.Concurrent.STM
import           GHC.Conc (getNumCapabilities, forkIO)
#else
import           Network.Wai (Application)
import           Data.Streaming.Network (bindPortTCP)
import           GHC.Conc (getNumCapabilities)
#endif
import qualified Network.Socket as S
import           System.Console.ANSI
import           Control.Exception (bracket)
import           Options
import           Data.List (intercalate)
import           Data.String (fromString)
import           Data.IP (fromHostAddress, fromHostAddress6)

data GracefulMode = ServeNormally | Serve503

data WaiOptions = WaiOptions
  { WaiOptions -> Int
wHttpPort                ∷ Int
  , WaiOptions -> String
wHttpHost                ∷ String
#ifdef WaiCliUnix
  , WaiOptions -> String
wUnixSock                ∷ String
#endif
  , WaiOptions -> String
wProtocol                ∷ String
#ifdef WaiCliTLS
  , WaiOptions -> String
wTlsKeyFile              ∷ String
  , WaiOptions -> String
wTlsCertFile             ∷ String
#endif
#ifdef WaiCliUnix
  , WaiOptions -> String
wGracefulMode            ∷ String
#endif
  , WaiOptions -> Maybe Bool
wDevlogging              ∷ Maybe Bool }

instance Options WaiOptions where
  defineOptions :: DefineOptions WaiOptions
defineOptions = (Int
 -> String
 -> String
 -> String
 -> String
 -> String
 -> String
 -> Maybe Bool
 -> WaiOptions)
-> DefineOptions
     (Int
      -> String
      -> String
      -> String
      -> String
      -> String
      -> String
      -> Maybe Bool
      -> WaiOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
-> String
-> String
-> String
-> String
-> String
-> String
-> Maybe Bool
-> WaiOptions
WaiOptions
    DefineOptions
  (Int
   -> String
   -> String
   -> String
   -> String
   -> String
   -> String
   -> Maybe Bool
   -> WaiOptions)
-> DefineOptions Int
-> DefineOptions
     (String
      -> String
      -> String
      -> String
      -> String
      -> String
      -> Maybe Bool
      -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Int -> String -> DefineOptions Int
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"port"              Int
3000                String
"The port the app should listen for connections on (for http)"
    DefineOptions
  (String
   -> String
   -> String
   -> String
   -> String
   -> String
   -> Maybe Bool
   -> WaiOptions)
-> DefineOptions String
-> DefineOptions
     (String
      -> String
      -> String
      -> String
      -> String
      -> Maybe Bool
      -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"host"              String
"*4"                String
"Host preference (for http)"
#ifdef WaiCliUnix
    DefineOptions
  (String
   -> String
   -> String
   -> String
   -> String
   -> Maybe Bool
   -> WaiOptions)
-> DefineOptions String
-> DefineOptions
     (String -> String -> String -> String -> Maybe Bool -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"socket"            String
"wai.sock"          String
"The UNIX domain socket path the app should listen for connections on (for unix)"
#endif
    DefineOptions
  (String -> String -> String -> String -> Maybe Bool -> WaiOptions)
-> DefineOptions String
-> DefineOptions
     (String -> String -> String -> Maybe Bool -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"protocol"          String
"http"              (String
"The protocol for the server. One of: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
availableProtocols)
#ifdef WaiCliTLS
    DefineOptions
  (String -> String -> String -> Maybe Bool -> WaiOptions)
-> DefineOptions String
-> DefineOptions (String -> String -> Maybe Bool -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"tlskey"            String
""                  String
"Path to the TLS private key file for +tls protocols"
    DefineOptions (String -> String -> Maybe Bool -> WaiOptions)
-> DefineOptions String
-> DefineOptions (String -> Maybe Bool -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"tlscert"           String
""                  String
"Path to the TLS certificate bundle file for +tls protocols"
#endif
#ifdef WaiCliUnix
    DefineOptions (String -> Maybe Bool -> WaiOptions)
-> DefineOptions String -> DefineOptions (Maybe Bool -> WaiOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> String -> DefineOptions String
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"graceful"          String
"serve-normally"    String
"Graceful shutdown mode. One of: none, serve-normally, serve-503"
#endif
    DefineOptions (Maybe Bool -> WaiOptions)
-> DefineOptions (Maybe Bool) -> DefineOptions WaiOptions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Bool -> String -> DefineOptions (Maybe Bool)
forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
"devlogging"        Maybe Bool
forall a. Maybe a
Nothing             String
"Whether development logging should be enabled"
    where
      availableProtocols :: String
availableProtocols = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [
          String
"http", String
"cgi"
#ifdef WaiCliUnix
        , String
"unix", String
"activate"
#endif
#ifdef WaiCliTLS
        , String
"http+tls"
#endif
#if defined(WaiCliTLS) && defined(WaiCliUnix)
        , String
"unix+tls", String
"activate+tls"
#endif
#ifdef WaiCliFastCGI
        , "fastcgi"
#endif
        ]


#ifdef WaiCliUnix

fdStart ∷ CInt
fdStart :: CInt
fdStart = CInt
3

getActivatedSockets ∷ IO (Maybe [S.Socket])
getActivatedSockets :: IO (Maybe [Socket])
getActivatedSockets = MaybeT IO [Socket] -> IO (Maybe [Socket])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Socket] -> IO (Maybe [Socket]))
-> MaybeT IO [Socket] -> IO (Maybe [Socket])
forall a b. (a -> b) -> a -> b
$ do
    ProcessID
listenPid ← String -> ProcessID
forall a. Read a => String -> a
read (String -> ProcessID) -> MaybeT IO String -> MaybeT IO ProcessID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
getEnv String
"LISTEN_PID")
    CInt
listenFDs ← String -> CInt
forall a. Read a => String -> a
read (String -> CInt) -> MaybeT IO String -> MaybeT IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
getEnv String
"LISTEN_FDS")
    ProcessID
myPid     ← IO ProcessID -> MaybeT IO ProcessID
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ProcessID
getProcessID
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ ProcessID
listenPid ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessID
myPid
    (CInt -> MaybeT IO Socket) -> [CInt] -> MaybeT IO [Socket]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO Socket -> MaybeT IO Socket
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Socket -> MaybeT IO Socket)
-> (CInt -> IO Socket) -> CInt -> MaybeT IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> IO Socket
S.mkSocket) [CInt
fdStart .. CInt
fdStart CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
listenFDs CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- CInt
1]

runActivated ∷ (Settings → S.Socket → Application → IO ()) → Settings → Application → IO ()
runActivated :: (Settings -> Socket -> Application -> IO ())
-> Settings -> Application -> IO ()
runActivated Settings -> Socket -> Application -> IO ()
run Settings
warps Application
app = do
  Maybe [Socket]
sockets ← IO (Maybe [Socket])
getActivatedSockets
  case Maybe [Socket]
sockets of
    Just [Socket]
socks →
      IO [ThreadId] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [ThreadId] -> IO ()) -> IO [ThreadId] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Socket] -> (Socket -> IO ThreadId) -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Socket]
socks ((Socket -> IO ThreadId) -> IO [ThreadId])
-> (Socket -> IO ThreadId) -> IO [ThreadId]
forall a b. (a -> b) -> a -> b
$ \Socket
sock → do
        Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
S.withFdSocket Socket
sock ((CInt -> IO ()) -> IO ()) -> (CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
sfd →
          CInt -> Bool -> IO ()
setNonBlockingFD CInt
sfd Bool
True
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Settings -> Socket -> Application -> IO ()
run Settings
warps Socket
sock Application
app
    Maybe [Socket]
Nothing → String -> IO ()
putStrLn String
"No sockets to activate"


runGraceful ∷ GracefulMode → (Settings → Application → IO ()) → Settings → Application → IO ()
runGraceful :: GracefulMode
-> (Settings -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runGraceful GracefulMode
mode Settings -> Application -> IO ()
run Settings
warps Application
app = do
  -- based on https://gist.github.com/NathanHowell/5435345
  -- XXX: an option to stop accepting (need change stuff inside Warp?)
  TMVar ()
shutdown ← IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO
  TVar Int
activeConnections ← Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO (Int
0 ∷ Int)
  Handler
_ ← CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sigTERM (IO () -> Handler
CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
shutdown ()) Maybe SignalSet
forall a. Maybe a
Nothing
  let warps' :: Settings
warps' = (SockAddr -> IO Bool) -> Settings -> Settings
setOnOpen  (\SockAddr
_ → STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
activeConnections (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
               (SockAddr -> IO ()) -> Settings -> Settings
setOnClose (\SockAddr
_ → STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
activeConnections (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Settings
warps
  let app' :: Application
app' = case GracefulMode
mode of
        GracefulMode
ServeNormally → Application
app
        GracefulMode
Serve503 → \Request
req Response -> IO ResponseReceived
respond → do
          Bool
shouldRun ← IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool)
-> (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar ()
shutdown
          if Bool
shouldRun then Application
app Request
req Response -> IO ResponseReceived
respond else Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
serviceUnavailable503 [] ByteString
""
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Settings -> Application -> IO ()
run Settings
warps' Application
app'
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
shutdown
    Int
conns ← TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
activeConnections
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
conns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) STM ()
forall a. STM a
retry
#endif

-- | Adjusts 'WaiOptions' with an address assigned to a newly created
-- server socket, uses those to set a "before main loop" function in
-- Warp 'Settings', which are then used to run an application.
runWarp ∷ (WaiOptions → IO ())
        -- ^ A "before main loop" function
        → WaiOptions
        -- ^ Original options
        → (Settings → S.Socket → Application → IO ())
        -- ^ A function such as 'runSettingsSocket'
        → Settings → Application → IO ()
runWarp :: (WaiOptions -> IO ())
-> WaiOptions
-> (Settings -> Socket -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runWarp WaiOptions -> IO ()
putListening WaiOptions
opts Settings -> Socket -> Application -> IO ()
runSocket Settings
set Application
app = IO () -> IO ()
forall a. IO a -> IO a
S.withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
getPort Settings
set) (Settings -> HostPreference
getHost Settings
set)) Socket -> IO ()
S.close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
s → do
  SockAddr
sa ← Socket -> IO SockAddr
S.getSocketName Socket
s
  Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
S.withFdSocket Socket
s CInt -> IO ()
S.setCloseOnExecIfNeeded
  Settings -> Socket -> Application -> IO ()
runSocket (IO () -> Settings -> Settings
setBeforeMainLoop (WaiOptions -> IO ()
putListening (WaiOptions -> IO ()) -> WaiOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> WaiOptions -> WaiOptions
updateOptions SockAddr
sa WaiOptions
opts) Settings
set) Socket
s Application
app
  where
    updateOptions ∷ S.SockAddr → WaiOptions → WaiOptions
    updateOptions :: SockAddr -> WaiOptions -> WaiOptions
updateOptions (S.SockAddrInet PortNumber
pn HostAddress
ha) WaiOptions
opt =
      WaiOptions
opt { wHttpPort :: Int
wHttpPort = PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
pn, wHttpHost :: String
wHttpHost = IPv4 -> String
forall a. Show a => a -> String
show (HostAddress -> IPv4
fromHostAddress HostAddress
ha) }
    updateOptions (S.SockAddrInet6 PortNumber
pn HostAddress
_flow HostAddress6
ha HostAddress
_scope) WaiOptions
opt =
      WaiOptions
opt { wHttpPort :: Int
wHttpPort = PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
pn, wHttpHost :: String
wHttpHost = IPv6 -> String
forall a. Show a => a -> String
show (HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
ha) }
    updateOptions SockAddr
_ WaiOptions
opt = WaiOptions
opt

waiMain ∷ (WaiOptions → IO ()) → (WaiOptions → IO ()) → Application → IO ()
waiMain :: (WaiOptions -> IO ())
-> (WaiOptions -> IO ()) -> Application -> IO ()
waiMain WaiOptions -> IO ()
putListening WaiOptions -> IO ()
putWelcome Application
app = (WaiOptions -> [String] -> IO ()) -> IO ()
forall (m :: * -> *) opts a.
(MonadIO m, Options opts) =>
(opts -> [String] -> m a) -> m a
runCommand ((WaiOptions -> [String] -> IO ()) -> IO ())
-> (WaiOptions -> [String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WaiOptions
opts [String]
_ → do
#ifdef WaiCliTLS
  let tlss :: TLSSettings
tlss = String -> String -> TLSSettings
tlsSettings (WaiOptions -> String
wTlsCertFile WaiOptions
opts) (WaiOptions -> String
wTlsKeyFile WaiOptions
opts)
#endif
  let warps :: Settings
warps = IO () -> Settings -> Settings
setBeforeMainLoop (WaiOptions -> IO ()
putListening WaiOptions
opts) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Int -> Settings -> Settings
setPort (WaiOptions -> Int
wHttpPort WaiOptions
opts) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
              HostPreference -> Settings -> Settings
setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString (String -> HostPreference) -> String -> HostPreference
forall a b. (a -> b) -> a -> b
$ WaiOptions -> String
wHttpHost WaiOptions
opts) Settings
defaultSettings
  let app' :: Application
app' = if WaiOptions -> Maybe Bool
wDevlogging WaiOptions
opts Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True then Middleware
logStdoutDev Application
app else Application
app
  case WaiOptions -> String
wProtocol WaiOptions
opts of
     String
"cgi" → Application -> IO ()
CGI.run Application
app'
#ifdef WaiCliFastCGI
     "fastcgi" → FCGI.run app'
#endif
     String
_ → do
       let run :: Settings -> Application -> IO ()
run = case WaiOptions -> String
wProtocol WaiOptions
opts of
             String
"http" → (WaiOptions -> IO ())
-> WaiOptions
-> (Settings -> Socket -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runWarp WaiOptions -> IO ()
putListening WaiOptions
opts Settings -> Socket -> Application -> IO ()
runSettingsSocket
#ifdef WaiCliUnix
             String
"unix" → \Settings
warps' Application
app'' → IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Socket
bindPath (String -> IO Socket) -> String -> IO Socket
forall a b. (a -> b) -> a -> b
$ WaiOptions -> String
wUnixSock WaiOptions
opts) Socket -> IO ()
S.close (\Socket
sock → Settings -> Socket -> Application -> IO ()
runSettingsSocket Settings
warps' Socket
sock Application
app'')
             String
"activate" → (Settings -> Socket -> Application -> IO ())
-> Settings -> Application -> IO ()
runActivated Settings -> Socket -> Application -> IO ()
runSettingsSocket
#endif
#ifdef WaiCliTLS
             String
"http+tls" → (WaiOptions -> IO ())
-> WaiOptions
-> (Settings -> Socket -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runWarp WaiOptions -> IO ()
putListening WaiOptions
opts (TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket TLSSettings
tlss)
#ifdef WaiCliUnix
             String
"unix+tls" → \Settings
warps' Application
app'' → IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Socket
bindPath (String -> IO Socket) -> String -> IO Socket
forall a b. (a -> b) -> a -> b
$ WaiOptions -> String
wUnixSock WaiOptions
opts) Socket -> IO ()
S.close (\Socket
sock → TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket TLSSettings
tlss Settings
warps' Socket
sock Application
app'')
             String
"activate+tls" → (Settings -> Socket -> Application -> IO ())
-> Settings -> Application -> IO ()
runActivated (TLSSettings -> Settings -> Socket -> Application -> IO ()
runTLSSocket TLSSettings
tlss)
#endif
#endif
             String
x → \Settings
_ Application
_ → String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported protocol: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
       WaiOptions -> IO ()
putWelcome WaiOptions
opts
#ifdef WaiCliUnix
       case WaiOptions -> String
wGracefulMode WaiOptions
opts of
             String
"none" → Settings -> Application -> IO ()
run Settings
warps Application
app'
             String
"serve-normally" → GracefulMode
-> (Settings -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runGraceful GracefulMode
ServeNormally Settings -> Application -> IO ()
run Settings
warps Application
app'
             String
"serve-503" → GracefulMode
-> (Settings -> Application -> IO ())
-> Settings
-> Application
-> IO ()
runGraceful GracefulMode
Serve503 Settings -> Application -> IO ()
run Settings
warps Application
app'
             String
x  → String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported graceful mode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
#else
       run warps app'
#endif

defPutListening ∷ WaiOptions → IO ()
defPutListening :: WaiOptions -> IO ()
defPutListening WaiOptions
opts = IO Int
getNumCapabilities IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
forall a. Show a => a -> IO ()
putMain
  where putMain :: a -> IO ()
putMain a
cpus = String -> IO ()
reset String
"Running on " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
blue (WaiOptions -> String
wProtocol WaiOptions
opts) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
putProto IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
reset String
" with " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
green (a -> String
forall a. Show a => a -> String
show a
cpus String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" CPUs") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
setReset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""
        putProto :: IO ()
putProto = case WaiOptions -> String
wProtocol WaiOptions
opts of
                     String
"http" → String -> IO ()
reset String
" host " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
boldMagenta (WaiOptions -> String
wHttpHost WaiOptions
opts)
                              IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
reset String
", port " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
boldMagenta (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ WaiOptions -> Int
wHttpPort WaiOptions
opts)
#ifdef WaiCliUnix
                     String
"unix" → String -> IO ()
reset String
" socket " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
boldMagenta (String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ WaiOptions -> String
wUnixSock WaiOptions
opts)
                     String
"activate" → String -> IO ()
reset String
" activated socket"
#endif
#ifdef WaiCliTLS
                     String
"http+tls" → String -> IO ()
reset String
" (TLS) port "   IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
boldMagenta (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ WaiOptions -> Int
wHttpPort WaiOptions
opts)
#ifdef WaiCliUnix
                     String
"unix+tls" → String -> IO ()
reset String
" (TLS) socket " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
boldMagenta (String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ WaiOptions -> String
wUnixSock WaiOptions
opts)
                     String
"activate+tls" → String -> IO ()
reset String
" (TLS) activated socket"
#endif
#endif
                     String
_      → IO ()
setReset
        setReset :: IO ()
setReset = [SGR] -> IO ()
setSGR [ SGR
Reset ]
        boldMagenta :: String -> IO ()
boldMagenta String
x = IO ()
setReset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> IO ()
setSGR [ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity, ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Magenta ] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStr String
x
        green :: String -> IO ()
green String
x = IO ()
setReset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> IO ()
setSGR [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green ] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStr String
x
        blue :: String -> IO ()
blue  String
x = IO ()
setReset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SGR] -> IO ()
setSGR [ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Blue ] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStr String
x
        reset :: String -> IO ()
reset String
x = IO ()
setReset IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStr String
x

defWaiMain ∷ Application → IO ()
defWaiMain :: Application -> IO ()
defWaiMain = (WaiOptions -> IO ())
-> (WaiOptions -> IO ()) -> Application -> IO ()
waiMain WaiOptions -> IO ()
defPutListening (\WaiOptions
_ → () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())