{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE RankNTypes #-}-- | Backend for Common Gateway Interface. Almost all users should use the-- 'run' function.moduleNetwork.Wai.Handler.CGI(run,runSendfile,runGeneric,requestBodyFunc)whereimportNetwork.WaiimportNetwork.Socket(getAddrInfo,addrAddress)importSystem.Environment(getEnvironment)importData.Maybe(fromMaybe)importqualifiedData.ByteString.Char8asBimportqualifiedData.ByteString.LazyasLimportControl.Arrow((***))importData.Char(toLower)importqualifiedSystem.IOimportqualifiedData.StringasStringimportData.Enumerator(Enumerator,Step(..),Stream(..),continue,yield,enumList,($$),joinI,returnI,(>>==),run_)importData.Monoid(mconcat)importBlaze.ByteString.Builder(fromByteString,toLazyByteString)importBlaze.ByteString.Builder.Char8(fromChar,fromString)importBlaze.ByteString.Builder.Enumerator(builderToByteString)importControl.Monad.IO.Class(liftIO)importData.ByteString.Lazy.Internal(defaultChunkSize)importSystem.IO(Handle)importNetwork.HTTP.Types(Status(..))importqualifiedNetwork.HTTP.TypesasHimportqualifiedData.CaseInsensitiveasCIsafeRead::Reada=>a->String->asafeReadds=casereadssof((x,_):_)->x[]->dlookup'::String->[(String,String)]->Stringlookup'keypairs=fromMaybe""$lookupkeypairs-- | Run an application using CGI.run::Application->IO()runapp=dovars<-getEnvironmentletinput=requestBodyHandleSystem.IO.stdinoutput=B.hPutSystem.IO.stdoutrunGenericvarsinputoutputNothingapp-- | Some web servers provide an optimization for sending files via a sendfile-- system call via a special header. To use this feature, provide that header-- name here.runSendfile::B.ByteString-- ^ sendfile header->Application->IO()runSendfilesfapp=dovars<-getEnvironmentletinput=requestBodyHandleSystem.IO.stdinoutput=B.hPutSystem.IO.stdoutrunGenericvarsinputoutput(Justsf)app-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to-- use the same code as CGI. Most users will not need this function, and can-- stick with 'run' or 'runSendfile'.runGeneric::[(String,String)]-- ^ all variables->(foralla.Int->EnumeratorB.ByteStringIOa)-- ^ responseBody of input->(B.ByteString->IO())-- ^ destination for output->MaybeB.ByteString-- ^ does the server support the X-Sendfile header?->Application->IO()runGenericvarsinputHoutputHxsendfileapp=doletrmethod=B.pack$lookup'"REQUEST_METHOD"varspinfo=lookup'"PATH_INFO"varsqstring=lookup'"QUERY_STRING"varsservername=lookup'"SERVER_NAME"varsserverport=safeRead80$lookup'"SERVER_PORT"varscontentLength=safeRead0$lookup'"CONTENT_LENGTH"varsremoteHost'=caselookup"REMOTE_ADDR"varsofJustx->xNothing->caselookup"REMOTE_HOST"varsofJustx->xNothing->""isSecure'=casemaptoLower$lookup'"SERVER_PROTOCOL"varsof"https"->True_->Falseaddrs<-getAddrInfoNothing(JustremoteHost')Nothingletaddr=caseaddrsofa:_->addrAddressa[]->error$"Invalid REMOTE_ADDR or REMOTE_HOST: "++remoteHost'letenv=Request{requestMethod=rmethod,rawPathInfo=B.packpinfo,pathInfo=H.decodePathSegments$B.packpinfo,rawQueryString=B.packqstring,queryString=H.parseQuery$B.packqstring,serverName=B.packservername,serverPort=serverport,requestHeaders=map(cleanupVarName***B.pack)vars,isSecure=isSecure',remoteHost=addr,httpVersion=H.http11-- FIXME}-- FIXME worry about exception?res<-run_$inputHcontentLength$$appenvcase(xsendfile,res)of(Justsf,ResponseFileshsfpNothing)->mapM_outputH$L.toChunks$toLazyByteString$sfBuildershssffp_->responseEnumeratorres$\shs->joinI$enumList1[headersshs,fromChar'\n']$$builderIterwhereheadersshs=mconcat(mapheader$statuss:mapheader'(fixHeadershs))status(Statusim)=(fromByteString"Status",mconcat[fromString$showi,fromChar' ',fromByteStringm])header'(x,y)=(fromByteString$CI.originalx,fromByteStringy)header(x,y)=mconcat[x,fromByteString": ",y,fromChar'\n']sfBuildershssffp=mconcat[headersshs,header$(fromByteStringsf,fromStringfp),fromChar'\n',fromByteStringsf,fromByteString" not supported"]bsStep=ContinuebsStep'bsStep'EOF=yield()EOFbsStep'(Chunks[])=continuebsStep'bsStep'(Chunksbss)=liftIO(mapM_outputHbss)>>continuebsStep'builderIter=builderToByteStringbsStepfixHeadersh=caselookup"content-type"hofNothing->("Content-Type","text/html; charset=utf-8"):hJust_->hcleanupVarName::String->CI.CIB.ByteStringcleanupVarName"CONTENT_TYPE"="Content-Type"cleanupVarName"CONTENT_LENGTH"="Content-Length"cleanupVarName"SCRIPT_NAME"="CGI-Script-Name"cleanupVarNames=casesof'H':'T':'T':'P':'_':a:as->String.fromString$a:helper'as_->String.fromStrings-- FIXME remove?wherehelper'('_':x:rest)='-':x:helper'resthelper'(x:rest)=toLowerx:helper'resthelper'[]=[]requestBodyHandle::Handle->Int->EnumeratorB.ByteStringIOarequestBodyHandleh=requestBodyFuncgowheregoi=Just`fmap`B.hGeth(minidefaultChunkSize)requestBodyFunc::(Int->IO(MaybeB.ByteString))->Int->EnumeratorB.ByteStringIOarequestBodyFunc_0step=returnIsteprequestBodyFunchlen(Continuek)=dombs<-liftIO$hlencasembsofNothing->continuekJustbs->doletnewLen=len-B.lengthbsk(Chunks[bs])>>==requestBodyFunchnewLenrequestBodyFunc__step=returnIstep