{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Webdriver(serveWebdriver) where

import Happstack.Lite
import Control.Concurrent.MVar
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
import Data.ByteString.Lazy (ByteString)

import qualified Data.HashMap.Strict as M
import Data.UUID as ID
import Data.UUID.V4

import Control.Monad.IO.Class (liftIO)
import Control.Monad (mapM)
import Data.Maybe (fromMaybe, isJust)

import qualified Network.URI as URI
import qualified Network.URI.Fetch as URI
import qualified Text.XML.Cursor as XC

import Capabilities (processCaps)
import JSON
import qualified Internal as WD
import qualified Internal.Load as WD
import qualified Internal.Elements as WDE

serveWebdriver :: WD.Sessions -> ServerPart Response
serveWebdriver sessions = do
  msum [
      dir "status" serveStatus,
      dir "session" $ postSession sessions,
      dir "session" $ path $ serveSession sessions,
      nullDir >> ok (toResponse ("This is a WebDriver endpoint. Please copy the URL to hand to Selenium." :: Text))
    ]
serveSession :: WD.Sessions -> String -> ServerPart Response
serveSession sessions = WD.withSession fail (\uuid session -> msum [
        delSession sessions uuid,
        dir "timeouts" $ getTimeout session,
        dir "timeouts" $ setTimeout session,
        dir "url" $ navigateTo session,
        dir "url" $ getURL session,
        dir "refresh" $ reloadPage session,
        dir "back" $ sessionAction WD.back session,
        dir "forward" $ sessionAction WD.next session,
        dir "title" $ sessionTitle session,
        dir "window" $ msum [ -- Noops
            getWindowHandle uuid,
            delSession sessions uuid, -- Closing the only window closes the session.
            switchWindowHandle uuid,
            dir "handles" $ getWindowHandles uuid,
            dir "rect" $ unsupportedOp,
            dir "maximize" $ unsupportedOp,
            dir "minimize" $ unsupportedOp,
            dir "fullscreen" $ unsupportedOp
        ],
        dir "frame" $ msum [noSuchFrame, dir "parent" $ ok $ toResponse ()], -- Noops
        dir "elements" $ findFromRoot session
    ]) sessions
  where
    fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ (
        "Session " ++ uuid' ++ " was not found in active sessions")
        | otherwise = errJSON 404 "invalid session ID" $ ("UUID " ++ uuid' ++ " is not a valid UUID")

data Status = Status {ready :: Bool, message :: Text} deriving Generic
instance ToJSON Status
serveStatus = okJSON $ Status True "Always ready to open new sessions"

data NewSession = NewSession {sessionId :: UUID, capabilities :: Object} deriving Generic
instance ToJSON NewSession
postSession sessions = do
    method POST
    nullDir
    caps' <- getJSON
    case processCaps caps' of
        Just caps -> do
            (uuid, _) <- liftIO $ WD.createSession sessions caps
            okJSON $ NewSession uuid caps
        Nothing -> errJSON 500 "session not created" "Invalid capabilities specified!"

delSession sessions uuid = do
    method DELETE
    nullDir
    liftIO $ WD.delSession uuid sessions
    ok $ toResponse ()

getTimeout session = do
    method GET
    nullDir
    session' <- liftIO $ readMVar session
    okJSON $ WD.timeouts session'

setTimeout session = do
    method POST
    nullDir
    update' <- getJSON
    session' <- liftIO $ readMVar session
    case update' of
        Just (Object update) | Object current <- toJSON $ WD.timeouts session',
                Success new <- fromJSON $ toJSON $ M.union update current -> do
            liftIO $ swapMVar session session' {WD.timeouts = new}
            ok $ toResponse ()
        _ -> errJSON 400 "invalid argument" "Failed to parse JSON input"

data NavigateTo = NavigateTo { url :: String } deriving Generic
instance FromJSON NavigateTo
navigateTo session = do
    method POST
    nullDir
    target' <- getJSON
    case target' of
        Just target | Just url' <- URI.parseAbsoluteURI target -> do
            liftIO $ WD.load session url'
            ok $ toResponse ()
        Just target -> errJSON 400 "invalid argument" (target ++ " is not an absolute URL")
        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input"

getURL session = do
    method GET
    nullDir
    session' <- liftIO $ readMVar session
    ok $ toResponse $ show $ WD.currentURL session'

reloadPage session = do
    method POST
    nullDir
    session' <- liftIO $ readMVar session
    liftIO $ WD.load' session $ WD.currentURL session'
    ok $ toResponse ()

sessionAction cb session = do
    method POST
    nullDir
    liftIO $ cb session
    ok $ toResponse ()

sessionTitle session = do
    method GET
    nullDir
    ret <- liftIO $ WDE.getTitle session
    ok $ toResponse ret

---- Windowing noops
getWindowHandle uuid = do
    method GET
    nullDir
    ok $ toResponse ("window-" ++ ID.toString uuid)

data WindowHandle = WindowHandle { handle :: String } deriving Generic
instance FromJSON WindowHandle
switchWindowHandle uuid = do
    method POST
    nullDir
    handle <- getJSON
    case handle of
        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input"
        Just (WindowHandle handle') | handle' /= "window-" ++ ID.toString uuid ->
            errJSON 404 "no such window" "Rhapsode isn't a multi-window or multi-tab browser"
        _ -> ok $ toResponse ()

getWindowHandles uuid = do
    method GET
    nullDir
    okJSON ["window-" ++ ID.toString uuid]

noSuchFrame = do
    method POST
    nullDir
    errJSON 404 "no such frame" "Rhapsode doesn't support frames"

unsupportedOp = do
    nullDir
    errJSON 400 "unsupported operation" "Windowsize is meaningless to Rhapsode"

----

findFromRoot session = do
    method POST
    nullDir
    req <- getJSON
    session' <- liftIO $ readMVar session
    case req of
        Just req' -> case WDE.find req' $ XC.fromDocument $ WD.document session' of
            Right res -> okJSON =<< mapM (liftIO . WD.serializeEl session) res
            Left (True, msg) -> errJSON 400 "invalid selector" msg
            Left (False, msg) -> errJSON 400 "invalid argument" msg
        Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"