~alcinnz/amphiarao

ref: 38e35ef9d734707812e882609d87acb401c82ef2 amphiarao/src/UI/Templates.hs -rw-r--r-- 2.5 KiB
38e35ef9 — Adrian Cochrane Add support for querying elements by CSS selector. 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
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module UI.Templates(page, inspector, sessionForm) where

import Happstack.Lite
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html
import Data.Text as Txt

import Internal
import Control.Monad.IO.Class (liftIO)
import Control.Monad (unless)
import Control.Concurrent.MVar
import Data.UUID as ID

import Messages
import Happstack.Server.I18N

page :: (Response -> ServerPart Response) -> [Text] -> ([Text] -> Html) -> ServerPart Response
page return' title body' = do
    langs <- bestLanguage <$> acceptLanguage
    return' $ toResponse $ html $ do
        H.head $ do
            H.title $ text $ intercalate " — " title
        body $ body' langs

inspector :: (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response
inspector return' title session' body' = do
    let timeout = H.stringValue $ show $ pageLoad $ timeouts session'
    page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do
        header $ do
            unless (Prelude.null $ backStack session') $ postButton "/nav/back" (l' langs Back') "🡸"
            unless (Prelude.null $ nextStack session') $ postButton "/nav/next" (l' langs Next') "🡺"
            postButton "/nav/reload" (l' langs Reload') "↻"
            hr
            H.form ! action' ["/", uuid', "/search"] ! alt (l' langs Search') $ do
                input ! type_ "search" ! name "q" ! placeholder (l' langs Search')
        body' langs
        footer $ do
            H.form ! action' ["/close/", uuid'] ! A.method "POST" ! alt (l' langs CloseSession') $ do
                button ! type_ "submit" $ l langs CloseSession
            hr
            H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" ! alt (l' langs LoadTimeout') $ p $ do
                H.label $ do
                    l langs LoadTimeout
                    input ! type_ "number" ! name "pageLoad" ! value timeout
                text "ms"

  where
    uuid' = ID.toString $ uuid_ session'
    action' = A.action . H.stringValue . Prelude.concat
    postButton target title' label = H.form ! action' ["/", uuid', target] ! alt title' ! A.method "POST" $ do
        button ! type_ "submit" ! A.title title' $ label

sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do
    input ! type_ "url" ! name "target" ! placeholder "URL to debug"
    button ! type_ "submit" $ l langs CreateSession