{-# LANGUAGE Rank2Types #-}
module Network.MoHWS.Server (main, mainWithOptions, ) where
import qualified Network.MoHWS.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Environment as ServerEnv
import qualified Network.MoHWS.Server.Context as ServerContext
import Network.MoHWS.Logger.Error (debug, logError, logInfo, )
import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Logger.Access as AccessLogger
import qualified Network.MoHWS.Logger.Error as ErrorLogger
import qualified Network.MoHWS.Configuration.Parser as ConfigParser
import Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.Initialization as Init
import qualified Network.MoHWS.HTTP.MimeType as MimeType
import qualified Network.MoHWS.Server.Options as Options
import Network.MoHWS.ParserUtility (getUntilEmptyLine, )
import qualified Network.MoHWS.HTTP.Version as Version
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Request as Request
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Stream as Stream
import qualified Network.MoHWS.Utility as Util
import Data.Monoid (mempty, )
import Data.Maybe (catMaybes, )
import Data.Tuple.HT (swap, )
import Data.List.HT (viewR, )
import qualified Data.Set as Set
import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Exception as Exception
import Control.Monad.Exception.Synchronous (ExceptionalT, runExceptionalT, )
import Control.Monad.Trans.State (StateT, runStateT, modify, )
import Control.Monad.Trans.Class (lift, )
import qualified Network.Socket as Socket
import qualified Network.BSD as BSD
import Control.Concurrent (myThreadId, ThreadId, throwTo, killThread, forkIO, )
import Control.Exception (ErrorCall(ErrorCall), finally, mask, )
import Control.Monad (liftM, when, )
import Network.BSD (HostEntry, hostName, )
import Network.Socket (Socket, HostAddress, Family(AF_INET), )
import Network.URI (uriPath, )
import qualified System.Posix as Posix
import qualified System.IO as IO
import System.IO.Error (isAlreadyInUseError, isEOFError, catchIOError, )
import System.Environment (getArgs, )
import System.Posix (installHandler, sigHUP, sigPIPE, )
import Text.ParserCombinators.Parsec (parse, choice, )
main :: (Stream.C body) =>
Init.T body ext -> IO ()
main :: T body ext -> IO ()
main T body ext
initExt =
do [String]
args <- IO [String]
getArgs
case [String] -> Either String T
Options.parse [String]
args of
Left String
err -> String -> IO ()
Util.die String
err
Right T
opts -> T body ext -> T -> IO ()
forall body ext. C body => T body ext -> T -> IO ()
mainWithOptions T body ext
initExt T
opts
mainWithOptions :: (Stream.C body) =>
Init.T body ext -> Options.T -> IO ()
mainWithOptions :: T body ext -> T -> IO ()
mainWithOptions T body ext
initExt T
opts =
do ThreadId
main_thread <- IO ThreadId
myThreadId
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigPIPE Handler
Posix.Ignore Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigHUP (IO () -> Handler
Posix.Catch (ThreadId -> IO ()
hupHandler ThreadId
main_thread)) Maybe SignalSet
forall a. Maybe a
Nothing
((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt T
opts)
type Unblock a = IO a -> IO a
hupHandler :: ThreadId -> IO ()
hupHandler :: ThreadId -> IO ()
hupHandler ThreadId
main_thread =
ThreadId -> ErrorCall -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
main_thread (String -> ErrorCall
ErrorCall String
"**restart**")
sigsToBlock :: Posix.SignalSet
sigsToBlock :: SignalSet
sigsToBlock = Signal -> SignalSet -> SignalSet
Posix.addSignal Signal
sigHUP SignalSet
Posix.emptySignalSet
readConfig :: (Stream.C body) =>
Init.T body ext -> Options.T -> (forall a. Unblock a) -> IO ()
readConfig :: T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt T
opts forall a. IO a -> IO a
unblock = do
SignalSet -> IO ()
Posix.blockSignals SignalSet
sigsToBlock
Either ParseError (Builder ext)
r <- T () ext -> String -> IO (Either ParseError (Builder ext))
forall ext.
T () ext -> String -> IO (Either ParseError (Builder ext))
ConfigParser.run
([T () ext] -> T () ext
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([T () ext] -> T () ext) -> [T () ext] -> T () ext
forall a b. (a -> b) -> a -> b
$ (T body ext -> T () ext) -> [T body ext] -> [T () ext]
forall a b. (a -> b) -> [a] -> [b]
map T body ext -> T () ext
forall body ext. T body ext -> T () ext
ModuleDesc.configParser ([T body ext] -> [T () ext]) -> [T body ext] -> [T () ext]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt)
(T -> String
Options.configPath T
opts)
case Either ParseError (Builder ext)
r of
Left ParseError
err ->
String -> IO ()
Util.die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
String
"Failed to parse configuration file" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ParseError -> String
forall a. Show a => a -> String
show ParseError
err String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []
Right Builder ext
b -> do
let updates :: [ext -> ext]
updates = (T body ext -> ext -> ext) -> [T body ext] -> [ext -> ext]
forall a b. (a -> b) -> [a] -> [b]
map T body ext -> ext -> ext
forall body ext. T body ext -> ext -> ext
ModuleDesc.setDefltConfig ([T body ext] -> [ext -> ext]) -> [T body ext] -> [ext -> ext]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt
confExtDeflt :: ext
confExtDeflt =
(ext -> (ext -> ext) -> ext) -> ext -> [ext -> ext] -> ext
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((ext -> ext) -> ext -> ext) -> ext -> (ext -> ext) -> ext
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ext -> ext) -> ext -> ext
forall a b. (a -> b) -> a -> b
($)) (T body ext -> ext
forall body ext. T body ext -> ext
Init.configurationExtensionDefault T body ext
initExt) [ext -> ext]
updates
conf :: T ext
conf = Builder ext
b (ext -> T ext
forall ext. ext -> T ext
Config.deflt ext
confExtDeflt)
T ext
st <- T -> T ext -> IO (T ext)
forall ext. T -> T ext -> IO (T ext)
initServerState T
opts T ext
conf
[T body]
mods <- ([Maybe (T body)] -> [T body])
-> IO [Maybe (T body)] -> IO [T body]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (T body)] -> [T body]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (T body)] -> IO [T body])
-> IO [Maybe (T body)] -> IO [T body]
forall a b. (a -> b) -> a -> b
$ (T body ext -> IO (Maybe (T body)))
-> [T body ext] -> IO [Maybe (T body)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (T ext -> T body ext -> IO (Maybe (T body))
forall body ext.
C body =>
T ext -> T body ext -> IO (Maybe (T body))
loadModule T ext
st) ([T body ext] -> IO [Maybe (T body)])
-> [T body ext] -> IO [Maybe (T body)]
forall a b. (a -> b) -> a -> b
$ T body ext -> [T body ext]
forall body ext. T body ext -> [T body ext]
Init.moduleList T body ext
initExt
T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
topServer T ext
st [T body]
mods T body ext
initExt forall a. IO a -> IO a
unblock
rereadConfig :: (Stream.C body) =>
ServerContext.T ext -> Init.T body ext -> (forall a. Unblock a) -> IO ()
rereadConfig :: T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
rereadConfig T ext
st T body ext
initExt forall a. IO a -> IO a
unblock =
do (Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
AccessLogger.stop (T ext -> [Handle]
forall ext. T ext -> [Handle]
ServerContext.accessLoggers T ext
st)
Handle -> IO ()
ErrorLogger.stop (T ext -> Handle
forall ext. T ext -> Handle
ServerContext.errorLogger T ext
st)
T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T body ext -> T -> (forall a. IO a -> IO a) -> IO ()
readConfig T body ext
initExt (T ext -> T
forall ext. T ext -> T
ServerContext.options T ext
st) forall a. IO a -> IO a
unblock
initServerState :: Options.T -> Config.T ext -> IO (ServerContext.T ext)
initServerState :: T -> T ext -> IO (T ext)
initServerState T
opts T ext
conf =
do HostEntry
host <- do HostEntry
ent <- IO HostEntry
BSD.getHostEntry
case T ext -> String
forall ext. T ext -> String
serverName T ext
conf of
String
"" -> HostEntry -> IO HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return HostEntry
ent
String
n -> HostEntry -> IO HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return HostEntry
ent { hostName :: String
hostName = String
n }
Dictionary
mimeTypes
<- String -> IO Dictionary
MimeType.loadDictionary (T -> String -> String
Options.inServerRoot T
opts (T ext -> String
forall ext. T ext -> String
typesConfig T ext
conf))
Handle
errorLogger
<- String -> T -> IO Handle
ErrorLogger.start (T -> String -> String
Options.inServerRoot T
opts (T ext -> String
forall ext. T ext -> String
errorLogFile T ext
conf)) (T ext -> T
forall ext. T ext -> T
logLevel T ext
conf)
[Handle]
accessLoggers
<- [IO Handle] -> IO [Handle]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [String -> String -> IO Handle
AccessLogger.start String
format (T -> String -> String
Options.inServerRoot T
opts String
file)
| (String
file,String
format) <- T ext -> [(String, String)]
forall ext. T ext -> [(String, String)]
customLogs T ext
conf]
let st :: T ext
st = Cons :: forall ext.
T
-> T ext -> HostEntry -> Dictionary -> Handle -> [Handle] -> T ext
ServerContext.Cons
{
options :: T
ServerContext.options = T
opts,
config :: T ext
ServerContext.config = T ext
conf,
hostName :: HostEntry
ServerContext.hostName = HostEntry
host,
mimeTypes :: Dictionary
ServerContext.mimeTypes = Dictionary
mimeTypes,
errorLogger :: Handle
ServerContext.errorLogger = Handle
errorLogger,
accessLoggers :: [Handle]
ServerContext.accessLoggers = [Handle]
accessLoggers
}
T ext -> IO (T ext)
forall (m :: * -> *) a. Monad m => a -> m a
return T ext
st
loadModule :: (Stream.C body) =>
ServerContext.T ext -> ModuleDesc.T body ext -> IO (Maybe (Module.T body))
loadModule :: T ext -> T body ext -> IO (Maybe (T body))
loadModule T ext
st T body ext
md =
(do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logInfo T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Loading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body ext -> String
forall body ext. T body ext -> String
ModuleDesc.name T body ext
md String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
(T body -> Maybe (T body)) -> IO (T body) -> IO (Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T body -> Maybe (T body)
forall a. a -> Maybe a
Just (IO (T body) -> IO (Maybe (T body)))
-> IO (T body) -> IO (Maybe (T body))
forall a b. (a -> b) -> a -> b
$ T body ext -> T ext -> IO (T body)
forall body ext. T body ext -> T ext -> IO (T body)
ModuleDesc.load T body ext
md T ext
st)
IO (Maybe (T body))
-> (SomeException -> IO (Maybe (T body))) -> IO (Maybe (T body))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
\(Exception.SomeException e
e) ->
do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Error loading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ T body ext -> String
forall body ext. T body ext -> String
ModuleDesc.name T body ext
md,
e -> String
forall a. Show a => a -> String
show e
e]
Maybe (T body) -> IO (Maybe (T body))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (T body)
forall a. Maybe a
Nothing
topServer :: (Stream.C body) =>
ServerContext.T ext -> [Module.T body] -> Init.T body ext -> (forall a. Unblock a) -> IO ()
topServer :: T ext
-> [T body] -> T body ext -> (forall a. IO a -> IO a) -> IO ()
topServer T ext
st [T body]
mods T body ext
initExt forall a. IO a -> IO a
unblock =
let startServers :: IO ()
startServers =
do [ThreadId]
ts <- T ext -> [T body] -> IO [ThreadId]
forall body ext. C body => T ext -> [T body] -> IO [ThreadId]
servers T ext
st [T body]
mods
(IO ()
forall a. IO a
Util.wait IO () -> (ErrorCall -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
(\ErrorCall
e -> case ErrorCall
e of
ErrorCall String
"**restart**" ->
do (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
ts
T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
forall body ext.
C body =>
T ext -> T body ext -> (forall a. IO a -> IO a) -> IO ()
rereadConfig T ext
st T body ext
initExt forall a. IO a -> IO a
unblock
ErrorCall
_ -> ErrorCall -> IO ()
forall a e. Exception e => e -> a
Exception.throw ErrorCall
e))
loop :: IO ()
loop =
(do SignalSet -> IO ()
Posix.unblockSignals SignalSet
sigsToBlock
Unblock ()
forall a. IO a -> IO a
unblock IO ()
startServers)
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
(\(Exception.SomeException e
e) ->
do T ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T ext
st (String
"server: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
IO ()
loop)
in IO ()
loop
servers :: (Stream.C body) =>
ServerContext.T ext -> [Module.T body] -> IO [ThreadId]
servers :: T ext -> [T body] -> IO [ThreadId]
servers T ext
st [T body]
mods =
let mkEnv :: PortNumber -> T body ext
mkEnv PortNumber
port =
Cons :: forall body ext. T ext -> PortNumber -> [T body] -> T body ext
ServerEnv.Cons {
context :: T ext
ServerEnv.context = T ext
st,
modules :: [T body]
ServerEnv.modules = [T body]
mods,
port :: PortNumber
ServerEnv.port = PortNumber
port
}
mkAddr :: (Maybe String, PortNumber) -> IO (T body ext, SockAddr)
mkAddr (Maybe String
maddr,PortNumber
port) =
do HostAddress
addr <- case Maybe String
maddr of
Maybe String
Nothing -> HostAddress -> IO HostAddress
forall (m :: * -> *) a. Monad m => a -> m a
return HostAddress
Socket.iNADDR_ANY
Just String
ip -> String -> IO HostAddress
Socket.inet_addr String
ip
(T body ext, SockAddr) -> IO (T body ext, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> T body ext
mkEnv PortNumber
port, PortNumber -> HostAddress -> SockAddr
Socket.SockAddrInet PortNumber
port HostAddress
addr)
in do [(T body ext, SockAddr)]
addrs <- ((Maybe String, PortNumber) -> IO (T body ext, SockAddr))
-> [(Maybe String, PortNumber)] -> IO [(T body ext, SockAddr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe String, PortNumber) -> IO (T body ext, SockAddr)
mkAddr (T ext -> [(Maybe String, PortNumber)]
forall ext. T ext -> [(Maybe String, PortNumber)]
listen (T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st))
((T body ext, SockAddr) -> IO ThreadId)
-> [(T body ext, SockAddr)] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (T body ext
env,SockAddr
addr) -> IO () -> IO ThreadId
forkIO (T body ext -> SockAddr -> IO ()
forall body ext. C body => T body ext -> SockAddr -> IO ()
server T body ext
env SockAddr
addr)) [(T body ext, SockAddr)]
addrs
server :: (Stream.C body) =>
ServerEnv.T body ext -> Socket.SockAddr -> IO ()
server :: T body ext -> SockAddr -> IO ()
server T body ext
st SockAddr
addr = do
T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logInfo T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting server thread on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr
Signal
proto <- String -> IO Signal
BSD.getProtocolNumber String
"tcp"
IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(Family -> SocketType -> Signal -> IO Socket
Socket.socket Family
AF_INET SocketType
Socket.Stream Signal
proto)
(\Socket
sock -> Socket -> IO ()
Socket.sClose Socket
sock)
(\Socket
sock -> do Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sock SocketOption
Socket.ReuseAddr Int
1
Bool
ok <- (IOError -> Bool) -> IO Bool -> (IOError -> IO Bool) -> IO Bool
forall a. (IOError -> Bool) -> IO a -> (IOError -> IO a) -> IO a
Util.catchSomeIOErrors IOError -> Bool
isAlreadyInUseError
(Socket -> SockAddr -> IO ()
Socket.bindSocket Socket
sock SockAddr
addr 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)
(\IOError
e -> do T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"server: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show IOError
e
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok Unblock () -> Unblock ()
forall a b. (a -> b) -> a -> b
$ do Socket -> Int -> IO ()
Socket.listen Socket
sock Int
Socket.maxListenQueue
T body ext -> Socket -> IO ()
forall body ext. C body => T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock)
acceptConnections :: (Stream.C body) =>
ServerEnv.T body ext -> Socket -> IO ()
acceptConnections :: T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock = do
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Calling accept..."
(Handle
h, Socket.SockAddrInet PortNumber
port HostAddress
haddr) <- Socket -> IO (Handle, SockAddr)
Util.accept Socket
sock
HostAddress -> IO String
Socket.inet_ntoa HostAddress
haddr IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
\String
ip -> T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got connection from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ip String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port
ThreadId
_ <- IO () -> IO ThreadId
forkIO (
(T body ext -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Handle -> HostAddress -> IO ()
talk T body ext
st Handle
h HostAddress
haddr IO () -> Unblock ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
IO.hClose Handle
h)
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
(\(Exception.SomeException e
e) ->
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String
"servlet died: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e))
)
T body ext -> Socket -> IO ()
forall body ext. C body => T body ext -> Socket -> IO ()
acceptConnections T body ext
st Socket
sock
talk :: (Stream.C body) =>
ServerEnv.T body ext -> IO.Handle -> HostAddress -> IO ()
talk :: T body ext -> Handle -> HostAddress -> IO ()
talk T body ext
st Handle
h HostAddress
haddr = do
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Started"
Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
h BufferMode
IO.LineBuffering
T body ext -> Bool -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
True Handle
h HostAddress
haddr
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Done"
run :: (Stream.C body) =>
ServerEnv.T body ext -> Bool -> IO.Handle -> HostAddress -> IO ()
run :: T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
first Handle
h HostAddress
haddr = do
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
let time_allowed :: Int
time_allowed =
if Bool
first
then T ext -> Int
forall ext. T ext -> Int
requestTimeout T ext
conf
else T ext -> Int
forall ext. T ext -> Int
keepAliveTimeout T ext
conf
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"Waiting for request..."
Maybe String
req <- IO (Maybe String)
-> (IOError -> IO (Maybe String)) -> IO (Maybe String)
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (
do Bool
ok <- Handle -> Int -> IO Bool
IO.hWaitForInput Handle
h (Int
time_allowed Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
if Bool
ok then (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (Handle -> IO String
getUntilEmptyLine Handle
h)
else do T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Request timeout (after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
time_allowed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s)"
Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeRequestTimeOut T ext
conf))
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
)
(\IOError
e ->
if IOError -> Bool
isEOFError IOError
e
then T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st String
"EOF from client" IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
else do T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing )
case Maybe String
req of { Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (); Just String
r -> do
case Parsec String () (T body)
-> String -> String -> Either ParseError (T body)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (T body)
forall body. Monoid body => Parser (T body)
Request.pHeaders String
"Request" String
r of
Left ParseError
err -> do
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeBadRequest T ext
conf)
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right T body
req_no_body -> do
T body
reqt <- Handle -> T body -> IO (T body)
forall body. C body => Handle -> T body -> IO (T body)
getBody Handle
h T body
req_no_body
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ T body -> String
forall a. Show a => a -> String
show T body
reqt
T body
resp <- T body ext -> T body -> HostAddress -> IO (T body)
forall body ext.
C body =>
T body ext -> T body -> HostAddress -> IO (T body)
request T body ext
st T body
reqt HostAddress
haddr
T body ext -> Handle -> T body -> IO ()
forall body ext. C body => T body ext -> Handle -> T body -> IO ()
response T body ext
st Handle
h T body
resp
let connection_headers :: [Connection]
connection_headers = Group -> [Connection]
forall a. HasHeaders a => a -> [Connection]
Request.getConnection (T body -> Group
forall body. T body -> Group
Request.headers T body
reqt)
if Connection
Request.ConnectionClose Connection -> [Connection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Connection]
connection_headers
Bool -> Bool -> Bool
|| (T body -> T
forall body. T body -> T
Request.httpVersion T body
reqt T -> T -> Bool
forall a. Ord a => a -> a -> Bool
< T
Version.http1_1
Bool -> Bool -> Bool
&& Connection
Request.ConnectionKeepAlive Connection -> [Connection] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Connection]
connection_headers)
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else T body ext -> Bool -> Handle -> HostAddress -> IO ()
forall body ext.
C body =>
T body ext -> Bool -> Handle -> HostAddress -> IO ()
run T body ext
st Bool
False Handle
h HostAddress
haddr
}
getBody :: (Stream.C body) =>
IO.Handle -> Request.T body -> IO (Request.T body)
getBody :: Handle -> T body -> IO (T body)
getBody Handle
h T body
req =
let
readBody :: IO body
readBody =
case T body -> Maybe Integer
forall a. HasHeaders a => a -> Maybe Integer
Header.getContentLength T body
req of
Maybe Integer
Nothing -> body -> IO body
forall (m :: * -> *) a. Monad m => a -> m a
return body
forall a. Monoid a => a
mempty
Just Integer
len -> Handle -> Integer -> IO body
forall stream. C stream => Handle -> Integer -> IO stream
Stream.read Handle
h Integer
len
in do body
b <- IO body
readBody
T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T body
req { body :: body
Request.body = body
b}
request :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress -> IO (Response.T body)
request :: T body ext -> T body -> HostAddress -> IO (T body)
request T body ext
st T body
req HostAddress
haddr =
do (T body
sreq,Maybe (T body)
merr) <- T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
forall body ext.
C body =>
T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
serverRequest T body ext
st T body
req HostAddress
haddr
T body
resp <- case Maybe (T body)
merr of
Maybe (T body)
Nothing -> do T body
sreq' <- T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
tweakRequest T body ext
st T body
sreq
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Handling request..."
T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
handleRequest T body ext
st T body
sreq'
Just T body
err -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
err
T body ext -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T body ext
st (T body -> String
forall body. T body -> String
Response.showStatusLine T body
resp)
T body ext -> T body -> T body -> TimeDiff -> IO ()
forall body ext.
T body ext -> T body -> T body -> TimeDiff -> IO ()
ServerEnv.logAccess T body ext
st T body
sreq T body
resp (String -> TimeDiff
forall a. HasCallStack => String -> a
error String
"noTimeDiff")
T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
resp
serverRequest :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress ->
IO (ServerRequest.T body, Maybe (Response.T body))
serverRequest :: T body ext -> T body -> HostAddress -> IO (T body, Maybe (T body))
serverRequest T body ext
st T body
req HostAddress
haddr =
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
sreq :: T body
sreq =
Cons :: forall body.
T body
-> HostAddress
-> Maybe HostEntry
-> HostEntry
-> String
-> String
-> PortNumber
-> T body
ServerRequest.Cons {
clientRequest :: T body
ServerRequest.clientRequest = T body
req,
clientAddress :: HostAddress
ServerRequest.clientAddress = HostAddress
haddr,
clientName :: Maybe HostEntry
ServerRequest.clientName = Maybe HostEntry
forall a. Maybe a
Nothing,
requestHostName :: HostEntry
ServerRequest.requestHostName = T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st,
serverURIPath :: String
ServerRequest.serverURIPath = String
"-",
serverFilename :: String
ServerRequest.serverFilename = String
"-",
serverPort :: PortNumber
ServerRequest.serverPort = T body ext -> PortNumber
forall body ext. T body ext -> PortNumber
ServerEnv.port T body ext
st
}
maybeExc :: Exceptional a a -> Maybe a
maybeExc Exceptional a a
x =
case Exceptional a a
x of
Exc.Success a
_ -> Maybe a
forall a. Maybe a
Nothing
Exc.Exception a
e -> a -> Maybe a
forall a. a -> Maybe a
Just a
e
in ((Maybe (T body), T body) -> (T body, Maybe (T body)))
-> IO (Maybe (T body), T body) -> IO (T body, Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (T body), T body) -> (T body, Maybe (T body))
forall a b. (a, b) -> (b, a)
swap (StateT (T body) IO (Maybe (T body))
-> T body -> IO (Maybe (T body), T body)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
((Exceptional (T body) () -> Maybe (T body))
-> StateT (T body) IO (Exceptional (T body) ())
-> StateT (T body) IO (Maybe (T body))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exceptional (T body) () -> Maybe (T body)
forall a a. Exceptional a a -> Maybe a
maybeExc (StateT (T body) IO (Exceptional (T body) ())
-> StateT (T body) IO (Maybe (T body)))
-> StateT (T body) IO (Exceptional (T body) ())
-> StateT (T body) IO (Maybe (T body))
forall a b. (a -> b) -> a -> b
$ ExceptionalT (T body) (StateT (T body) IO) ()
-> StateT (T body) IO (Exceptional (T body) ())
forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
runExceptionalT (ExceptionalT (T body) (StateT (T body) IO) ()
-> StateT (T body) IO (Exceptional (T body) ()))
-> ExceptionalT (T body) (StateT (T body) IO) ()
-> StateT (T body) IO (Exceptional (T body) ())
forall a b. (a -> b) -> a -> b
$ T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall body ext.
C body =>
T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
serverRequestExc T body ext
st T body
req HostAddress
haddr) T body
sreq)
IO (T body, Maybe (T body))
-> (SomeException -> IO (T body, Maybe (T body)))
-> IO (T body, Maybe (T body))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
( \(Exception.SomeException e
exception) -> do
T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
exception)
(T body, Maybe (T body)) -> IO (T body, Maybe (T body))
forall (m :: * -> *) a. Monad m => a -> m a
return (T body
sreq, T body -> Maybe (T body)
forall a. a -> Maybe a
Just (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeInternalServerError T ext
conf))
)
serverRequestExc :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> HostAddress ->
ExceptionalT (Response.T body) (StateT (ServerRequest.T body) IO) ()
serverRequestExc :: T body ext
-> T body
-> HostAddress
-> ExceptionalT (T body) (StateT (T body) IO) ()
serverRequestExc T body ext
st T body
req HostAddress
haddr =
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
use :: ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use = (IO (Exceptional e1 b) -> StateT (T body) IO (Exceptional e1 b))
-> ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
forall (m :: * -> *) e0 a (n :: * -> *) e1 b.
(m (Exceptional e0 a) -> n (Exceptional e1 b))
-> ExceptionalT e0 m a -> ExceptionalT e1 n b
Exc.mapExceptionalT IO (Exceptional e1 b) -> StateT (T body) IO (Exceptional e1 b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
update :: (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update = StateT s IO () -> ExceptionalT (T body) (StateT s IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT s IO () -> ExceptionalT (T body) (StateT s IO) ())
-> ((s -> s) -> StateT s IO ())
-> (s -> s)
-> ExceptionalT (T body) (StateT s IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s) -> StateT s IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify
in do Maybe HostEntry
remoteName <- ExceptionalT (T body) IO (Maybe HostEntry)
-> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry)
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO (Maybe HostEntry)
-> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry))
-> ExceptionalT (T body) IO (Maybe HostEntry)
-> ExceptionalT (T body) (StateT (T body) IO) (Maybe HostEntry)
forall a b. (a -> b) -> a -> b
$ IO (Maybe HostEntry) -> ExceptionalT (T body) IO (Maybe HostEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe HostEntry)
-> ExceptionalT (T body) IO (Maybe HostEntry))
-> IO (Maybe HostEntry)
-> ExceptionalT (T body) IO (Maybe HostEntry)
forall a b. (a -> b) -> a -> b
$ T ext -> HostAddress -> IO (Maybe HostEntry)
forall ext. T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname T ext
conf HostAddress
haddr
(T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { clientName :: Maybe HostEntry
ServerRequest.clientName = Maybe HostEntry
remoteName }
HostEntry
host <- ExceptionalT (T body) IO HostEntry
-> ExceptionalT (T body) (StateT (T body) IO) HostEntry
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO HostEntry
-> ExceptionalT (T body) (StateT (T body) IO) HostEntry)
-> ExceptionalT (T body) IO HostEntry
-> ExceptionalT (T body) (StateT (T body) IO) HostEntry
forall a b. (a -> b) -> a -> b
$ T body ext -> T body -> ExceptionalT (T body) IO HostEntry
forall body ext.
C body =>
T body ext -> T body -> EIO body HostEntry
getServerHostName T body ext
st T body
req
(T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { requestHostName :: HostEntry
ServerRequest.requestHostName = HostEntry
host }
String
path <- ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String)
-> ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall a b. (a -> b) -> a -> b
$ T body ext -> T body -> ExceptionalT (T body) IO String
forall body ext. C body => T body ext -> T body -> EIO body String
requestAbsPath T body ext
st T body
req
(T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { serverURIPath :: String
ServerRequest.serverURIPath = String
path }
String
file <- ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall e1 b.
ExceptionalT e1 IO b -> ExceptionalT e1 (StateT (T body) IO) b
use (ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String)
-> ExceptionalT (T body) IO String
-> ExceptionalT (T body) (StateT (T body) IO) String
forall a b. (a -> b) -> a -> b
$ T body ext -> String -> String -> ExceptionalT (T body) IO String
forall body ext.
C body =>
T body ext -> String -> String -> EIO body String
translatePath T body ext
st (HostEntry -> String
hostName HostEntry
host) String
path
(T body -> T body) -> ExceptionalT (T body) (StateT (T body) IO) ()
forall s. (s -> s) -> ExceptionalT (T body) (StateT s IO) ()
update ((T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ())
-> (T body -> T body)
-> ExceptionalT (T body) (StateT (T body) IO) ()
forall a b. (a -> b) -> a -> b
$ \T body
sreq -> T body
sreq { serverFilename :: String
ServerRequest.serverFilename = String
file }
maybeLookupHostname :: Config.T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname :: T ext -> HostAddress -> IO (Maybe HostEntry)
maybeLookupHostname T ext
conf HostAddress
haddr =
if T ext -> Bool
forall ext. T ext -> Bool
hostnameLookups T ext
conf
then IO (Maybe HostEntry)
-> (IOError -> IO (Maybe HostEntry)) -> IO (Maybe HostEntry)
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError
((HostEntry -> Maybe HostEntry)
-> IO HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HostEntry -> Maybe HostEntry
forall a. a -> Maybe a
Just (Family -> HostAddress -> IO HostEntry
BSD.getHostByAddr Family
AF_INET HostAddress
haddr))
(\IOError
_ -> Maybe HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HostEntry
forall a. Maybe a
Nothing)
else Maybe HostEntry -> IO (Maybe HostEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HostEntry
forall a. Maybe a
Nothing
type EIO body = ExceptionalT (Response.T body) IO
getServerHostName :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> EIO body HostEntry
getServerHostName :: T body ext -> T body -> EIO body HostEntry
getServerHostName T body ext
st T body
req =
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
isServerHost :: String -> Bool
isServerHost String
host =
String
host String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert (T ext -> String
forall ext. T ext -> String
serverName T ext
conf) (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$ T ext -> Set String
forall ext. T ext -> Set String
serverAlias T ext
conf) Bool -> Bool -> Bool
||
(T body -> Bool) -> [T body] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((T body -> String -> Bool) -> String -> T body -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip T body -> String -> Bool
forall body. T body -> String -> Bool
Module.isServerHost String
host) (T body ext -> [T body]
forall body ext. T body ext -> [T body]
ServerEnv.modules T body ext
st)
in case T body -> Maybe (String, Maybe Int)
forall a. HasHeaders a => a -> Maybe (String, Maybe Int)
Request.getHost T body
req of
Maybe (String, Maybe Int)
Nothing ->
if T body -> T
forall body. T body -> T
Request.httpVersion T body
req T -> T -> Bool
forall a. Ord a => a -> a -> Bool
< T
Version.http1_1
then HostEntry -> EIO body HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (HostEntry -> EIO body HostEntry)
-> HostEntry -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st
else T body -> EIO body HostEntry
forall (m :: * -> *) e a. Monad m => e -> ExceptionalT e m a
Exc.throwT (T body -> EIO body HostEntry) -> T body -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeBadRequest T ext
conf
Just (String
host,Maybe Int
_) ->
if String -> Bool
isServerHost String
host
then HostEntry -> EIO body HostEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (HostEntry -> EIO body HostEntry)
-> HostEntry -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ (T body ext -> HostEntry
forall body ext. T body ext -> HostEntry
ServerEnv.hostName T body ext
st) { hostName :: String
hostName = String
host }
else do IO () -> ExceptionalT (T body) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptionalT (T body) IO ())
-> IO () -> ExceptionalT (T body) IO ()
forall a b. (a -> b) -> a -> b
$ T body ext -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logError T body ext
st (String
"Unknown host: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
host)
T body -> EIO body HostEntry
forall (m :: * -> *) e a. Monad m => e -> ExceptionalT e m a
Exc.throwT (T body -> EIO body HostEntry) -> T body -> EIO body HostEntry
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotFound T ext
conf
requestAbsPath :: (Stream.C body) =>
ServerEnv.T body ext -> Request.T body -> EIO body String
requestAbsPath :: T body ext -> T body -> EIO body String
requestAbsPath T body ext
_ T body
req = String -> EIO body String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> EIO body String) -> String -> EIO body String
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ T body -> URI
forall body. T body -> URI
Request.uri T body
req
translatePath :: (Stream.C body) =>
ServerEnv.T body ext -> String -> String -> EIO body FilePath
translatePath :: T body ext -> String -> String -> EIO body String
translatePath T body ext
st String
host String
pth =
do Maybe String
m_file <- IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String))
-> IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ T body ext -> (T body -> MaybeT IO String) -> IO (Maybe String)
forall body ext a.
T body ext -> (T body -> MaybeT IO a) -> IO (Maybe a)
ServerEnv.tryModules T body ext
st (\T body
m -> T body -> String -> String -> MaybeT IO String
forall body. T body -> String -> String -> MaybeT IO String
Module.translatePath T body
m String
host String
pth)
case Maybe String
m_file of
Just String
file -> String -> EIO body String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> EIO body String) -> String -> EIO body String
forall a b. (a -> b) -> a -> b
$ String
file
Maybe String
Nothing -> T body ext -> String -> EIO body String
forall body ext. C body => T body ext -> String -> EIO body String
defaultTranslatePath T body ext
st String
pth
defaultTranslatePath :: (Stream.C body) =>
ServerEnv.T body ext -> String -> EIO body FilePath
defaultTranslatePath :: T body ext -> String -> EIO body String
defaultTranslatePath T body ext
st String
pth =
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
in (Maybe String -> String)
-> ExceptionalT (T body) IO (Maybe String) -> EIO body String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
forall a. a -> a
id) (ExceptionalT (T body) IO (Maybe String) -> EIO body String)
-> ExceptionalT (T body) IO (Maybe String) -> EIO body String
forall a b. (a -> b) -> a -> b
$ IO (Maybe String) -> ExceptionalT (T body) IO (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> String -> IO (Maybe String)
Util.localPath (T ext -> String
forall ext. T ext -> String
documentRoot T ext
conf) String
pth)
tweakRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (ServerRequest.T body)
tweakRequest :: T body ext -> T body -> IO (T body)
tweakRequest T body ext
st =
T body ext
-> (T body -> T body -> IO (T body)) -> T body -> IO (T body)
forall body ext a. T body ext -> (T body -> a -> IO a) -> a -> IO a
ServerEnv.foldModules T body ext
st (\T body
m T body
r -> T body -> T body -> IO (T body)
forall body. T body -> T body -> IO (T body)
Module.tweakRequest T body
m T body
r)
handleRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
handleRequest :: T body ext -> T body -> IO (T body)
handleRequest T body ext
st T body
req =
do Maybe (T body)
m_resp <- T body ext -> (T body -> MaybeT IO (T body)) -> IO (Maybe (T body))
forall body ext a.
T body ext -> (T body -> MaybeT IO a) -> IO (Maybe a)
ServerEnv.tryModules T body ext
st (\T body
m -> T body -> T body -> MaybeT IO (T body)
forall body. T body -> T body -> MaybeT IO (T body)
Module.handleRequest T body
m T body
req)
case Maybe (T body)
m_resp of
Just T body
resp -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return T body
resp
Maybe (T body)
Nothing -> T body ext -> T body -> IO (T body)
forall body ext. C body => T body ext -> T body -> IO (T body)
defaultHandleRequest T body ext
st T body
req
defaultHandleRequest :: (Stream.C body) =>
ServerEnv.T body ext -> ServerRequest.T body -> IO (Response.T body)
defaultHandleRequest :: T body ext -> T body -> IO (T body)
defaultHandleRequest T body ext
st T body
_ =
T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$ T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotFound (T ext -> T body) -> T ext -> T body
forall a b. (a -> b) -> a -> b
$ T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
st
response :: (Stream.C body) =>
ServerEnv.T body ext ->
IO.Handle ->
Response.T body ->
IO ()
response :: T body ext -> Handle -> T body -> IO ()
response T body ext
env Handle
h
(Response.Cons {
code :: forall body. T body -> Int
Response.code = Int
code,
description :: forall body. T body -> String
Response.description = String
desc,
headers :: forall body. T body -> Group
Response.headers = Group
headers,
coding :: forall body. T body -> [TransferCoding]
Response.coding = [TransferCoding]
tes,
body :: forall body. T body -> Body body
Response.body = Body body
body,
doSendBody :: forall body. T body -> Bool
Response.doSendBody = Bool
sendBody
}) =
do
Handle -> String -> IO ()
Util.hPutStrCrLf Handle
h (Int -> String -> String
Response.statusLine Int
code String
desc)
Handle -> T -> IO ()
hPutHeader Handle
h T
Response.serverHeader
T
date <- IO T
Response.dateHeader
Handle -> T -> IO ()
hPutHeader Handle
h T
date
(T -> IO ()) -> [T] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> T -> IO ()
hPutHeader Handle
h) (Group -> [T]
forall x. HasHeaders x => x -> [T]
Header.list Group
headers)
let contentLength :: Maybe Integer
contentLength = Body body -> Maybe Integer
forall body. Body body -> Maybe Integer
Response.size Body body
body
Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Body body -> Bool
forall body. C body => Body body -> Bool
Response.hasBody Body body
body Bool -> Bool -> Bool
&& [TransferCoding] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TransferCoding]
tes)
(IO () -> (Integer -> IO ()) -> Maybe Integer -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Handle -> T -> IO ()
hPutHeader Handle
h (T -> IO ()) -> (Integer -> T) -> Integer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> T
Header.makeContentLength) Maybe Integer
contentLength)
(TransferCoding -> IO ()) -> [TransferCoding] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> T -> IO ()
hPutHeader Handle
h (T -> IO ()) -> (TransferCoding -> T) -> TransferCoding -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferCoding -> T
Header.makeTransferCoding) [TransferCoding]
tes
Handle -> String -> IO ()
Util.hPutStrCrLf Handle
h String
""
let conf :: T ext
conf = T body ext -> T ext
forall body ext. T body ext -> T ext
ServerEnv.config T body ext
env
Bool -> Unblock ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendBody Unblock () -> Unblock ()
forall a b. (a -> b) -> a -> b
$
case [TransferCoding] -> Maybe ([TransferCoding], TransferCoding)
forall a. [a] -> Maybe ([a], a)
viewR [TransferCoding]
tes of
Just ([TransferCoding]
_, TransferCoding
Header.ChunkedTransferCoding) ->
Int -> Handle -> Body body -> IO ()
forall body. C body => Int -> Handle -> Body body -> IO ()
Response.sendBodyChunked (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) Handle
h Body body
body
Maybe ([TransferCoding], TransferCoding)
_ -> Handle -> Body body -> IO ()
forall body. C body => Handle -> Body body -> IO ()
Response.sendBody Handle
h Body body
body
hPutHeader :: IO.Handle -> Header.T -> IO ()
Handle
h =
Handle -> String -> IO ()
IO.hPutStr Handle
h (String -> IO ()) -> (T -> String) -> T -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> String
forall a. Show a => a -> String
show