implementation module iTasks.Testing.Selenium

import StdEnv

import ABC.Interpreter

from Data.Func import $, mapSt
import qualified Data.Map as Map
import Data.Map.GenJSON
import Data.Queue
import Data.Set.GenJSON
import System.CommandLine
import System.Directory
import System.File
import System.Options
import Testing.TestEvents
from Text import class Text(concat,split), instance Text String
import Text.Encodings.Base64

import iTasks
import iTasks.Internal.IWorld
import iTasks.Internal.Task
import iTasks.Internal.TaskEval
import iTasks.Internal.TaskIO
import iTasks.Internal.Util
import iTasks.Testing.Selenium.Interface

gEditor{|PrelinkedInterpretationEnvironment|} _ = abort "gEditor{|PrelinkedInterpretationEnvironment|}\n"
gText{|PrelinkedInterpretationEnvironment|} _ _ = ["PrelinkedInterpretationEnvironment"]
JSONEncode{|PrelinkedInterpretationEnvironment|} _ _ = [JSONError]
JSONDecode{|PrelinkedInterpretationEnvironment|} _ j = (?None,j)
gEq{|PrelinkedInterpretationEnvironment|} _ _ = False

derive class iTask EndEventType, Expression
derive class iTask \ JSONEncode, JSONDecode TestEvent, StartEvent, EndEvent, TestLocation, FailReason, CounterExample, FailedAssertion, Relation

derive class iTask Queue, Event, QueuedEvent
derive class iTask \ gEq, JSONEncode, JSONDecode, gText [!!]

:: TestStatus =
	{ tcpQueue      :: !String
	, queue         :: ![DriverCommand]
	, waitRequested :: ![InstanceNo]
	, testEvents    :: ![TestEvent]
	, eventsPassedToQueue :: !Int
	, screenshots   :: !'Map'.Map String String //* A map from filename to PNG data
	}

derive class iTask TestStatus

:: DriverCommand
	= ByteCode !String
	| ExecuteFunction !String //* Execute a function (base64-encoded serialized bytecode)
	| TaskIsIdle !InstanceNo  //* Response to WaitForIdle

:: DriverResponse
	= WaitForIdle !InstanceNo          //* Wait for a task to become idle (have no events in the queue)
	| OK                               //* Driver is ready for next message
	| StartTest !String                //* startTest in iTasks.Testing.EndToEnd.Interface
	| FinishTest !String !Bool !String //* finishTest in iTasks.Testing.EndToEnd.Interface
	| Screenshot !String !String       //* Filename and base64-encoded PNG image
	| Close

derive class iTask DriverCommand, DriverResponse

instance tune TestProperty (Task a)
where
	tune p t = t <<@ testPropertyToUIAttribute p

testPropertyToUIAttribute :: !TestProperty -> UIAttribute
testPropertyToUIAttribute p = case p of
	Name n -> (attr "name", JSONString n)
where
	attr :: !String -> String
	attr a = "selenium-"+++a

runTest :: !TestOptions !TestSpec !(sds () (Queue TestEvent) (Queue TestEvent)) -> Task [TestEvent] | RWShared sds
runTest {browser,screenshotsDir,clientOptions} spec event_queue_sds =
	get applicationURL >>- \url ->
	mkInstantTask (\_ iworld=:{options,abcInterpreterEnv} -> (Ok (options,abcInterpreterEnv), iworld)) >>- \(options,abc_env) ->
	accWorld (read_bytecode options.byteCodePath) >>- \bytecode ->
	let
		testMonad = withWebDriver browser clientOptions options.appName url (spec url)
		serialized = base64Encode $ serialize_for_prelinked_interpretation
			(wrapInitFunction \me w -> snd $ runJS (newTestState clientOptions) me testMonad w) abc_env
	in
	withShared {tcpQueue="", queue=[], waitRequested=[], testEvents=[], eventsPassedToQueue=0, screenshots='Map'.newMap} \share ->
	handleResponses share ||-
	tcpconnect "127.0.0.1" 8081 (?Just 5000) share
		{ ConnectionHandlers
		| onConnect     = \_ _ _ -> (Ok [ByteCode bytecode,ExecuteFunction serialized],?None,[toString (size bytecode)],False)
		, onData        = onData
		, onDisconnect  = \l _ -> (Ok l, ?None)
		, onShareChange = onShareChange
		, onDestroy     = \s -> (Ok s, [])
		} >-|
	get share >>- \{testEvents,screenshots} ->
	storeScreenshots screenshotsDir ('Map'.toList screenshots) >-|
	return (reverse testEvents)
where
	read_bytecode path w
		# path = path % (0,size path-3) +++ "pbc"
		# (Ok contents,w) = readFile path w
		= (contents,w)

	onData data local_queue status = case split "\n" data of
		[data]
			-> (Ok local_queue,?Just {status & tcpQueue=status.tcpQueue+++data},[],False)
		[data:rest]
			# data = status.tcpQueue+++data
			  status & tcpQueue = last rest
			  rest = init rest
			# (msgs,mbSt) = mapSt handle [data:rest] (Ok (local_queue,status,False))
			| isError mbSt
				-> (Error (fromError mbSt),?Just status,[],False)
				# (local_queue,status,stop) = fromOk mbSt
				-> (Ok local_queue,?Just status,catMaybes msgs,stop)
	where
		handle _ e=:(Error _) = (?None, e)
		handle msg (Ok (local_queue,status,stop)) = case fromJSON $ fromString msg of
			?None -> (?None, Error ("Illegal response from driver: "+++msg))
			?Just msg -> case msg of
				WaitForIdle no
					-> (?None, Ok (local_queue,{status & waitRequested=[no:status.waitRequested]},stop))
				StartTest name
					-> (?None, Ok (local_queue,{status & testEvents=[event:status.testEvents]},stop))
						with event = StartEvent {StartEvent | name=name,location= ?None}
				FinishTest name True _
					-> (?None, Ok (local_queue,{status & testEvents=[event:status.testEvents]},stop))
						with event = EndEvent {name=name,location= ?None,event=Passed,message="",time= ?None}
				FinishTest name False reason
					-> (?None, Ok (local_queue,{status & testEvents=[event:status.testEvents]},stop))
						with event = EndEvent {name=name,location= ?None,event=Failed (?Just $ CustomFailReason reason),message="",time= ?None}
				Screenshot filename png
					-> (?None, Ok (local_queue,{status & screenshots='Map'.put filename (base64Decode png) status.screenshots},False))
				OK
					-> case local_queue of
						[]     -> (?None,Ok (local_queue,status,stop))
						[m:ms] -> case m of
							ByteCode bc -> (?Just bc,Ok (ms,status,stop))
							_           -> (?Just (toString $ toJSON m),Ok (ms,status,stop))
				Close
					-> (?None, Ok (local_queue,status,True))

	onShareChange local status = case status.queue of
		[]     -> (Ok local,?None,[],False)
		[m:ms] -> case local of
			[] -> (Ok ms,?Just {status & queue=[]},[toString $ toJSON m],False)
			_  -> (Ok (local++status.queue), ?Just {status & queue=[]},[],False)

	handleResponses :: (SimpleSDSLens TestStatus) -> Task ()
	handleResponses share = watch share >>*
		[ OnValue $ ifValue (\s -> s.waitRequested=:[_:_]) \{waitRequested} ->
			get (taskEvents |*| allTaskInstances) >>- \(queue,timeta) ->
			let active_instance_nos = [instanceNo \\ {QueuedEvent|instanceNo} <- toList queue] in
			allTasks
				[checkInstanceNo no timeta
					@! if (isMember no active_instance_nos) ?None (?Just no)
					\\ no <- waitRequested]
				>>- \idle ->
			let idle_instance_nos = catMaybes idle in
			upd (\status ->
					{ status
					& waitRequested = filter (\x -> not $ isMember x idle_instance_nos) status.waitRequested
					, queue = status.queue ++ [TaskIsIdle no \\ no <- idle_instance_nos]
					}) share >-|
			handleResponses share
		, OnValue $ ifValue (\s -> s.eventsPassedToQueue < length s.testEvents) \{eventsPassedToQueue,testEvents} ->
			upd (\q -> foldr enqueue q (take (length testEvents - eventsPassedToQueue) testEvents)) (event_queue_sds) >-|
			upd (\s -> {s & eventsPassedToQueue=length testEvents}) share >-|
			handleResponses share
		]
	where
		checkInstanceNo :: !InstanceNo ![TaskInstance] -> Task InstanceNo
		checkInstanceNo no instances = case [i \\ {TaskInstance|instanceNo=i} <- instances | i == no] of
			[m] -> return m
			[]  -> throw ("No active task with InstanceNo '"+++toString no+++"' found")
			_   -> throw ("More than one active task with InstanceNo '"+++toString no+++"' found")

storeScreenshots :: !FilePath ![(String, String)] -> Task ()
storeScreenshots _ [] = return ()
storeScreenshots dir screenshots =
	accWorldOSError (ensureDirectoryExists dir) >-|
	allTasks
	[ accWorldError (writeFile (dir </> filename) png) id
	\\ (filename,png) <- screenshots
	]
	@! ()

runTestSuite :: !TestOptions ![TestedTask] !*World -> *World
runTestSuite _ [] w = w
runTestSuite options [TestedTask task spec:specs] w
	#! w = doTasksWithOptions (\_ engineOptions -> Ok
		(
			( onRequest "/" task
			, onStartup $ withShared newQueue \queue ->
				// Run test and print events coming in while running
				(runTest options spec queue -|| watchEventQueue queue) >>- \events ->
				// Print any remaining events and crash events for started tests without EndEvent
				get queue >>- \q ->
				printEvents (toList q ++ getCrashedEvents [] events) >-|
				shutDown 0
			)
		, {engineOptions & verboseOperation=False}
		)) w
	= runTestSuite options specs w
where
	watchEventQueue :: !(sds () (Queue TestEvent) (Queue TestEvent)) -> Task () | RWShared sds
	watchEventQueue queue = watch queue >>*
		[ OnValue $ ifValue (\q -> not $ empty q) \q ->
			let (?Just event,_) = dequeue q in
			upd (snd o dequeue) queue >-|
			printEvents [event] >-|
			watchEventQueue queue
		]

	printEvents :: ![TestEvent] -> Task ()
	printEvents events = mkInstantTask \_ iw -> (Ok (), show iw)
	where
		show iw=:{world=w}
		# (io,w) = stdio w
		# io     = foldl (\io json -> io <<< json <<< "\n") io [toJSON e \\ e <- events]
		# (_,io) = fflush io
		# (_,w)  = fclose io w
		= {iw & world=w}

	getCrashedEvents :: ![TestEvent] ![TestEvent] -> [TestEvent]
	getCrashedEvents crashes []
		= reverse crashes
	getCrashedEvents crashes [e=:(EndEvent _):es]
		= getCrashedEvents crashes es
	getCrashedEvents crashes [e=:(StartEvent {StartEvent | name=startName,location}):es]
		| any (\e -> case e of EndEvent {EndEvent | name} -> name==startName; _ -> False) es
			= getCrashedEvents crashes es
			= getCrashedEvents [EndEvent end_event:crashes] es
	where
		end_event =
			{ name     = startName
			, location = location
			, event    = Failed (?Just Crashed)
			, message  = ""
			, time     = ?None
			}

runTestSuiteWithCLI :: ![TestedTask] !*World -> *World
runTestSuiteWithCLI tests w
	# ([_:args],w) = getCommandLine w
	# opts = parseOptions options args defaultOptions
	| isError opts
		# err = foldl (\err msg -> err <<< msg <<< "\n") stderr (fromError opts)
		# (_,w) = fclose err w
		= setReturnCode (if (isMember "--help" args) 0 1) w
	# opts = fromOk opts
	= runTestSuite opts tests w
where
	defaultOptions =
		{ browser = Firefox
		, screenshotsDir = "screenshots"
		, clientOptions =
			{ headless                  = False
			, windowSize                = (1920, 1080)
			, timeout                   = 10000
			, screenshotsForFailedTests = False
			}
		}
	options = WithHelp False $ Options
		[ Option "--browser"
			(\browser opts -> case browser of
				"firefox" -> Ok {opts & browser=Firefox}
				"chrome"  -> Ok {opts & browser=Chrome}
				"safari"  -> Ok {opts & browser=Safari}
				"edge"    -> Ok {opts & browser=Edge}
				_         -> Error ["Unknown browser '"+++browser+++"'"])
			"BROWSER"
			"Run with BROWSER (firefox,chrome,safari,edge)"
		, Flag "--headless"
			(\opts -> Ok {TestOptions | opts & clientOptions.headless=True})
			"Run without browser GUI"
		, Option "--window-size"
			(\sz opts -> case map toInt (split "x" sz) of
				[w,h] | w > 0 && h > 0 -> Ok {TestOptions | opts & clientOptions.windowSize=(w,h)}
				_ -> Error ["Invalid --window-size option. Use --window-size WIDTHxHEIGHT with positive integers."])
			"WIDTHxHEIGHT"
			"The window size (used in headless mode)"
		, Option "--screenshots-dir"
			(\dir opts -> Ok {opts & screenshotsDir=dir})
			"DIR"
			"Directory to store screenshots (will be created if it does not exist; default 'screenshots')"
		, Flag "--screenshots-for-failed-tests"
			(\opts -> Ok {TestOptions | opts & clientOptions.screenshotsForFailedTests=True})
			"Automatically create screenshots when tests fail"
		]
