-- ------------------------------------------------------------------------------- Copyright 2002, Simon Marlow.-- Copyright 2006, Bjorn Bringert.-- Copyright 2009, Henning Thielemann.-- All rights reserved.---- Redistribution and use in source and binary forms, with or without-- modification, are permitted provided that the following conditions are-- met:---- * Redistributions of source code must retain the above copyright notice,-- this list of conditions and the following disclaimer.---- * Redistributions in binary form must reproduce the above copyright-- notice, this list of conditions and the following disclaimer in the-- documentation and/or other materials provided with the distribution.---- * Neither the name of the copyright holder(s) nor the names of-- contributors may be used to endorse or promote products derived from-- this software without specific prior written permission.---- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-- -----------------------------------------------------------------------------moduleNetwork.MoHWS.Server(main,mainWithOptions,)whereimportqualifiedNetwork.MoHWS.Server.RequestasServerRequestimportqualifiedNetwork.MoHWS.Server.EnvironmentasServerEnvimportqualifiedNetwork.MoHWS.Server.ContextasServerContextimportNetwork.MoHWS.Logger.Error(debug,logError,logInfo,)importqualifiedNetwork.MoHWS.ModuleasModuleimportqualifiedNetwork.MoHWS.Module.DescriptionasModuleDescimportqualifiedNetwork.MoHWS.Logger.AccessasAccessLoggerimportqualifiedNetwork.MoHWS.Logger.ErrorasErrorLoggerimportqualifiedNetwork.MoHWS.Configuration.ParserasConfigParserimportNetwork.MoHWS.ConfigurationasConfigimportqualifiedNetwork.MoHWS.InitializationasInitimportqualifiedNetwork.MoHWS.HTTP.MimeTypeasMimeTypeimportqualifiedNetwork.MoHWS.Server.OptionsasOptionsimportNetwork.MoHWS.ParserUtility(getUntilEmptyLine,)importqualifiedNetwork.MoHWS.HTTP.VersionasVersionimportqualifiedNetwork.MoHWS.HTTP.HeaderasHeaderimportqualifiedNetwork.MoHWS.HTTP.RequestasRequestimportqualifiedNetwork.MoHWS.HTTP.ResponseasResponseimportqualifiedNetwork.MoHWS.StreamasStreamimportqualifiedNetwork.MoHWS.UtilityasUtilimportData.Monoid(mempty,)importData.Maybe(catMaybes,)importData.Tuple.HT(swap,)importData.List.HT(viewR,)importqualifiedData.SetasSetimportControl.Monad.Trans.State(StateT,runStateT,modify,)importqualifiedControl.Monad.Exception.SynchronousasExcimportqualifiedControl.ExceptionasExceptionimportControl.Monad.Trans(lift,)importControl.Monad.Exception.Synchronous(ExceptionalT,runExceptionalT,)importControl.Concurrent(myThreadId,ThreadId,throwTo,killThread,forkIO,)importControl.Exception(Exception(ErrorCall),finally,catchJust,ioErrors,block,unblock,)importControl.Monad(liftM,when,)importNetwork.BSDimportNetwork.Sockethiding(listen)importqualifiedNetwork.SocketasSocketimportNetwork.URI(uriPath,)importSystem.Environment(getArgs,)importSystem.IOimportSystem.IO.Error(isAlreadyInUseError,isEOFError,)importSystem.PosiximportText.ParserCombinators.Parsec(parse,choice,){- -----------------------------------------------------------------------------
ToDo:
- MAJOR:
- deal with http version numbers
- timeouts (partly done)
- languages
- per-directory permissions (ala apache)
- error logging levels
- per-directory config options.
- languages (content-language, accept-language)
- multipart/byteranges
- MINOR:
- access logging (various bits left)
- implement user & group setting
- log time to serve request
- terminate & restart signal (like Apache's SIGHUP)
- don't die if the new configuration file contains errors after a restart
- reading config file may block, unsafe if we receive another SIGHUP
- common up headers with same name (eg. accept).
- implement if-modified-since (need to parse time)
- MAYBE:
- throttling if too many open connections (config: MaxClients)
-}------------------------------------------------------------------------------- Top-level servermain::(Stream.Cbody)=>Init.Tbodyext->IO()maininitExt=doargs<-getArgscaseOptions.parseargsofLefterr->Util.dieerrRightopts->mainWithOptionsinitExtoptsmainWithOptions::(Stream.Cbody)=>Init.Tbodyext->Options.T->IO()mainWithOptionsinitExtopts=domain_thread<-myThreadIdinstallHandlersigPIPEIgnoreNothinginstallHandlersigHUP(Catch(hupHandlermain_thread))Nothingblock$readConfiginitExtoptshupHandler::ThreadId->IO()hupHandlermain_thread=throwTomain_thread(ErrorCall"**restart**")sigsToBlock::SignalSetsigsToBlock=addSignalsigHUPemptySignalSet-- Async exceptions should be blocked on entry to readConfig (so that-- multiple SIGHUPs close together can't kill us). Make sure that-- there aren't any interruptible operations until we've blocked signals.readConfig::(Stream.Cbody)=>Init.Tbodyext->Options.T->IO()readConfiginitExtopts=doblockSignalssigsToBlockr<-ConfigParser.run(choice$mapModuleDesc.configParser$Init.moduleListinitExt)(Options.configPathopts)caserofLefterr->Util.die$unlines$"Failed to parse configuration file":showerr:[]Rightb->doletupdates=mapModuleDesc.setDefltConfig$Init.moduleListinitExtconfExtDeflt=foldl(flip($))(Init.configurationExtensionDefaultinitExt)updatesconf=b(Config.defltconfExtDeflt)st<-initServerStateoptsconfmods<-fmapcatMaybes$mapM(loadModulest)$Init.moduleListinitExttopServerstmodsinitExtrereadConfig::(Stream.Cbody)=>ServerContext.Text->Init.Tbodyext->IO()rereadConfigstinitExt=domapM_AccessLogger.stop(ServerContext.accessLoggersst)ErrorLogger.stop(ServerContext.errorLoggerst)readConfiginitExt(ServerContext.optionsst)initServerState::Options.T->Config.Text->IO(ServerContext.Text)initServerStateoptsconf=dohost<-doent<-getHostEntrycaseserverNameconfof""->returnentn->returnent{hostName=n}mimeTypes<-MimeType.loadDictionary(Options.inServerRootopts(typesConfigconf))errorLogger<-ErrorLogger.start(Options.inServerRootopts(errorLogFileconf))(logLevelconf)accessLoggers<-sequence[AccessLogger.startformat(Options.inServerRootoptsfile)|(file,format)<-customLogsconf]letst=ServerContext.Cons{ServerContext.options=opts,ServerContext.config=conf,ServerContext.hostName=host,ServerContext.mimeTypes=mimeTypes,ServerContext.errorLogger=errorLogger,ServerContext.accessLoggers=accessLoggers}returnstloadModule::(Stream.Cbody)=>ServerContext.Text->ModuleDesc.Tbodyext->IO(Maybe(Module.Tbody))loadModulestmd=(dologInfost$"Loading module "++ModuleDesc.namemd++"..."fmapJust$ModuleDesc.loadmdst)`Exception.catch`\e->dologErrorst$unlines["Error loading module "++ModuleDesc.namemd,showe]returnNothing-- We catch exceptions from the main server thread, and restart the-- server. If we receive a restart signal (from a SIGHUP), then we-- re-read the configuration file.topServer::(Stream.Cbody)=>ServerContext.Text->[Module.Tbody]->Init.Tbodyext->IO()topServerstmodsinitExt=letstartServers=dots<-serversstmods(Util.wait`Exception.catch`(\e->caseeofErrorCall"**restart**"->domapM_killThreadtsrereadConfigstinitExt_->Exception.throwe))loop=(dounblockSignalssigsToBlockunblockstartServers)`Exception.catch`(\e->dologErrorst("server: "++showe)loop)inloopservers::(Stream.Cbody)=>ServerContext.Text->[Module.Tbody]->IO[ThreadId]serversstmods=letmkEnvport=ServerEnv.Cons{ServerEnv.context=st,ServerEnv.modules=mods,ServerEnv.port=port}mkAddr(maddr,port)=doaddr<-casemaddrofNothing->returniNADDR_ANYJustip->inet_addripreturn(mkEnvport,SockAddrInetportaddr)indoaddrs<-mapMmkAddr(listen(ServerContext.configst))mapM(\(env,addr)->forkIO(serverenvaddr))addrs-- open the server socket and start accepting connectionsserver::(Stream.Cbody)=>ServerEnv.Tbodyext->SockAddr->IO()serverstaddr=dologInfost$"Starting server thread on "++showaddrproto<-getProtocolNumber"tcp"Exception.bracket(socketAF_INETStreamproto)(\sock->sClosesock)(\sock->dosetSocketOptionsockReuseAddr1ok<-Util.catchSomeIOErrorsisAlreadyInUseError(bindSocketsockaddr>>returnTrue)(\e->dologErrorst("server: "++showe)hPutStrLnstderr$showereturnFalse)whenok$doSocket.listensockmaxListenQueueacceptConnectionsstsock)-- accept connections, and fork off a new thread to handle each oneacceptConnections::(Stream.Cbody)=>ServerEnv.Tbodyext->Socket->IO()acceptConnectionsstsock=dodebugst"Calling accept..."(h,SockAddrInetporthaddr)<-Util.acceptsockinet_ntoahaddr>>=\ip->debugst$"Got connection from "++ip++":"++showportforkIO((talksthhaddr`finally`hCloseh)`Exception.catch`(\e->debugst("servlet died: "++showe)))acceptConnectionsstsocktalk::(Stream.Cbody)=>ServerEnv.Tbodyext->Handle->HostAddress->IO()talksthhaddr=dodebugst"Started"hSetBufferinghLineBufferingrunstTruehhaddrdebugst"Done"run::(Stream.Cbody)=>ServerEnv.Tbodyext->Bool->Handle->HostAddress->IO()runstfirsthhaddr=doletconf=ServerEnv.configst-- read a request up to the first empty line. If we-- don't get a request within the alloted time, issue-- a "Request Time-out" response and close the connection.lettime_allowed=iffirstthenrequestTimeoutconfelsekeepAliveTimeoutconfdebugst"Waiting for request..."req<-catchJustioErrors(dook<-hWaitForInputh(time_allowed*1000)ifokthenliftMJust(getUntilEmptyLineh)-- only send a "request timed out" response if this-- was the first request on the socket. Subsequent-- requests time-out and close the socket silently.-- ToDo: if we get a partial request, still emit the-- the timeout response.elsedodebugst$"Request timeout (after "++showtime_allowed++" s)"whenfirst(responsesth(Response.makeRequestTimeOutconf))returnNothing)(\e->ifisEOFErrorethendebugst"EOF from client">>returnNothingelsedologErrorst("request: "++showe)returnNothing)casereqof{Nothing->return();Justr->docaseparseRequest.pHeaders"Request"rof-- close the connection after a badly formatted requestLefterr->dodebugst(showerr)responsesth(Response.makeBadRequestconf)return()Rightreq_no_body->doreqt<-getBodyhreq_no_bodydebugst$showreqtresp<-requeststreqthaddrresponsesthresp-- Persistent Connections---- We close the connection if-- (a) client specified "connection: close"-- (b) client is pre-HTTP/1.1, and didn't-- specify "connection: keep-alive"letconnection_headers=Request.getConnection(Request.headersreqt)ifRequest.ConnectionClose`elem`connection_headers||(Request.httpVersionreqt<Version.http1_1&&Request.ConnectionKeepAlive`notElem`connection_headers)thenreturn()elserunstFalsehhaddr}getBody::(Stream.Cbody)=>Handle->Request.Tbody->IO(Request.Tbody)getBodyhreq=let-- FIXME: handled chunked inputreadBody=caseHeader.getContentLengthreqofNothing->returnmempty-- FIXME: what if input is huge?Justlen->Stream.readhlenindob<-readBodyreturn$req{Request.body=b}------------------------------------------------------------------------------- Dealing with requestsrequest::(Stream.Cbody)=>ServerEnv.Tbodyext->Request.Tbody->HostAddress->IO(Response.Tbody)requeststreqhaddr=do(sreq,merr)<-serverRequeststreqhaddrresp<-casemerrofNothing->dosreq'<-tweakRequeststsreqdebugst$"Handling request..."handleRequeststsreq'Justerr->returnerrdebugst(Response.showStatusLineresp)ServerEnv.logAccessstsreqresp(error"noTimeDiff"){-FIXME-}returnrespserverRequest::(Stream.Cbody)=>ServerEnv.Tbodyext->Request.Tbody->HostAddress->IO(ServerRequest.Tbody,Maybe(Response.Tbody))serverRequeststreqhaddr=letconf=ServerEnv.configstsreq=ServerRequest.Cons{ServerRequest.clientRequest=req,ServerRequest.clientAddress=haddr,ServerRequest.clientName=Nothing,ServerRequest.requestHostName=ServerEnv.hostNamest,ServerRequest.serverURIPath="-",ServerRequest.serverFilename="-",ServerRequest.serverPort=ServerEnv.portst}maybeExcx=casexofExc.Success_->NothingExc.Exceptione->Justeinfmapswap(runStateT(fmapmaybeExc$runExceptionalT$serverRequestExcstreqhaddr)sreq)`Exception.catch`(\exception->dologErrorst("request: "++showexception)return(sreq,Just(Response.makeInternalServerErrorconf)))serverRequestExc::(Stream.Cbody)=>ServerEnv.Tbodyext->Request.Tbody->HostAddress->ExceptionalT(Response.Tbody)(StateT(ServerRequest.Tbody)IO)()serverRequestExcstreqhaddr=letconf=ServerEnv.configstuse=Exc.mapExceptionalTliftupdate=lift.modifyindoremoteName<-use$lift$maybeLookupHostnameconfhaddrupdate$\sreq->sreq{ServerRequest.clientName=remoteName}host<-use$getServerHostNamestrequpdate$\sreq->sreq{ServerRequest.requestHostName=host}path<-use$requestAbsPathstrequpdate$\sreq->sreq{ServerRequest.serverURIPath=path}file<-use$translatePathst(hostNamehost)pathupdate$\sreq->sreq{ServerRequest.serverFilename=file}maybeLookupHostname::Config.Text->HostAddress->IO(MaybeHostEntry)maybeLookupHostnameconfhaddr=ifhostnameLookupsconfthencatchJustioErrors(liftMJust(getHostByAddrAF_INEThaddr))(\_->returnNothing)elsereturnNothingtypeEIObody=ExceptionalT(Response.Tbody)IO-- make sure we've got a host field-- if the request version is >= HTTP/1.1getServerHostName::(Stream.Cbody)=>ServerEnv.Tbodyext->Request.Tbody->EIObodyHostEntrygetServerHostNamestreq=letconf=ServerEnv.configstisServerHosthost=host`Set.member`(Set.insert(serverNameconf)$serverAliasconf)||any(flipModule.isServerHosthost)(ServerEnv.modulesst)incaseRequest.getHostreqofNothing->ifRequest.httpVersionreq<Version.http1_1thenreturn$ServerEnv.hostNamestelseExc.throwT$Response.makeBadRequestconfJust(host,_)->ifisServerHosthostthenreturn$(ServerEnv.hostNamest){hostName=host}elsedolift$logErrorst("Unknown host: "++showhost)Exc.throwT$Response.makeNotFoundconf-- | Get the absolute path from the request.requestAbsPath::(Stream.Cbody)=>ServerEnv.Tbodyext->Request.Tbody->EIObodyStringrequestAbsPath_req=return$uriPath$Request.urireq-- Path translationtranslatePath::(Stream.Cbody)=>ServerEnv.Tbodyext->String->String->EIObodyFilePathtranslatePathsthostpth=dom_file<-lift$ServerEnv.tryModulesst(\m->Module.translatePathmhostpth)casem_fileofJustfile->return$fileNothing->defaultTranslatePathstpthdefaultTranslatePath::(Stream.Cbody)=>ServerEnv.Tbodyext->String->EIObodyFilePathdefaultTranslatePathstpth=letconf=ServerEnv.configstincasepthof'/':_->return$documentRootconf++pth_->Exc.throwT$Response.makeNotFoundconf-- Request tweakingtweakRequest::(Stream.Cbody)=>ServerEnv.Tbodyext->ServerRequest.Tbody->IO(ServerRequest.Tbody)tweakRequestst=ServerEnv.foldModulesst(\mr->Module.tweakRequestmr)-- Request handlinghandleRequest::(Stream.Cbody)=>ServerEnv.Tbodyext->ServerRequest.Tbody->IO(Response.Tbody)handleRequeststreq=dom_resp<-ServerEnv.tryModulesst(\m->Module.handleRequestmreq)casem_respofJustresp->returnrespNothing->defaultHandleRequeststreqdefaultHandleRequest::(Stream.Cbody)=>ServerEnv.Tbodyext->ServerRequest.Tbody->IO(Response.Tbody)defaultHandleRequestst_=return$Response.makeNotFound$ServerEnv.configst-- Sending responseresponse::(Stream.Cbody)=>ServerEnv.Tbodyext->Handle->Response.Tbody->IO()responseenvh(Response.Cons{Response.code=code,Response.description=desc,Response.headers=headers,Response.coding=tes,Response.body=body,Response.doSendBody=sendBody})=doUtil.hPutStrCrLfh(Response.statusLinecodedesc)hPutHeaderhResponse.serverHeader-- Date Header: required on all messagesdate<-Response.dateHeaderhPutHeaderhdatemapM_(hPutHeaderh)(Header.listheaders)-- Output a Content-Length when the message body isn't-- encoded. If it *is* encoded, then the last transfer-- coding must be "chunked", according to RFC2616 sec 3.6. This-- allows the client to determine the message-length.letcontentLength=Response.sizebodywhen(Response.hasBodybody&&nulltes)(maybe(return())(hPutHeaderh.Header.makeContentLength)contentLength)mapM_(hPutHeaderh.Header.makeTransferCoding)tesUtil.hPutStrCrLfh""-- ToDo: implement transfer codingsletconf=ServerEnv.configenvwhensendBody$caseviewRtesofJust(_,Header.ChunkedTransferCoding)->Response.sendBodyChunked(Config.chunkSizeconf)hbody_->Response.sendBodyhbodyhPutHeader::Handle->Header.T->IO()hPutHeaderh=hPutStrh.show-- Util.hPutStrCrLf h . show