#!/usr/bin/runhaskell

import Network
import Data.Char
import IO
import System.Timeout
import Directory

repo = "repo"
fn x = repo ++ "/" ++ x
port = 12345

split p a = s1 a where
	s1 (x:xs) | not$p x = s2 xs [x]
	s1 (x:xs) = s1 xs
	s1 [] = []
	s2 (x:xs) c | p x = reverse c : s1 xs
	s2 (x:xs) c = s2 xs (x:c)
	s2 [] c = [reverse c]

tr s = case reads s of
	[] -> Nothing
	((x, _):_) -> Just x

fl = (foldl step 0) . lines
	where	step x ('+':_) = x + 1
		step x ('-':_) = x - 1
		step x _ = x

change file pos char = do
	f <- readFile file
	if fl f > pos
		then appendFile file ("*" ++ show pos ++ ' ':char:[] ++ "\n") >> return True
		else return False

fold (Just x) str | x >= 0 && x <= (length $ lines str) = '+' : foldl step "" (take x (lines str))
	where	step x ('+':c:[]) = x ++ [c]
		step x ('-':_) = tail x
		step x ('*':str) = let
			ps = split isSpace str
			pos = read (ps!!0)
			c = last (ps!!1) in
				take pos x ++ [c] ++ drop (pos + 1) x

fold Nothing str = fold (Just (length $ lines str)) str

fold _ _ = "-"

h _ = return ()

main = let f s = do
		(handle, host, _) <- accept s
		do
			res <- timeout 5000000 (inter handle)
			case res of
				Nothing -> hPutStrLn handle "time is out"
				Just socket -> return ()
			hClose handle `catch` h
		f s
	in listenOn (PortNumber port) >>= f

inter handle = do
	hSetBuffering handle LineBuffering
	ls <- hGetContents handle `catch` \_ -> return ""
	mapM_ (process1 handle) (lines ls) `catch` h
	return handle

process1 h cmd = process h cmd `catch` \e -> hPutStrLn h "-"

process h "l" =
	getDirectoryContents repo >>=
	(hPutStr h) .
	(foldl (++) "") .
	(map (++"\n")) .
	(filter (\x -> x /= ".." && x /= "."))

process h ('+':str) = let (file,chars) = break isSpace str in
	appendFile (fn file) ("+" ++ [last chars] ++ "\n") >> hPutStrLn h "+"

process h ('-':str) = let (file,chars) = break isSpace str in do
	f <- readFile (fn file)
	if fl f > 0
		then appendFile (fn file) ("-" ++ [last chars] ++ "\n") >> hPutStrLn h "+"
		else hPutStrLn h "-"

process h ('*':str) = case split isSpace str of
	(file:pos:chars:[]) -> case tr pos of
		Just rev -> change (fn file) rev (last chars) >>= \x -> hPutStrLn h (if x then "+" else "-")
		Nothing -> hPutStrLn h "-"
	_ -> hPutStrLn h "-"

process h other = let (file, revision) = break isSpace other in do
	ans <- (openFile (fn file) ReadMode >>= hGetContents >>= return . (fold (tr revision)))
	hPutStrLn h ans