module Main where
import Control.Monad.State
import Data.List
import Network
import Network.BSD
import Network.Socket
import qualified Data.Map as M
import Data.Char
import System.IO
import qualified System.IO.Error as I
import Foreign.Marshal.Alloc
import Control.Concurrent
import System.Time
import System.Process
import System.Posix.IO
import System.Directory
path="/Users/refugee/public_html"
port=1234
hV="rephttpd/0.1"
hP=hPutStr
r=reverse
c=concat
fI=fromIntegral
type S=String
fD x s=M.findWithDefault""x$hd s
data ParserState = ParserState {
	met::S,
	loc::S,
	hd::M.Map S S,
	ver::S,
	err::Int,
	cH::HostName
}
eS = ParserState""""M.empty""0""
pH x=case(last$head$words x)of
	':'->pHd x
	_->pMd x
pHd x=get>>= \s->put$s{hd=M.insert k v(hd s)}
	where 
	(y:ys)=words x
	k=r$tail$r y
	v=filter(/='\r')$c ys
pMd x=pM'(words x)
	where
	pM'(m:l:v:[])=get>>= \s->put$s{met=m,loc=l,ver=v}
	pM' _=get>>= \s->put$s{err=400}
sCH h=getClockTime>>=toCalendarTime>>=hP h.("Date: "++).calendarTimeToString>>(hP h$"Server: "++hV++"\r\n")
pR h s=do
	name<-rN""sg
	case name of
		Just x->I.try(openFile(fst x)ReadMode)>>=either(sE h s.eC)(pM h s x)
		Nothing->sE h s 404
	where
	sg=sp"/"fn
	rN l[]=return$Just(l,"")
	rN l("":xs)=rN l xs
	rN l(x:xs)=do
		dE<-doesDirectoryExist f
		if dE==True then rN f xs else do
			fileExists<-doesFileExist f
			if fileExists==True then return$Just(f,c$intersperse"/"xs)	else return$Nothing
        	where f=c[l,"/",x]
	loc'=takeWhile(/='?')$loc s
	fn=case loc' of
		"/"->path++"/index.html"
		_->path++loc'
	eC e
		|I.isDoesNotExistError e=404
		|I.isPermissionError e=403
		|otherwise=501
pM h s file h2=case(cT$fst file)of
		"cgi-script"->dC h s file
		_->case(met s)of
			"GET"->sF h s h2
			"HEAD"->sH h s h2
			_->sE h s 501
sp g xs=s' xs
	where
	s'[]=[]
	s' xs'=p:s'(dG r)
		where
		(p,r)=bOG g xs'
		dG=drop(length g)
bOG _[]=([],[])
bOG g r@(x:y)
	|isPrefixOf g r=([],r)
	|otherwise=(x:p,r')
        where (p,r')=bOG g y
dC h s f=do
	hP h"HTTP/1.1 200 OK\r\n"
	sCH h
	hFlush h
	(sR,sW)<-createPipe
	r<-fdToHandle sR
	w<-fdToHandle sW
	ptr<-mallocBytes$fI len
	hGetBuf h ptr$fI len
	putStrLn$snd f
	id<-runProcess(fst f)args(Just dir)(Just$c[env"127.0.0.1",hH])(Just r)(Just h)Nothing
	hPutBuf w ptr$fI len
	free ptr
	hClose w
	waitForProcess id
	return()
	where 
	len
		|cT'==""=0::Integer
		|otherwise=read cL
	dir=r$tail$dropWhile(/='/')$r$fst f
	cL=fD"Content-Length"s
	cT'=fD"Content-Type"s
	sH=takeWhile(/= ':')$fD"Host"s
	sP=tail$dropWhile(/= ':')$fD"Host"s
	hH=map(\(x,y)->("HTTP_"++map toUpper x,y))$M.toList$hd s
	q'=dropWhile(/= '?')$loc s
	q=if q'/=""then tail q' else""
	args=if elem '='q then[]else sp"+"q
	env hst=[("SERVER_SOFTWARE",hV),
		("SERVER_NAME",sH),
		("GATEWAY_INTERFACE","CGI/1.1"),
		("SERVER_PROTOCOL",ver s),
		("SERVER_PORT",sP),
		("REQUEST_METHOD",met s),
		("PATH_INFO","/"++snd f),
		("PATH_TRANSLATED",fst f),
		("SCRIPT_NAME",takeWhile(/= '?')$loc s),
		("QUERY_STRING",q),
		("REMOTE_ADDR",hst),
		("CONTENT_TYPE",cT'),
		("CONTENT_LENGTH",cL)]
sH h s h2=do
	size<-hFileSize h2
	hP h"HTTP/1.1 200 OK\r\n"
	sCH h
	hP h$"Content-Length: "++(show size)++"\r\n"
	hP h$"Content-Type: "++cT(loc s)++"\r\n"
	hP h"\r\n"
cT s=case s of
		_:".jpg"->"image/JPEG"
		_:".pdf"->"application/pdf"
		_:".cgi"->"cgi-script"
		_:".pl"->"cgi-script"
		_->"text/html"
sF h s h2=do
	z<-hFileSize h2
	allocaBytes(fI z)$ \p->hGetBuf h2 p(fI z)>>sH h s h2>>hPutBuf h p(fI z)
sE h s n=do
	hP h$"HTTP/1.1 "++(show n)++" Not Found\r\n"
	sCH h
	hP h"Content-Type: text/html; charset=iso-8859-1\r\n\r\n"
	hP h$"ERROR "++(show n)++"\r\n"
	hClose h
pC h=do
	t<-lift$catch(hGetLine h)(const$return"")
	case t of
		"\r"->do
			s<-get
			lift$pR h s
			(lift$I.try$hFlush h)>>=either(const$return())(const $ k s)
			where
			k s=case(fD "Connection" s)of
				"close"->lift$hClose h
				"keep-alive"->put eS>>pC h
				_->lift$hClose h
		""->return()
		_->do
			pH t
			s<-get
			if(err s/=0)then lift$sE h s$err s else pC h
mainLoop s=do
	(h,hs,p)<-Network.accept s
	forkOS$evalStateT(pC h)$eS{cH=hs}
	mainLoop s
main=listenOn(PortNumber port)>>=mainLoop