{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}
module Main where
import Happstack.Lite
import Happstack.Server.RqData
import Happstack.Server.Monads (askRq)
import Happstack.Server.Types (rqUri)
import Control.Concurrent.MVar
import Data.HashMap.Strict as M
import Data.FileEmbed
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html (text, string, contents)
import Text.Blaze.Renderer.Text (renderMarkup)
import qualified Data.Text as Txt
import Data.Text.Lazy (toStrict)
import Webdriver
import Data.UUID as ID
import qualified Text.XML.Cursor as XC
import Data.Maybe
import Messages
import Happstack.Server.I18N
import Internal
import Internal.Load as Load
import Internal.Elements as El
import Internal.Forms as Forms
import Internal.Style as Style
import Data.CSS.Syntax.Tokens as Style
import Control.Monad.IO.Class (liftIO)
import Control.Monad (forM)
import qualified UI.Templates as Tpl
import qualified UI.Search as Q
main :: IO ()
main = do
sessions <- initSessions
putStrLn "Serving http://localhost:8000/"
serve Nothing $ do
req <- askRq
liftIO $ putStrLn $ rqUri req
msum [
dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"),
dir "webdriver" $ dir "v1" $ serveWebdriver sessions,
postHome sessions,
serveHome,
dir "preview-prompt" servePreviewPrompt,
dir "close" $ path $ deleteSession sessions,
path $ serveSession sessions
]
serveHome :: ServerPart Response
serveHome = do
nullDir
method GET
Tpl.page ok ["Amphiarao"] "" $ \langs -> do
l langs AmphiaraoIntro
Tpl.sessionForm langs
postHome sessions = do
nullDir
method POST
liftIO $ putStrLn "Creating new session!"
(uuid, session) <- liftIO $ createSession sessions M.empty
target <- looks "target"
-- Not much point of a blank session, so allow loading here.
liftIO $ putStrLn "Allocated new session!"
case target of
(target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load' session url
_ -> return ()
liftIO $ putStrLn "Created new session!"
seeOther ('/' : ID.toString uuid) $ toResponse ()
deleteSession sessions uuid = do
nullDir
method POST
case ID.fromString uuid of
Just id -> liftIO $ delSession id sessions
Nothing -> return ()
seeOther ['/'] $ toResponse ()
servePreviewPrompt = do
nullDir
method GET
Tpl.page ok ["?", "Amphiarao"] "" $ \langs -> H.p $ l langs PromptPreview
---
serveSession :: Sessions -> String -> ServerPart Response
serveSession = withSession session404 $ \uuid session -> msum [
sessionHome uuid session,
dir "timeout" $ setTimeout uuid session,
dir "search" $ searchSession session,
dir "nav" $ msum [
dir "load" $ loadPage uuid session,
dir "reload" $ reloadPage uuid session,
dir "back" $ sessionAction' uuid session Load.back,
dir "next" $ sessionAction' uuid session Load.next
],
dir "el" $ path $ serveEl uuid session,
dir "click" $ clickElement uuid session,
dir "type" $ typeElement uuid session
]
sessionHome uuid session = do
nullDir
method GET
session' <- liftIO $ readMVar session
let el = XC.fromDocument $ document session'
related <- liftIO $ getRelatedEls session el
Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related ""
session404 uuid = do
Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do
H.h1 $ l langs SessionNotFound
Tpl.sessionForm langs
setTimeout uuid session = do
nullDir
method POST
timeout <- lookRead "pageLoad"
let inner s = return $ s {timeouts = (timeouts s) {pageLoad = Just timeout}}
liftIO $ modifyMVar_ session inner
seeOther ('/':ID.toString uuid) $ toResponse ()
searchSession session = do
nullDir
method GET
q <- look "q"
session' <- liftIO $ readMVar session
el <- looks "el"
let (root, ancestors) = case el of {
(el':_) | Just root <- ID.fromString el' >>= getEl session' ->
(root, Prelude.reverse $ (XC.orSelf XC.ancestor) root);
_ -> (XC.fromDocument $ document session', [])
}
results <- forM Q.engines $ \(header, engine) -> do
results' <- liftIO $ engine q session root
return (header, labelEmpty results')
Tpl.inspector' q ok (Txt.pack ('🔎':q)) session' $ \langs -> H.main $ do
H.aside $ do
H.p $ do
forM ancestors $ \el -> do
Tpl.xmlNode' $ XC.node el -- Should all be elements...
H.text " > "
return ()
H.dl $ do
forM results $ \(header, results') -> do
H.dt $ header langs
forM results' $ \result -> H.dd $ result langs
return ()
return ()
H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ ""
where
labelEmpty [] = [\langs -> l langs NoResults]
labelEmpty x = x
loadPage uuid session = do
nullDir
method POST
target <- look "url"
case Load.parseAbsoluteURI target of
Just url -> do
liftIO $ Load.load session url
seeOther ('/':ID.toString uuid) $ toResponse ()
Nothing -> do
session' <- liftIO $ readMVar session
Tpl.inspector ok "400" session' $ \langs -> l langs ErrURL
reloadPage uuid session = do
nullDir
method POST
session' <- liftIO $ readMVar session
liftIO $ Load.load' session $ currentURL session'
seeOther ('/':ID.toString uuid) $ toResponse ()
sessionAction' uuid session cb = do
nullDir
method POST
liftIO $ cb session
seeOther ('/':ID.toString uuid) $ toResponse ()
---
serveEl :: UUID -> Session -> String -> ServerPart Response
serveEl uuid session el = do
session' <- liftIO $ readMVar session
case getEl session' =<< ID.fromString el of
Just el' -> msum [
dir "preview" $ serveElPreview uuid session el',
serveEl' uuid session session' el'
]
Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
H.h1 $ l langs ElementNotFound
serveEl' uuid session session' el = do
nullDir
method GET
let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
related <- liftIO $ getRelatedEls session el
elValue <- liftIO $ Forms.readInput' session el
let styles = M.toList $ Style.styleCursor session' el
Tpl.inspector ok title session' $ \langs -> do
Tpl.elPage uuid el related elValue langs
H.aside $ H.dl H.! A.class_ "tabular" $ do
forM styles $ \(prop, val) -> do
H.dt $ do
Tpl.identTok $ Txt.pack prop
Tpl.symbolTok False ":"
H.dd $ Tpl.hlCSSs val
return ()
serveElPreview uuid session el = do
nullDir
method GET
let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
related <- liftIO $ getRelatedEls session el
elValue <- liftIO $ Forms.readInput' session el
Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $
Tpl.elPage uuid el related elValue
clickElement uuid session = do
nullDir
method POST
elUUID <- look "el"
session' <- liftIO $ readMVar session
case getEl session' =<< ID.fromString elUUID of
Just el -> do
liftIO $ Load.clickEl session el
seeOther ('/':ID.toString uuid) $ toResponse ()
Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
H.h1 $ l langs ElementNotFound
typeElement uuid session = do
nullDir
method POST
elUUID <- look "el"
newValue <- lookText' "text"
isReset <- looks "reset"
session' <- liftIO $ readMVar session
case getEl session' =<< ID.fromString elUUID of
Just el | Prelude.null isReset -> do
liftIO $ Forms.sendText (Forms.SendText newValue) el session
seeOther ('/':ID.toString uuid) $ toResponse ()
Just el -> do
liftIO $ Forms.clearForm session el
seeOther ('/':ID.toString uuid) $ toResponse ()
Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
H.h1 $ l langs ElementNotFound