GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-03 00:02:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

RunHTTP.hs: remove hardcoded document root

Browse Source 
The document root is now part of the arguments passed to runHTTP.
This commit is contained in:
hallgren
2010-12-17 16:33:54 +00:00
parent c51d1f9833
commit 7ebdacc884
1 changed files with 7 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src/server/RunHTTP.hs
View File

@@ -1,4 +1,4 @@
module RunHTTP(runHTTP) where module RunHTTP(runHTTP,Options(..)) where
import Network.URI(uriPath,uriQuery) import Network.URI(uriPath,uriQuery)
import Network.CGI(ContentType(..)) import Network.CGI(ContentType(..))
import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..), import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
@@ -8,11 +8,11 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments)
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack) import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack)
import qualified Data.Map as M(fromList) import qualified Data.Map as M(fromList)
documentRoot = "www" data Options = Options { documentRoot :: String, port :: Int } deriving Show
runHTTP port = initServer port . cgiHandler runHTTP (Options root port) = initServer port . cgiHandler root
cgiHandler h = fmap httpResp . runCGIT h . cgiReq cgiHandler root h = fmap httpResp . runCGIT h . cgiReq root
httpResp :: (Headers,CGIResult) -> Response httpResp :: (Headers,CGIResult) -> Response
httpResp (hdrs,r) = Response code (map name hdrs) (body r) httpResp (hdrs,r) = Response code (map name hdrs) (body r)
@@ -23,12 +23,12 @@ httpResp (hdrs,r) = Response code (map name hdrs) (body r)
name (HeaderName n,v) = (n,v) name (HeaderName n,v) = (n,v)
cgiReq :: Request -> CGIRequest cgiReq :: String -> Request -> CGIRequest
cgiReq (Request method uri hdrs body) = CGIRequest vars inputs body' cgiReq root (Request method uri hdrs body) = CGIRequest vars inputs body'
where where
vars = M.fromList [("REQUEST_METHOD",method), vars = M.fromList [("REQUEST_METHOD",method),
("REQUEST_URI",show uri), ("REQUEST_URI",show uri),
("SCRIPT_FILENAME",documentRoot++uriPath uri), ("SCRIPT_FILENAME",root++uriPath uri),
("QUERY_STRING",qs), ("QUERY_STRING",qs),
("HTTP_ACCEPT_LANGUAGE",al)] ("HTTP_ACCEPT_LANGUAGE",al)]
qs = case uriQuery uri of qs = case uriQuery uri of