implementation module CLPM.Util

import StdEnv

import TCPIP

import Control.Applicative
import Control.Monad

import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
import Data.Tuple

import Internet.HTTP

import System.Directory
import System.File
import System.FilePath

from Text import instance + String

TIMEOUT :== Just 10000

instance Parse Int
where
	Parse [] = Error "Empty string for Int."
	Parse cs
	| all isDigit cs = Ok $ toInt $ toString cs
	| otherwise = Error "Unexpected character in Int."

instance Parse (Maybe Int)
where
	Parse ['?'] = Ok $ Nothing
	Parse cs = Just <$> Parse cs

parse :: (String -> MaybeErrorString a) | Parse a
parse = Parse o fromString

doRequest :: HTTPRequest *World -> *(MaybeErrorString HTTPResponse, *World)
doRequest req w
# (ip,w) = lookupIPAddress server_name w
| isNothing ip
	= (Error $ "DNS lookup for " + server_name + " failed.", w)
# (Just ip) = ip
# (rpt,chan,w) = connectTCP_MT TIMEOUT (ip, req.server_port) w
| rpt == TR_Expired
	= (Error $ "Connection to " + server_name + " timed out.", w)
| rpt == TR_NoSuccess
	= (Error $ "Could not connect to " + server_name + ".", w)
# (Just {sChannel,rChannel}) = chan
# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq req) sChannel w
| rpt <> TR_Success
	= (Error $ "Could not send request to " + server_name + ".", w)
# (rpt,resp,rChannel,w) = receive_MT TIMEOUT rChannel w
| rpt <> TR_Success
	= (Error $ "Did not receive a reply from " + server_name + ".", w)
# resp = join $ parseResponse <$> toString <$> resp
| isNothing resp
	# w = closeChannel sChannel (closeRChannel rChannel w)
	= (Error $ "Server did not respond with HTTP.", w)
# (resp,rChannel,w) = receiveRest (fromJust resp) rChannel w
# w = closeChannel sChannel (closeRChannel rChannel w)
= (resp,w)
where
	server_name = req.server_name

	/*receiveRest :: HTTPResponse !*(ch .a) !*env
		-> *(MaybeErrorString HTTPResponse, !*(ch .a), !*env)
		| Receive ch & ChannelEnv env*/
	receiveRest resp chan w
	# cl = lookup "Content-Length" resp.HTTPResponse.rsp_headers
	| isNothing cl
		= (Ok resp, chan, w)
	| size resp.rsp_data >= toInt (fromJust cl)
		= (Ok resp, chan, w)
	# (rpt,newresp,chan,w) = receive_MT TIMEOUT chan w
	| rpt <> TR_Success
		= (Error $ server_name + " hung up during transmission.", chan, w)
	= receiveRest {resp & rsp_data=resp.rsp_data + toString (fromJust newresp)} chan w

syscall :: !String !*World -> *(!Int, !*World)
syscall cmd w = code {
	ccall system "s:I:A"
}

recursivelyRemove :: !FilePath !*World -> *(MaybeErrorString (), !*World)
recursivelyRemove fp w
| isMember (last $ takeWhile ((<>) "") $ iterate (snd o splitFileName) fp)
	[".", ".."] = (Ok (), w)
# (inf,w) = getFileInfo fp w
| isError inf = cast (inf, w)
| not (fromOk inf).directory = cast $ deleteFile fp w
# (fps,w) = readDirectory fp w
| isError fps = cast (fps,w)
# (rem,w) = appFst sequence $
	seqList (map (recursivelyRemove o ((</>) fp)) (fromOk fps)) w
| isError rem = (Error $ fromError rem,w)
= cast $ removeDirectory fp w
where
	cast :: (MaybeOSError a, *World) -> (MaybeErrorString (), *World)
	cast (Error e, w) = (Error $ snd e, w)
	cast (Ok _, w)    = (Ok (), w)