abuiles · May 26, 2009 14:42
diff --git a/gistfile1.hs b/gistfile1.hs
 import Network
 import Network.HTTP
 import Network.HTTP.Base
 import Network.URI
 import System.IO
 import Text.Regex
 import Data.Maybe
 import System.Directory (doesFileExist)
 import System.FilePath.Posix (takeExtensions)


 main = do
  putStrLn "Starting Server"
  server

 methodNotImplementedRsp = Response {rspCode = (5,0,1) ,
                                    rspReason = "Not Implemented" ,
                                    rspHeaders = [Header HdrConnection "close",
                                                  Header HdrContentType "test/html; charset=ISO-8859-1"
                                                  ],
                                    rspBody = ""}    

 htmlNotImplemented = "<html><head><title>Not Implemented</title></head><body><H1>Your method is not supported by this server</H1></body></html>"

 notFoundRsp = Response {rspCode = (4,0,4) ,
                        rspReason = "Not Found" ,
                        rspHeaders = [Header HdrConnection "close",
                                      Header HdrContentType "test/html; charset=ISO-8859-1"] ,
                        rspBody = htmlNotFound}

 methodGETRsp = Response {rspCode = (2,0,0) , rspReason = "OK" , rspHeaders = [Header HdrConnection "close",Header HdrServer "minihserver-0.1"] ,rspBody = "" }

 htmlNotFound = "<html><head><title>Not Found</title></head><body><H1>Page not founded</H1></body></html>"

 doGetHead req hdl mtd = do fileExist <- doesFileExist ( "." ++  (filePath) )                    
                           if fileExist 
                            then do                             
                                   doResp                   
                            else
                               hPutStr hdl (show notFoundRsp )
                    
    where
      filePath  =  uriPath$rqURI req
      doResp = do file <- readFile ("."++ ( filePath ))                                    
                  let resp  =  methodGETRsp { rspHeaders = (rspHeaders methodGETRsp) ++ 
                                                                       [Header HdrContentLength (show (length file)),
                                                                        Header HdrContentType "text/html"],
                                              rspBody = file }
                  case takeExtensions filePath of
                     ".html" -> do  let resp2 = resp { rspHeaders = (rspHeaders resp) ++ [Header HdrContentType "text/html"] }                                     
                                    case mtd of
                                      GET -> hPutStr hdl (show (resp2) ++ rspBody resp2)
                                      HEAD -> hPutStr hdl (show (resp2))
                                    
                     _ -> do let resp2 =  resp { rspHeaders = (rspHeaders resp) ++ [Header HdrContentType "text/plain; charset=utf-8"] }
                             case mtd of
                               GET -> hPutStr hdl (show (resp2) ++ rspBody resp2)
                               HEAD -> hPutStr hdl (show (resp2))
                              

          
 defaultPort = 8080
 --2293457
 server =  {-# SCC "Main" #-} do 
  socket <- listenOn $ PortNumber defaultPort
  (hdl,hostName,portNumber) <- accept socket  
  putStrLn $ " Request Accepted from " ++ hostName       
  content <- getReqMessage hdl ""  
  let reqMessage = parseReqMess content  
  putStrLn "reqParsed"  
  let req = (fromJust( reqMessage))
  putStrLn.show$req
  --putStrLn "reqPar"
  case (rqMethod req) of
    GET  -> doGetHead req hdl GET
    HEAD -> doGetHead req hdl HEAD
    _    -> hPutStr hdl (show (methodNotImplementedRsp) ++ rspBody methodNotImplementedRsp )
  sClose socket
  hClose hdl  
  return "Done"





 -- Get the request message from the handle receive when accepting a new connection
 getReqMessage :: Handle -> String -> IO String
 getReqMessage hdl msg  = do noEOF <- hReady hdl
                            if noEOF 
                             then do 
                              ch <- hGetChar hdl
                              getReqMessage hdl (msg ++ [ch])
                             else
                                return msg
                        
                  


 --

 parseReqMess rqm = let reqMsg = splitRegex (mkRegex "(\r\n)(\r\n)?") rqm
                       reqH =  parseRequestHead reqMsg
                   in
                     case reqH of
                       Right (reqMeth,uri,hdrs) ->  let req = Request{rqURI = uri, rqMethod = reqMeth , rqHeaders = hdrs , rqBody = ""}
                                                    in if (findHeader HdrContentLength req /= Nothing) ||  (findHeader HdrTransferEncoding req /= Nothing) 
                                                       then
                                                            Just req{rqBody = last reqMsg}
                                                       else
                                                           Just  req
                       Left _ -> Nothing
	import Network
	import Network.HTTP
	import Network.HTTP.Base
	import Network.URI
	import System.IO
	import Text.Regex
	import Data.Maybe
	import System.Directory (doesFileExist)
	import System.FilePath.Posix (takeExtensions)


	main = do
	putStrLn "Starting Server"
	server

	methodNotImplementedRsp = Response {rspCode = (5,0,1) ,
	rspReason = "Not Implemented" ,
	rspHeaders = [Header HdrConnection "close",
	Header HdrContentType "test/html; charset=ISO-8859-1"
	],
	rspBody = ""}

	htmlNotImplemented = "<html><head><title>Not Implemented</title></head><body><H1>Your method is not supported by this server</H1></body></html>"

	notFoundRsp = Response {rspCode = (4,0,4) ,
	rspReason = "Not Found" ,
	rspHeaders = [Header HdrConnection "close",
	Header HdrContentType "test/html; charset=ISO-8859-1"] ,
	rspBody = htmlNotFound}

	methodGETRsp = Response {rspCode = (2,0,0) , rspReason = "OK" , rspHeaders = [Header HdrConnection "close",Header HdrServer "minihserver-0.1"] ,rspBody = "" }

	htmlNotFound = "<html><head><title>Not Found</title></head><body><H1>Page not founded</H1></body></html>"

	doGetHead req hdl mtd = do fileExist <- doesFileExist ( "." ++ (filePath) )
	if fileExist
	then do
	doResp
	else
	hPutStr hdl (show notFoundRsp )

	where
	filePath = uriPath$rqURI req
	doResp = do file <- readFile ("."++ ( filePath ))
	let resp = methodGETRsp { rspHeaders = (rspHeaders methodGETRsp) ++
	[Header HdrContentLength (show (length file)),
	Header HdrContentType "text/html"],
	rspBody = file }
	case takeExtensions filePath of
	".html" -> do let resp2 = resp { rspHeaders = (rspHeaders resp) ++ [Header HdrContentType "text/html"] }
	case mtd of
	GET -> hPutStr hdl (show (resp2) ++ rspBody resp2)
	HEAD -> hPutStr hdl (show (resp2))

	_ -> do let resp2 = resp { rspHeaders = (rspHeaders resp) ++ [Header HdrContentType "text/plain; charset=utf-8"] }
	case mtd of
	GET -> hPutStr hdl (show (resp2) ++ rspBody resp2)
	HEAD -> hPutStr hdl (show (resp2))



	defaultPort = 8080
	--2293457
	server = {-# SCC "Main" #-} do
	socket <- listenOn $ PortNumber defaultPort
	(hdl,hostName,portNumber) <- accept socket
	putStrLn $ " Request Accepted from " ++ hostName
	content <- getReqMessage hdl ""
	let reqMessage = parseReqMess content
	putStrLn "reqParsed"
	let req = (fromJust( reqMessage))
	putStrLn.show$req
	--putStrLn "reqPar"
	case (rqMethod req) of
	GET -> doGetHead req hdl GET
	HEAD -> doGetHead req hdl HEAD
	_ -> hPutStr hdl (show (methodNotImplementedRsp) ++ rspBody methodNotImplementedRsp )
	sClose socket
	hClose hdl
	return "Done"





	-- Get the request message from the handle receive when accepting a new connection
	getReqMessage :: Handle -> String -> IO String
	getReqMessage hdl msg = do noEOF <- hReady hdl
	if noEOF
	then do
	ch <- hGetChar hdl
	getReqMessage hdl (msg ++ [ch])
	else
	return msg




	--

	parseReqMess rqm = let reqMsg = splitRegex (mkRegex "(\r\n)(\r\n)?") rqm
	reqH = parseRequestHead reqMsg
	in
	case reqH of
	Right (reqMeth,uri,hdrs) -> let req = Request{rqURI = uri, rqMethod = reqMeth , rqHeaders = hdrs , rqBody = ""}
	in if (findHeader HdrContentLength req /= Nothing) \|\| (findHeader HdrTransferEncoding req /= Nothing)
	then
	Just req{rqBody = last reqMsg}
	else
	Just req
	Left _ -> Nothing