5 files changed, 64 insertions(+), 10 deletions(-)

M amphiarao.cabal
M src/Internal/Load.hs
M src/Main.hs
M src/Messages.hs
M src/UI/Templates.hs

@@ 84,3 84,4 @@ executable amphiarao
   -- Base language which the package is written in.
   default-language:    Haskell2010
   
+  ghc-options: -threaded

@@ 1,5 1,5 @@
 {-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
-module Internal.Load(load, load', back, next, parseAbsoluteURI) where
+module Internal.Load(load, load', back, next, parseAbsoluteURI, clickEl, isClickableEl) where
 
 import Internal
 


@@ 22,6 22,7 @@ import Network.URI.Fetch as URI
 import Network.URI.Charset (convertCharset)
 import qualified Text.HTML.DOM as HTML
 import qualified Text.XML as XML
+import qualified Text.XML.Cursor as XC
 import qualified Data.Map as M
 
 mime = words "text/html text/xml application/xml application/xhtml+xml text/plain"


@@ 151,3 152,30 @@ parseGemini' ("```":lines) = go [] lines
 
 parseGemini' (line:lines) = el "p" line : parseGemini' lines
 parseGemini' [] = []
+
+----
+
+clickEl :: Internal.Session -> XC.Cursor -> IO ()
+clickEl session el | XML.NodeElement el' <- XC.node el = clickEl' session el'
+    | otherwise = return ()
+
+clickEl' session (XML.Element _ attrs _)
+    | Just href <- "href" `M.lookup` attrs', Just uri <- URI.parseURIReference $ Txt.unpack href = do
+        base <- withMVar session (return . Internal.currentURL)
+        load session $ URI.relativeTo uri base
+    | Just src <- "src" `M.lookup` attrs', Just uri <- URI.parseURIReference $ Txt.unpack src = do
+        base <- withMVar session (return . Internal.currentURL)
+        load session $ URI.relativeTo uri base
+    -- There's more nuances to links in Rhapsode, but that covered most of them.
+    | otherwise = return ()
+  where attrs' = M.mapKeys XML.nameLocalName attrs
+
+-- Keep inline with clickEl
+isClickableEl :: XC.Cursor -> Bool
+isClickableEl el | XML.NodeElement el' <- XC.node el = isClickableEl' el'
+    | otherwise = False
+isClickableEl' (XML.Element _ attrs _)
+    | Just href <- "href" `M.lookup` attrs', Just _ <- URI.parseURIReference $ Txt.unpack href = True
+    | Just src <- "src" `M.lookup` attrs', Just _ <- URI.parseURIReference $ Txt.unpack src = True
+    | otherwise = False
+  where attrs' = M.mapKeys XML.nameLocalName attrs

@@ 90,7 90,8 @@ serveSession = withSession session404 $ \uuid session -> msum [
             dir "back" $ sessionAction' uuid session Load.back,
             dir "next" $ sessionAction' uuid session Load.next
         ],
-        dir "el" $ path $ serveEl uuid session
+        dir "el" $ path $ serveEl uuid session,
+        dir "click" $ clickElement uuid session
     ]
 
 sessionHome uuid session = do


@@ 100,7 101,7 @@ sessionHome uuid session = do
     session' <- liftIO $ readMVar session
     let el = XC.fromDocument $ document session'
     related <- liftIO $ getRelatedEls session el
-    Tpl.inspector ok ":root" session' $ \langs -> Tpl.elPage uuid el related
+    Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related
 
 session404 uuid = do
     Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do


@@ 191,11 192,23 @@ serveEl' uuid session session' el = do
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
     related <- liftIO $ getRelatedEls session el
-    Tpl.inspector ok title session' $ \langs -> Tpl.elPage uuid el related
+    Tpl.inspector ok title session' $ Tpl.elPage uuid el related
 
 serveElPreview uuid session el = do
     nullDir
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
     related <- liftIO $ getRelatedEls session el
-    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ \langs -> Tpl.elPage uuid el related
+    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ Tpl.elPage uuid el related
+
+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

@@ 16,7 16,8 @@ data Message =
     NoResults |
     PromptPreview |
     ErrURL |
-    LinkSearchExact | LinkSearch
+    LinkSearchExact | LinkSearch |
+    Click
     deriving Show
 
 l :: [Text] -> Message -> Html


@@ 44,6 45,7 @@ l ("en":_) ErrURL = do
     p "The provided URL was not absolute."
 l ("en":_) LinkSearchExact = "Links (Exact)"
 l ("en":_) LinkSearch = "Links"
+l ("en":_) Click = "Click"
 ---- End localizations
 l (_:langs) msg = l langs msg
 l [] msg = string $ show msg


@@ 56,7 58,9 @@ data AttrMessage =
     DebugLink' |
     Reload' |
     Back' |
-    Next' deriving Show
+    Next' |
+    SearchChildren' |
+    Click' deriving Show
 
 l' :: [Text] -> AttrMessage -> AttributeValue
 ---- Begin localization


@@ 68,6 72,8 @@ l' ("en":_) DebugLink' = "Debug link in this test session"
 l' ("en":_) Reload' = "Reload inspected page"
 l' ("en":_) Back' = "Previous inspected page"
 l' ("en":_) Next' = "Next inspected page"
+l' ("en":_) SearchChildren' = "Search Children…"
+l' ("en":_) Click' = "Click"
 ---- End localization
 l' (_:langs) msg = l' langs msg
 l' [] msg = stringValue $ show msg

@@ 9,6 9,7 @@ import Text.Blaze.Html
 import Data.Text as Txt
 
 import Internal
+import Internal.Load (isClickableEl)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (unless, when, forM)
 import Control.Concurrent.MVar


@@ 120,16 121,21 @@ elSelector (Element (Name name _ ns) attrs _) = do
             tok val'
         | otherwise = return []
 
-elPage uuid cursor links = blockquote $ do
+elPage uuid cursor links langs = blockquote $ do
     nav $ do
         forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
             link el $ xmlNode' $ XC.node el -- Should all be elements...
             symbolTok False " > "
-        H.form ! class_ "disclosure" ! target "_top" !
+        H.form ! class_ "disclosure" ! target "_top" ! alt (l' langs SearchChildren') !
                 action (stringValue ('/':ID.toString uuid ++ "/search")) ! A.method "GET" $ do
             input ! type_ "hidden" ! name "el" !
                 value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
-            input ! type_ "search" ! name "q"
+            input ! type_ "search" ! name "q" ! placeholder (l' langs SearchChildren')
+        when (isClickableEl cursor) $ H.form ! class_ "disclosure" ! target "_top" ! alt (l' langs Click') !
+                action (stringValue ('/':ID.toString uuid ++ "/click")) ! A.method "POST" $ do
+            input ! type_ "hidden" ! name "el" !
+                value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
+            button $ l langs Click
     link cursor $ p $ xmlNode $ XC.node cursor
     ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
   where