~alcinnz/amphiarao

ref: a52109529e3af8433a574eb10d00e435f0bc9b09 amphiarao/src/Internal.hs -rw-r--r-- 3.4 KiB
a5210952 — Adrian Cochrane Show search queries in existing searchbox, not new one. 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
103
104
105
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Internal(Session(..), Session'(..), Sessions(..),
        initSessions, createSession, delSession, getSession, withSession,
        Timeouts(..), registerEl, serializeEl, getEl) 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)
      ]

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