~alcinnz/amphiarao

ref: 7b26fe8f55dd630cde332fb7663e163ae441d70b amphiarao/src/Internal.hs -rw-r--r-- 3.3 KiB
7b26fe8f — Adrian Cochrane Expose CSS selector search in UI FIXME: build the linked pages. 3 years ago 
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Internal(Session(..), Session'(..), Sessions(..),
        initSessions, createSession, delSession, getSession, withSession,
        Timeouts(..), registerEl, serializeEl) 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
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
  }

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