{-# 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 } 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 } 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