{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Internal(Session(..), Session'(..), Sessions(..),
        initSessions, createSession, delSession, getSession, withSession,
        Timeouts(..)) 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 Data.Aeson
import Data.Text (Text, pack)
import GHC.Generics

import qualified Network.URI as URI
import qualified Network.URI.Fetch as URI

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]
  }

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 = []
      }
    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