From d4c10f895dce29c0eb5b6209fb228abc731e7b5a Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 23 Jun 2021 14:29:20 +1200 Subject: [PATCH] Allow loading webpage, commit missing files. --- amphiarao.cabal | 9 ++-- src/Capabilities.hs | 59 ++++++++++++++++++++ src/Internal.hs | 68 ++++++++++++++++++++++++ src/Internal/Load.hs | 29 ++++++++++ src/JSON.hs | 45 ++++++++++++++++ src/Main.hs | 124 ++++++++++++++++++++++++++++++++++++++++--- src/Messages.hs | 43 +++++++++++++++ src/UI/Search.hs | 29 ++++++++++ src/UI/Templates.hs | 51 ++++++++++++++++++ src/Webdriver.hs | 112 +++++++++++++++++++++++++------------- 10 files changed, 521 insertions(+), 48 deletions(-) create mode 100644 src/Capabilities.hs create mode 100644 src/Internal.hs create mode 100644 src/Internal/Load.hs create mode 100644 src/JSON.hs create mode 100644 src/Messages.hs create mode 100644 src/UI/Search.hs create mode 100644 src/UI/Templates.hs diff --git a/amphiarao.cabal b/amphiarao.cabal index d71e608..200d3d2 100644 --- a/amphiarao.cabal +++ b/amphiarao.cabal @@ -54,15 +54,18 @@ executable amphiarao main-is: Main.hs -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: Webdriver, Capabilities, JSON, Messages, Internal, Internal.Load, + UI.Templates, UI.Search -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server, - aeson >= 1.5.0 && <1.6, text, bytestring, - containers >=0.5 && <0.7, uuid >=1.3 && <1.4 + aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector, + containers >=0.5 && <0.7, uuid >=1.3 && <1.4, + blaze-html, + hurl >= 2.1 && <3, network-uri -- Directories containing source files. hs-source-dirs: src diff --git a/src/Capabilities.hs b/src/Capabilities.hs new file mode 100644 index 0000000..28cbdcb --- /dev/null +++ b/src/Capabilities.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Capabilities(processCaps) where + +import Data.Aeson +import Data.Text (Text, pack) +import qualified Data.HashMap.Strict as M +import qualified Data.Vector as V + +import Data.Maybe (isJust, mapMaybe, fromMaybe) +import Internal (Timeouts(..)) + +processCaps :: Maybe Value -> Maybe Object +processCaps caps + | Just (required, fallbacks) <- decodeCaps caps, isJust $ validateCap required = + foldl mergeCaps (Just required) $ mapMaybe validateCap fallbacks +processCaps _ = Nothing + +-- Manual decode, to ensure WebDriver specs are followed. +decodeCaps :: Maybe Value -> Maybe (Object, [Object]) +decodeCaps (Just (Object obj)) + | Just (Object caps) <- "capabilities" `M.lookup` obj, + required <- "alwaysMatch" `M.lookup` caps, fallbacks <- "firstMatch" `M.lookup` caps, + fromMaybe True (isObj <$> required) = + let required' = case required of { + Just (Object o) -> o; + _ -> nilCap + } in case fallbacks of + Just (Array fallbacks') | all isObj fallbacks' -> + Just (required', [f | Object f <- V.toList fallbacks']) + Nothing -> Just (required', [nilCap]) + _ -> Nothing + where + isObj (Object _) = True + isObj _ = False + nilCap = M.empty +decodeCaps _ = Nothing + +validateCap :: Object -> Maybe Object +validateCap cap + | and [isJust $ inner k v | (k, v) <- M.toList cap, v /= Null] = Just $ M.mapMaybeWithKey inner cap + | otherwise = Nothing + where + inner _ Null = Nothing + inner "acceptInsecureCertificates" v@(Bool _) = Just v -- What's the behavior here? + inner "browserName" v@(String "rhapsode") = Just v + inner "browserVersion" v@(String "5") = Just v + inner "browserVersion" v@(String "4") = Just v + inner "browserVersion" v@(String "3") = Just v + inner "platformName" v@(String _) = Just v -- Rhapsode's very cross-platform. + inner "pageLoadStrategy" v@(String v') | v' `elem` ["none", "eager", "normal"] = Just v -- Noop + -- I don't support "proxy" yet. + inner "timeouts" v | Success Timeouts {} <- fromJSON v = Just v + inner "unhandledPromptBehavior" v@(String v') + | v' `elem` ["dissmiss", "accept", "dismiss and accept", "accept and notify", "ignore"] = Just v -- Noop + inner _ _ = Nothing + +mergeCaps :: Maybe Object -> Object -> Maybe Object +mergeCaps (Just primary) secondary | M.null $ M.intersection primary secondary = + Just $ M.union primary secondary diff --git a/src/Internal.hs b/src/Internal.hs new file mode 100644 index 0000000..b995048 --- /dev/null +++ b/src/Internal.hs @@ -0,0 +1,68 @@ +{-# 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 { + 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 { + 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 diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs new file mode 100644 index 0000000..ab8edf2 --- /dev/null +++ b/src/Internal/Load.hs @@ -0,0 +1,29 @@ +module Internal.Load(load, parseAbsoluteURI) where + +import Internal + +import Control.Concurrent.MVar +import System.Timeout (timeout) +import Control.Monad.IO.Class + +import Data.Aeson +import Data.Text (Text, pack) +import GHC.Generics + +import Data.Maybe (fromMaybe) + +import Network.URI as URI +import Network.URI.Fetch as URI + +mime = words "text/html text/xml application/xml application/xhtml+xml text/plain" + +load :: Internal.Session -> URI -> IO () +load session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do + (redirected, _, _) <- fetchURL' (loader session') mime uri + return $ session' { currentURL = redirected} + +maybeTimeout :: Session' -> URI -> IO Session' -> IO Session' +maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad $ timeouts session = + -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds. + fromMaybe session <$> timeout (delay * 1000) act +maybeTimeout _ _ act = act diff --git a/src/JSON.hs b/src/JSON.hs new file mode 100644 index 0000000..506ae83 --- /dev/null +++ b/src/JSON.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-} +module JSON(getJSON, okJSON, errJSON) where + +import Happstack.Lite +import Happstack.Server.Types (unBody, takeRequestBody) +import Happstack.Server (askRq, resp) + +import Data.Aeson +import Data.Text (Text) +import GHC.Generics +import Data.ByteString.Lazy (ByteString) + +import Control.Monad.IO.Class (liftIO) + +getBody :: ServerPart ByteString +getBody = do + req <- askRq + body <- liftIO $ takeRequestBody req + case body of + Just rqbody -> return . unBody $ rqbody + Nothing -> return "" + +getJSON :: FromJSON x => ServerPart (Maybe x) +getJSON = decode <$> getBody + +okJSON :: ToJSON x => x -> ServerPart Response +okJSON x = do + setHeaderM "Content-Type" "application/json" + ok $ toResponse $ encode x + +data WDError' = WDError' { + value :: WDError + } deriving Generic +instance ToJSON WDError' +data WDError = WDError { + error :: Text, + message :: String, + stacktrace :: Text -- Noop + } deriving Generic +instance ToJSON WDError + +errJSON :: Int -> Text -> String -> ServerPart Response +errJSON code name message = do + setHeaderM "Content-Type" "application/json" + resp code $ toResponse $ encode $ WDError' $ WDError name message "" diff --git a/src/Main.hs b/src/Main.hs index a7766bd..718ce4c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,21 +2,131 @@ module Main where import Happstack.Lite +import Happstack.Server.RqData import Control.Concurrent.MVar -import qualified Data.Map.Strict as M +import Data.HashMap.Strict as M + +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html (text, string) +import qualified Data.Text as Txt import Webdriver -import Data.UUID +import Data.UUID as ID + +import Messages +import Happstack.Server.I18N + +import Internal +import Internal.Load as Load +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 <- newMVar emptySessions + sessions <- initSessions serve Nothing $ msum [ dir "webdriver" $ dir "v1" $ serveWebdriver sessions, - serveHome + 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 + (uuid, session) <- liftIO $ createSession sessions M.empty + target <- looks "target" + -- Not much point of a blank session, so allow loading here. + case target of + (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load session url + _ -> return () + 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 uuid session, + dir "nav" $ msum [ + dir "load" $ loadPage uuid session + ] ] -emptySessions :: M.Map UUID WDSession -emptySessions = M.empty +sessionHome uuid session = do + nullDir + method GET + + let uuid' = ID.toString uuid + Tpl.inspector ok "UUID" session uuid $ \langs -> H.h1 $ string uuid' + +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 uuid session = do + nullDir + method GET + q <- look "q" + session' <- liftIO $ readMVar session + let results = [(header, labelEmpty $ engine q session') | (header, engine) <- Q.engines] + Tpl.inspector ok (Txt.pack ('๐Ÿ”Ž':q)) session uuid $ \langs -> H.main $ do + H.aside $ do + H.form $ do + H.input H.! A.type_ "search" H.! A.name "q" H.! A.value (H.stringValue q) + H.dl $ do + forM results $ \(header, results') -> do + H.dt $ header langs + forM results' $ \result -> H.dd $ result langs + return () + return () + H.section $ do + H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ "" + where + labelEmpty [] = [\langs -> l langs NoResults] + labelEmpty x = x -serveHome = ok $ toResponse ("Hello, world!" :: String) +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 -> Tpl.inspector ok "400" session uuid $ \langs -> l langs ErrURL diff --git a/src/Messages.hs b/src/Messages.hs new file mode 100644 index 0000000..7f15117 --- /dev/null +++ b/src/Messages.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +module Messages(l, Message(..)) where + +import Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html +import Data.Text (Text) + +data Message = + AmphiaraoIntro | + CreateSession | + CloseSession | + LoadTimeout | + SessionNotFound | + NoResults | + PromptPreview | + ErrURL deriving Show + +l :: [Text] -> Message -> Html +---- Begin localizations +l ("en":_) AmphiaraoIntro = do + h1 "Amphiarao webpage debugger for Rhapsode" + p $ do + text "Amphiarao lets you analyze how webpages are parsed & styled in " + a ! href "https://rhapsode.adrian.geek.nz/" $ "Rhapsode" + text ", either programmatically via " + a ! href "https://www.selenium.dev/" $ "Selenium" + text " (using " + a ! href "/webdriver/v1/" $ "this WebDriver endpoint" + text ") or manually via this web UI which can be viewed in any web browser including Rhapsode. " + p "Amphiarao is a locally-run webservice implemented using the same underlying libraries as Rhapsode." +l ("en":_) CreateSession = "Open new test session" +l ("en":_) LoadTimeout = "Load Timeout" +l ("en":_) CloseSession = "Close Session" +l ("en":_) SessionNotFound = "Session Not Found" +l ("en":_) NoResults = em "No Results" +l ("en":_) PromptPreview = em "Click a search result to preview it here" +l ("en":_) ErrURL = do + h1 "Invalid Link!" + p "The provided URL was not absolute." +---- End localizations +l (_:langs) msg = l langs msg +l [] msg = string $ show msg diff --git a/src/UI/Search.hs b/src/UI/Search.hs new file mode 100644 index 0000000..0c244a8 --- /dev/null +++ b/src/UI/Search.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module UI.Search(engines) where + +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 Network.URI (parseAbsoluteURI) + +engines :: [( + [Text] -> Html, + String -> Session' -> [[Text] -> Html] + )] +engines = [ + (const "URL", offerToLoad) + ] + +offerToLoad q _ | Just _ <- parseAbsoluteURI q = [const $ do + result q q + H.form ! action "nav/load" ! method "POST" $ do + input ! type_ "hidden" ! name "url" ! value (stringValue q) + button ! type_ "submit" ! class_ "disclosure" $ disclosure + ] + +result href' label = a ! href (stringValue href') ! target "preview" $ string label +disclosure = "โคท" diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs new file mode 100644 index 0000000..e848e88 --- /dev/null +++ b/src/UI/Templates.hs @@ -0,0 +1,51 @@ +{-# 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.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 -> UUID -> ([Text] -> Html) -> ServerPart Response +inspector return' title session uuid body' = do + session' <- liftIO $ readMVar session + let uuid' = ID.toString uuid + let timeout = H.stringValue $ show $ pageLoad $ timeouts session' + page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do + header $ do + H.form ! action' ["/", uuid', "/search"] $ do + input ! type_ "search" ! name "q" ! placeholder "Search..." + body' langs + footer $ do + H.form ! action' ["/close/", uuid'] ! A.method "POST" $ do + button ! type_ "submit" $ l langs CloseSession + hr + H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" $ p $ do + H.label $ do + l langs LoadTimeout + input ! type_ "number" ! name "pageLoad" ! value timeout + text "ms" + + where + action' = A.action . H.stringValue . Prelude.concat + +sessionForm langs = H.form ! A.method "POST" ! action "/" $ do + input ! type_ "url" ! name "target" ! placeholder "URL to debug" + button ! type_ "submit" $ l langs CreateSession diff --git a/src/Webdriver.hs b/src/Webdriver.hs index 88d1c1d..1e0d3b7 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -1,60 +1,96 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-} -module Webdriver(serveWebdriver, WDSession(..)) where +module Webdriver(serveWebdriver) where import Happstack.Lite -import Happstack.Server.Types (unBody, takeRequestBody) -import Happstack.Server (askRq) import Control.Concurrent.MVar import Data.Aeson import Data.Text (Text) import GHC.Generics import Data.ByteString.Lazy (ByteString) -import qualified Data.Map.Strict as M -import Data.UUID +import qualified Data.HashMap.Strict as M +import Data.UUID as ID import Data.UUID.V4 import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) -data WDSession = WDSession -- TODO: Add fields +import qualified Network.URI as URI +import qualified Network.URI.Fetch as URI -serveWebdriver :: MVar (M.Map UUID WDSession) -> ServerPart Response -serveWebdriver sessions = msum [ - dir "status" serveStatus, - dir "session" $ postSession sessions - ] +import Capabilities (processCaps) +import JSON +import qualified Internal as WD +import qualified Internal.Load as WD + +serveWebdriver :: WD.Sessions -> ServerPart Response +serveWebdriver sessions = do + msum [ + dir "status" serveStatus, + dir "session" $ postSession sessions, + dir "session" $ path $ serveSession sessions, + nullDir >> ok (toResponse ("This is a WebDriver endpoint. Please copy the URL to hand to Selenium." :: Text)) + ] +serveSession :: WD.Sessions -> String -> ServerPart Response +serveSession sessions = WD.withSession fail (\uuid session -> msum [ + delSession sessions uuid, + dir "timeouts" $ getTimeout session, + dir "timeouts" $ setTimeout session + ]) sessions + where + fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ ( + "Session " ++ uuid' ++ " was not found in active sessions") + | otherwise = errJSON 404 "invalid session ID" $ ("UUID " ++ uuid' ++ " is not a valid UUID") data Status = Status {ready :: Bool, message :: Text} deriving Generic instance ToJSON Status serveStatus = okJSON $ Status True "Always ready to open new sessions" -data NewSession = NewSession {sessionId :: UUID, capabilities :: Value} deriving Generic +data NewSession = NewSession {sessionId :: UUID, capabilities :: Object} deriving Generic instance ToJSON NewSession postSession sessions = do method POST - caps <- fromMaybe Null <$> getJSON - -- FIXME: Validate provided capabilities. - uuid <- liftIO nextRandom - let session = WDSession - liftIO $ modifyMVar_ sessions (return . M.insert uuid session) - okJSON $ NewSession uuid caps - --------- ----- Utils --------- -getBody :: ServerPart ByteString -getBody = do - req <- askRq - body <- liftIO $ takeRequestBody req - case body of - Just rqbody -> return . unBody $ rqbody - Nothing -> return "" - -getJSON :: FromJSON x => ServerPart (Maybe x) -getJSON = decode <$> getBody - -okJSON :: ToJSON x => x -> ServerPart Response -okJSON x = do - setHeaderM "Content-Type" "application/json" - ok $ toResponse $ encode x + nullDir + caps' <- getJSON + case processCaps caps' of + Just caps -> do + (uuid, _) <- liftIO $ WD.createSession sessions caps + okJSON $ NewSession uuid caps + Nothing -> errJSON 500 "session not created" "Invalid capabilities specified!" + +delSession sessions uuid = do + method DELETE + nullDir + liftIO $ WD.delSession uuid sessions + ok $ toResponse () + +getTimeout session = do + method GET + nullDir + session' <- liftIO $ readMVar session + okJSON $ WD.timeouts session' + +setTimeout session = do + method POST + nullDir + update' <- getJSON + session' <- liftIO $ readMVar session + case update' of + Just (Object update) | Object current <- toJSON $ WD.timeouts session', + Success new <- fromJSON $ toJSON $ M.union update current -> do + liftIO $ swapMVar session session' {WD.timeouts = new} + ok $ toResponse () + _ -> errJSON 400 "invalid argument" "Failed to parse JSON input" + +data NavigateTo = NavigateTo { url :: String } deriving Generic +instance FromJSON NavigateTo +navigateTo session = do + method POST + nullDir + target' <- getJSON + case target' of + Just target | Just url' <- URI.parseAbsoluteURI target -> do + liftIO $ WD.load session url' + ok $ toResponse () + Just target -> errJSON 400 "invalid argument" (target ++ " is not an absolute URL") + Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input" -- 2.30.2