{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Internal(Session(..), Session'(..), Sessions(..),
        initSessions, createSession, delSession, getSession, withSession,
        Timeouts(..), registerEl, serializeEl, getEl, getRelatedEls) where

import qualified Data.HashMap.Strict as M
import Data.UUID as ID
import Data.UUID.V4 as ID
import Control.Concurrent.MVar

import Control.Monad.IO.Class
import Control.Monad (mapM)

import Data.Aeson
import Data.Text (Text, pack)
import GHC.Generics

import qualified Network.URI as URI
import qualified Network.URI.Fetch as URI
import qualified Text.XML as XML
import qualified Text.XML.Cursor as XML
import qualified Data.Map as M'

type Sessions = MVar (M.HashMap UUID Session)
type Session = MVar Session'
data Session' = Session {
    uuid_ :: UUID,
    timeouts :: Timeouts,
    loader :: URI.Session,
    currentURL :: URI.URI,
    backStack :: [URI.URI],
    nextStack :: [URI.URI],
    document :: XML.Document,
    knownEls :: M.HashMap UUID XML.Cursor,
    forms :: M'.Map XML.Element (M.HashMap Text [Text]),
    id2els :: M.HashMap Text XML.Cursor
  }

initSessions :: IO Sessions
initSessions = newMVar M.empty

createSession :: Sessions -> Object -> IO (UUID, Session)
createSession sessions caps = do
    uuid <- ID.nextRandom
    loader' <- URI.newSession
    let session = Session {
        uuid_ = uuid,
        timeouts = case "timeouts" `M.lookup` caps of
            Just t | Success t' <- fromJSON t -> t'
            _ -> Timeouts Nothing Nothing Nothing,
        loader = loader',
        currentURL = URI.nullURI,
        backStack = [], nextStack = [],
        document = XML.Document {
            XML.documentPrologue = XML.Prologue [] Nothing [],
            XML.documentRoot = XML.Element {
                XML.elementName = "html",
                XML.elementAttributes = M'.empty,
                XML.elementNodes = []
            },
            XML.documentEpilogue = []
        },
        knownEls = M.empty,
        forms = M'.empty,
        id2els = M.empty
      }
    session' <- newMVar session
    modifyMVar_ sessions (return . M.insert uuid session')
    return (uuid, session')

delSession :: UUID -> Sessions -> IO ()
delSession uuid sessions = modifyMVar_ sessions (return . M.delete uuid)

getSession :: String -> Sessions -> IO (Maybe (UUID, Session))
getSession uuid' sessions' = withMVar sessions' (return . getSession' (ID.fromString uuid'))
getSession' :: Maybe UUID -> M.HashMap UUID Session -> Maybe (UUID, Session)
getSession' (Just uuid) sessions | Just session <- M.lookup uuid sessions = Just (uuid, session)
getSession' _ _ = Nothing

withSession :: MonadIO m => (String -> m a) -> (UUID -> Session -> m a) -> Sessions -> String -> m a
withSession fail pass sessions' uuid' = do
    ret <- liftIO $ getSession uuid' sessions'
    case ret of
        Just (uuid, session) -> pass uuid session
        Nothing -> fail uuid'

data Timeouts = Timeouts {
    script :: Maybe Int, -- Noop
    pageLoad :: Maybe Int,
    implicit :: Maybe Int -- Noop?
  } deriving Generic
instance FromJSON Timeouts
instance ToJSON Timeouts

registerEl :: Session -> XML.Cursor -> IO UUID
registerEl session el = modifyMVar session $ \session' -> do
    uuid <- ID.nextRandom
    return (session' {
        knownEls = M.insert uuid el $ knownEls session'
      }, uuid)

serializeEl :: Session -> XML.Cursor -> IO Object
serializeEl session el = do
    uuid <- registerEl session el
    return $ M.fromList [
        ("element-6066-11e4-a52e-4f735466cecf", String $ pack $ ID.toString uuid)
      ]

getEl :: Session' -> UUID -> Maybe XML.Cursor
getEl session uuid = M.lookup uuid $ knownEls session

getRelatedEls session cursor = do
    session' <- readMVar session
    let knownEls' = [(XML.node c, uuid) | (uuid, c) <- M.toList $ knownEls session']
    let elID = elID' knownEls'
    parents' <- mapM elID $ XML.ancestor cursor
    self' <- elID cursor
    childs' <- mapM elID $ XML.child cursor
    return (self':parents' ++ childs')
  where
    elID' knownEls' c | Just id <- c' `Prelude.lookup` knownEls' = return (c', id)
        | otherwise = (,) c' <$> registerEl session c
      where c' = XML.node c