diff --git a/hurl-xml.cabal b/hurl-xml.cabal --- a/hurl-xml.cabal +++ b/hurl-xml.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Fetch parsed XML & possibly CSS for a URL based on MIMEtype. @@ -51,10 +51,10 @@ library -- Modules exported by the library. - exposed-modules: Network.MIME.XML + exposed-modules: Network.URI.Fetch.XML, Network.URI.Fetch.XML.Table -- Modules included in this library but not exported. - other-modules: Network.MIME.XML.Table + other-modules: -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Network/MIME/XML.hs b/src/Network/MIME/XML.hs deleted file mode 100644 --- a/src/Network/MIME/XML.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Network.MIME.XML(Page(..), loadVisited, - fetchDocument, pageForText, applyCSScharset, readStrict) where - -import Data.Text.Lazy (fromStrict) -import qualified Data.Text as Txt -import Data.Text (Text) -import qualified Data.Text.IO as Txt -import Data.Text.Encoding -import qualified Data.Text.Lazy as LTxt -import qualified Data.ByteString.Lazy as B -import qualified Text.HTML.DOM as HTML -import qualified Text.XML as XML -import Text.XML (Document(..)) -import Network.URI -import Network.URI.Fetch -import Network.URI.Charset -import qualified Data.Map as M -import qualified Data.Set as Set -import Data.Set (Set(..)) -import Data.List (intercalate) -import Data.Time.Clock - --- For alternative styles -import qualified Data.CSS.Syntax.Tokens as CSSTok -import Stylist.Parse - -import System.IO -import System.IO.Temp -import Data.Default.Class -import System.Directory -import System.FilePath (()) -import Data.FileEmbed -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) - -import Network.MIME.XML.Table -- Apply table sorting here... -import Data.HTML2CSS (html2css) - -data Page styles = Page { - pageURL :: URI, - css :: styles, - initCSS :: styles, - html :: Document, - pageTitle :: String, - pageMIME :: String, - apps :: [Application], - backStack :: [(String, URI)], - forwardStack :: [(String, URI)], - -- Probably don't need an MVar here, but let's be safe! - visitedURLs :: Set Text, - appName :: String -} - -loadVisited :: String -> IO (Set Text) -loadVisited appname = do - dir <- getXdgDirectory XdgData appname - let path = dir "history.gmni" - exists <- doesFileExist path - - if exists then do - file <- readStrict path - let hist = Set.fromList [Txt.pack uri | _:uri:_ <- map words $ lines file] - return hist - else return Set.empty - -readStrict path = do s <- Prelude.readFile path; length s `seq` return s - -utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes -aCCEPT = ["text/xml", "application/xml", "text/html", "text/gemini", - "text/csv", "text/tab-separated-values", "text/css", "text/*", "*/*"] - -fetchDocument http referer URI { uriScheme = "action:", uriPath = "nocache" } = - fetchDocument http { cachingEnabled = False } referer $ pageURL referer -fetchDocument http referer URI { uriScheme = "action:", uriPath = "novalidate" } = - fetchDocument http { validateCertificates = False } referer $ pageURL referer -fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/back" } = - fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False - where referer' = shiftHistory referer (-1) -fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/forward" } = - fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False - where referer' = shiftHistory referer 1 -fetchDocument http referer URI { - uriScheme = "action:", uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x - } | Just x' <- readMaybe x, referer' <- shiftHistory referer x' = - fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer http False -fetchDocument http referer URI { uriScheme = "app:", uriPath = appID } = do - dispatchByApp http Application { - name = "", icon = nullURI, description = "", - appId = appID - } (pageMIME referer) $ pageURL referer - return referer -- TODO play an error or success sound -fetchDocument http referer@Page { pageURL = uri0 } uri@URI { uriFragment = anchor } - | uri { uriFragment = "" } == uri0 { uriFragment = "" } = return referer { - html = applySortDoc anchor $ html referer, - pageURL = uri - } -fetchDocument http referer uri = fetchURL' http aCCEPT uri >>= parseDocument' referer http True - -shiftHistory :: Page style -> Integer -> Page style -shiftHistory self 0 = self -shiftHistory self@Page { backStack = (title, url):bs } delta | delta < 0 = - shiftHistory self { - backStack = bs, - forwardStack = (pageTitle self, pageURL self):forwardStack self, - pageTitle = title, - pageURL = url - } $ succ delta -shiftHistory self@Page { forwardStack = (title, url):fs } delta | delta > 0 = - shiftHistory self { - forwardStack = fs, - backStack = (pageTitle self, pageURL self):backStack self, - pageTitle = title, - pageURL = url - } $ pred delta -shiftHistory self _ = self -- Error case. - -parseDocument' ref@Page {visitedURLs = hist} sess saveHist resp@(URI {uriFragment = anch}, mime, _) = do - page <- parseDocument ref sess resp >>= logHistory hist - apps' <- appsForMIME sess mime - return $ attachHistory page { - pageMIME = mime, - apps = apps', - html = applySortDoc anch $ html page - } - where - attachHistory x@Page { pageTitle = title, pageURL = url } - | saveHist = x { backStack = (title, url):backStack ref, forwardStack = forwardStack ref } - | otherwise = x -parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString) - -> IO (Page s) -parseDocument ref sess (uri, "html/x-error\t", resp) = parseDocument ref sess (uri, "text/html", resp) -parseDocument Page {initCSS = css', appName = name} _ (uri, "text/html", Left text) = - pageForDoc css' name uri $ HTML.parseLT $ fromStrict text -parseDocument Page {initCSS = css', appName = name} _(uri, "text/html", Right bytes) = - pageForDoc css' name uri $ HTML.parseLBS bytes -parseDocument Page {initCSS = css', appName = name} _ - (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Left text) = - pageForDoc css' name uri $ parseGemini (Just lang) text -parseDocument Page {initCSS = css', appName = name} _ - (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Right bytes) = - pageForDoc css' name uri $ parseGemini (Just lang) $ utf8' bytes -parseDocument Page {initCSS = css', appName = name} _ (uri, "text/gemini", Left text) = - pageForDoc css' name uri $ parseGemini Nothing text -parseDocument Page {initCSS = css', appName = name} _ (uri, "text/gemini", Right bytes) = - pageForDoc css' name uri $ parseGemini Nothing $ utf8' bytes -parseDocument a b (a', b'@"text/css", Right bytes) = - parseDocument a b (a', b', Left $ applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes) -parseDocument referer@Page {pageURL = uri', initCSS = css', appName = name} _ - (uri, "text/css", Left text) - | URI {uriAuthority = Just host} <- pageURL referer = do - -- Save this per-domain setting - dir <- ( "domain") <$> getXdgDirectory XdgConfig name - createDirectoryIfMissing True dir - Txt.writeFile (dir uriRegName host) $ - CSSTok.serialize $ map absolutizeCSS $ CSSTok.tokenize text - - return ret - | otherwise = return ret - where - ret = referer { - css = parseForURL css' uri text - } - absolutizeCSS (CSSTok.Url text) | Just rel <- parseRelativeReference $ Txt.unpack text = - CSSTok.Url $ Txt.pack $ uriToStr' $ relativeTo rel uri' - absolutizeCSS tok = tok -parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/csv", Left body) = - pageForDoc css' name uri $ parseDelimitedToTable ',' body -parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/tab-separated-values", Left body) = - pageForDoc css' name uri $ parseDelimitedToTable '\t' body -parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/csv", Right body) = - pageForDoc css' name uri $ parseDelimitedToTable ',' $ utf8' body -parseDocument ref@Page {initCSS = css', appName = name} _ - (uri, "text/tab-separated-values", Right body) = - pageForDoc css' name uri $ parseDelimitedToTable '\t' $ utf8' body - -parseDocument ref sess (uri, mime, body) | mime' /= mime = parseDocument ref sess (uri, mime', body) - where mime' = takeWhile (/= ';') mime -parseDocument Page {initCSS = css', appName = name} _ (uri, _, Left text) - | Right doc <- XML.parseText def $ fromStrict text = pageForDoc css' name uri doc - | otherwise = pageForText css' name uri text -parseDocument Page {initCSS = css', appName = name} _ (uri, _, Right bytes) - | Right doc <- XML.parseLBS def bytes = pageForDoc css' name uri doc -parseDocument Page {initCSS = css', appName = name} _ (uri, 't':'e':'x':'t':'/':_, Right bytes) = - -- charset wasn't specified, so assume utf-8. - pageForText css' name uri $ utf8' bytes -parseDocument Page {initCSS = css', appName = name} sess resp@(uri, mime, _) = do - dir <- getCurrentDirectory -- TODO find Downloads directory. - ret <- saveDownload nullURI { - uriScheme = "file:", - uriAuthority = Just (URIAuth "" "" "") - } dir resp >>= dispatchByMIME sess mime - pageForDoc css' name uri $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret - -pageForText css' appname uri txt = pageForDoc css' appname uri XML.Document { - XML.documentPrologue = XML.Prologue [] Nothing [], - XML.documentRoot = XML.Element { - XML.elementName = "pre", - XML.elementAttributes = M.empty, - XML.elementNodes = [XML.NodeContent txt] - }, - XML.documentEpilogue = [] - } - -pageForDoc :: StyleSheet s => s -> String -> URI -> Document -> IO (Page s) -pageForDoc css' appname uri doc = do - -- See if the user has configured an alternate stylesheet for this domain. - let authorStyle = return $ html2css doc uri css' - styles <- case uriAuthority uri of - Nothing -> authorStyle - Just host -> do - dir <- getXdgDirectory XdgConfig appname - let path = dir "domain" uriRegName host - hasAltStyle <- doesFileExist path - if not hasAltStyle then authorStyle else parse css' <$> Txt.readFile path - - return Page {pageURL = uri, html = doc, css = styles, - initCSS = css', appName = appname, - -- These fields are all blank, to be filled in later by logHistory & parseDocument' - pageTitle = "", pageMIME = "", apps = [], - backStack = [], forwardStack = [], visitedURLs = Set.empty} - -logHistory hist ret@Page {pageURL = url', html = doc, appName = name} = do - dir <- getXdgDirectory XdgData name - createDirectoryIfMissing True dir - now <- getCurrentTime - let title = Txt.unpack $ getTitle $ XML.documentRoot doc - appendFile (dir "history.gmni") $ '\n' : intercalate " " [ - "=>", uriToStr' url', show now, title - ] - - return ret { pageTitle = title, visitedURLs = Set.insert (Txt.pack $ uriToStr' url') hist} - where - getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs] - getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs] - getTitle (XML.Element _ _ childs) - | title:_ <- [getTitle el | XML.NodeElement el <- childs] = title - | otherwise = "" - -uriToStr' :: URI -> String -uriToStr' uri = uriToString id uri "" - --------- ----- CSS charset sniffing --------- -applyCSScharset (charset:charsets) bytes - | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text - | otherwise = applyCSScharset charsets bytes - where - text = convertCharset charset bytes -applyCSScharset _ bytes = convertCharset "utf-8" bytes -cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks, - (CSSTok.String charset:_) <- skipCSSspace toks' = charset - | otherwise = "" -skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks -skipCSSspace toks = toks - --------- ----- Gemini implementation --------- --- Copied from css-syntax. -pattern (:.) :: Char -> Txt.Text -> Txt.Text -pattern x :. xs <- (Txt.uncons -> Just (x, xs)) - -infixr 5 :. - -el name text = XML.Element name M.empty [XML.NodeContent text] - -parseGemini :: Maybe String -> Txt.Text -> XML.Document -parseGemini lang txt = XML.Document { - XML.documentPrologue = XML.Prologue [] Nothing [], - XML.documentRoot = XML.Element { - XML.elementName = "body", - XML.elementAttributes = M.fromList [ - ("lang", Txt.pack lang') | Just langs <- [lang], lang' <- [csv langs]], - XML.elementNodes = map XML.NodeElement $ parseGemini' $ Txt.lines txt - }, - XML.documentEpilogue = [] - } - -csv (',':_) = "" -csv (c:rest) = c:csv rest -csv "" = "" - -parseGemini' :: [Txt.Text] -> [XML.Element] -parseGemini' (('#':.'#':.'#' :. '#':.'#':.'#':.line):lines) = - el "h6" line : parseGemini' lines -parseGemini' (('#':.'#':.'#' :. '#':.'#':.line):lines) = - el "h5" line : parseGemini' lines -parseGemini' (('#':.'#':.'#' :. '#':.line):lines) = - el "h4" line : parseGemini' lines -parseGemini' (('#':.'#':.'#':.line):lines) = el "h3" line : parseGemini' lines -parseGemini' (('#':.'#':.line):lines) = el "h2" line : parseGemini' lines -parseGemini' (('#':.line):lines) = el "h1" line : parseGemini' lines --- Not properly structured, but still sounds fine... -parseGemini' (('*':.line):lines) = el "li" line : parseGemini' lines -parseGemini' (('>':.line):lines) = el "blockquote" line : parseGemini' lines - -parseGemini' (('=':.'>':.line):lines) - | (url:text@(_:_)) <- Txt.words line = (el "a" $ Txt.unwords text) { - XML.elementAttributes = M.insert "href" url M.empty - } : parseGemini' lines - | otherwise = (el "a" $ Txt.strip line) { - XML.elementAttributes = M.insert "href" (Txt.strip line) M.empty - } : parseGemini' lines -parseGemini' (('`':.'`':.'`':.line):lines) = el "p" line : go lines - where - go (('`':.'`':.'`':._):lines) = parseGemini' lines - go (_:lines) = go lines - go [] = [] -parseGemini' ("```":lines) = go [] lines - where - go texts (('`':.'`':.'`':._):lines) = - el "pre" (Txt.unlines texts) : parseGemini' lines - go texts (line:lines) = go (texts ++ [line]) lines - go texts [] = [] - -parseGemini' (line:lines) = el "p" line : parseGemini' lines -parseGemini' [] = [] - --------- ----- TSV, CSV, etc --------- - -parseDelimitedValues _ "" row rows = reverse (reverse row : rows) -parseDelimitedValues delim ('\r':.cs) row rows = parseDelimitedValues delim cs row rows -parseDelimitedValues delim ('\n':.cs) row rows = parseDelimitedValues delim cs [] (reverse row : rows) -parseDelimitedValues delim (c:.'"':.cs) row rows | c == delim = - let (value, cs') = inner cs in parseDelimitedValues delim cs' (value:row) rows - where - inner (x:.y:.cs) | x == delim && y == delim = let (a, b) = inner cs in (delim `Txt.cons` a, b) - inner (c:.cs) | c == delim = ("", cs) - | otherwise = let (a, b) = inner cs in (c `Txt.cons` a, b) - inner "" = ("", "") -parseDelimitedValues delim (c:.cs) row rows | c == delim = - let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs - in parseDelimitedValues delim cs' (value:row) rows -parseDelimitedValues delim cs row rows = - let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs - in parseDelimitedValues delim cs (value:row) rows - -escapeDelimitedValues delim source = map (map inner) $ parseDelimitedValues delim source [] [] - where - inner = Txt.strip . Txt.replace "\\\\" "\\" . Txt.replace "\\n" "\n" . - Txt.replace "\\t" "\t" . Txt.replace "\\r" "\r" - -parseDelimitedToTable delim source - | (head:body) <- filter (not . null) $ escapeDelimitedValues delim source = - XML.Document { - XML.documentPrologue = XML.Prologue [] Nothing [], - XML.documentRoot = XML.Element { - XML.elementName = "table", - XML.elementAttributes = M.empty, - XML.elementNodes = rowToTr "th" head : map (rowToTr "td") body - }, - XML.documentEpilogue = [] - } - | otherwise = XML.Document { -- Empty TSV/CSV/etc - XML.documentPrologue = XML.Prologue [] Nothing [], - XML.documentRoot = XML.Element "table" M.empty [], - XML.documentEpilogue = [] - } -rowToTr tagname values = XML.NodeElement $ XML.Element "tr" M.empty $ map inner values - where - inner = XML.NodeElement . XML.Element tagname M.empty . singleton . XML.NodeContent - singleton a = [a] diff --git a/src/Network/MIME/XML/Table.hs b/src/Network/MIME/XML/Table.hs deleted file mode 100644 --- a/src/Network/MIME/XML/Table.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} -module Network.MIME.XML.Table(applySort, applySortDoc, splitTable) where - -import Text.XML -import Data.Text as Txt -import qualified Data.Map as M - -import Data.Maybe -import qualified Data.List as L -import Text.Read (readMaybe) - --- For smarter comparisons... -import Data.Time.Format (parseTimeM, defaultTimeLocale) -import Data.Time.Clock (UTCTime) -import Data.Char (isDigit) - -applySortDoc :: String -> Document -> Document -applySortDoc anchor doc@Document {documentRoot = el} = doc {documentRoot = applySort anchor el} - -applySort :: String -> Element -> Element -applySort ('#':'-':'a':'r':'g':'o':'-':'%':anchor) el - | (id', ord:col) <- L.break (`elem` ['<', '>']) anchor, Just col' <- readMaybe col = - applySort' id' (ord == '<') col' el -applySort _ el = el - -applySort' :: String -> Bool -> Int -> Element -> Element -applySort' ('.':id') asc col el@Element { elementNodes = childs } - | (ix, subpath) <- L.break (== '.') id', Just ix' <- readMaybe ix = - el { elementNodes = setAt ix' (rewriteNode subpath) childs } - | otherwise = el - where - rewriteNode p (NodeElement child) = NodeElement $ applySort' p asc col child - rewriteNode _ x = x -applySort' "" asc col el = applySort'' asc col el - -applySort' id' asc col el@Element { elementAttributes = attrs, elementNodes = childs } - | Just actual <- "id" `M.lookup` M.mapKeys nameLocalName attrs, pack id' == actual = - applySort'' asc col el - | otherwise = el { elementNodes = L.map searchNode childs } - where - searchNode (NodeElement child) = NodeElement $ applySort' id' asc col child - searchNode x = x - -applySort'' asc col el - | Just sortable <- table2sorttable el = el { - elementNodes = annotateTHead header asc col ++ - (L.concatMap (L.map NodeElement . markup) $ L.sortBy compareRows sortable) - ++ footer - } - | otherwise = el - where - compareRows (TableRow a _) (TableRow b _) - | asc = compareAs (a !! col) (b !! col) (comparators !! col) - | otherwise = compareAs (b !! col) (a !! col) (comparators !! col) - (header, _, footer) = splitTable $ elementNodes el - comparators = tableHeadComparators header - -data TableRow = TableRow { keys :: [Text], markup :: [Element] } - -table2sorttable Element { - elementName = Name "table" _ _, - elementAttributes = attrs, - elementNodes = childs - } | "-argo-unsortable" `notElem` attrs, (_, body, _) <- splitTable childs = - trs2sorttable body -table2sorttable _ = Nothing - -splitTable :: [Node] -> ([Node], [Element], [Node]) -splitTable (NodeElement el@Element { elementName = Name "caption" _ _}:els) = - let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer) -splitTable (NodeElement el@Element { elementName = Name "colgroup" _ _}:els) = - let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer) -splitTable (NodeElement el@Element { elementName = Name "thead" _ _}:els) = - let (body, footer) = splitTableBody els in ([NodeElement el], body, footer) -splitTable (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs}:els) - | L.all (== "th") [nameLocalName $ elementName el | NodeElement el <- childs] = - let (body, footer) = splitTableBody els in ([NodeElement el], body, footer) -splitTable els@(NodeElement _:_) = - let (body, footer) = splitTableBody els in ([], body, footer) -splitTable (_:els) = splitTable els -splitTable [] = ([], [], []) - -splitTableBody :: [Node] -> ([Element], [Node]) -splitTableBody (NodeElement el@Element { elementName = Name "tbody" _ _, elementNodes = childs }:els) = - ([el | NodeElement el@Element { elementName = Name "tr" _ _ } <- childs], els) -splitTableBody (NodeElement el@Element { elementName = Name "tr" _ _ }:els) = - let (body, footer) = splitTableBody els in (el:body, footer) -splitTableBody els@(NodeElement _:_) = ([], els) -splitTableBody (_:els) = splitTableBody els -splitTableBody [] = ([], []) - -tableHeadComparators :: [Node] -> [Text] -tableHeadComparators = Prelude.map (fromMaybe "alphanumeric") . tableHeadComparators' -tableHeadComparators' :: [Node] -> [Maybe Text] -tableHeadComparators' (NodeElement el@Element { elementName = Name name _ _, elementNodes = childs}:els) - | name == "thead" = tableHeadComparators' childs `mergeRight` tableHeadComparators' els - | name `elem` ["colgroup", "tr"] = tableRowComparators childs `mergeRight` tableHeadComparators' els - | otherwise = tableHeadComparators' els -tableHeadComparators' [] = [] -tableRowComparators :: [Node] -> [Maybe Text] -tableRowComparators (NodeElement el@(Element (Name "col" _ _) attrs _):els) = - let colspan = fromMaybe 1 (M.lookup "span" attrs >>= readMaybe . unpack) - in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els -tableRowComparators (NodeElement el@(Element (Name n _ _) attrs _):els) | n `elem` ["td", "th"] = - let colspan = fromMaybe 1 (M.lookup "colspan" attrs >>= readMaybe . unpack) - in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els -tableRowComparators (_:els) = tableRowComparators els -tableRowComparators [] = [] -mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a] -mergeRight (_:as) (Just b:bs) = Just b : mergeRight as bs -mergeRight (a:as) (_:bs) = a : mergeRight as bs -mergeRight [] bs = bs -mergeRight as [] = as - -annotateTHead (NodeElement el@Element { elementName = Name "thead" _ _, elementNodes = childs }:nodes) a c = - NodeElement el { elementNodes = annotateTHead childs a c } : nodes -annotateTHead (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs }:nodes) a c = - NodeElement el { elementNodes = annotateTR childs a c 0 } : nodes -annotateTHead (child:childs) a c = child:annotateTHead childs a c -annotateTHead [] _ _ = [] - -annotateTR (NodeElement el@Element { elementName = Name n _ _, elementAttributes = attrs }:nodes) asc col count - | n `elem` ["th", "td"], count >= col = - NodeElement el { elementAttributes = M.insert "aria-sort" asc' attrs }:nodes - | n `elem` ["th", "td"] = NodeElement el:annotateTR nodes asc col (count + colspan) - where - colspan = fromMaybe 1 (readMaybe =<< unpack <$> M.lookup "colspan" attrs') - attrs' = M.mapKeys nameLocalName attrs - asc' | asc = "ascending" - | otherwise = "descending" -annotateTR (node:nodes) a c n = node:annotateTR nodes a c n -annotateTR [] _ _ _ = [] - -trs2sorttable els@(el@Element { elementName = Name "tr" _ _, elementNodes = childs }:_) - | Just keys' <- tds2keys [el | NodeElement el <- childs], - Just (group, rest) <- groupTrs els 1, - Just rest' <- trs2sorttable rest = Just (TableRow keys' group : rest') -trs2sorttable [] = Just [] -trs2sorttable _ = Nothing - -tds2keys :: [Element] -> Maybe [Text] -tds2keys (el@Element {elementName = Name n _ _, elementAttributes = attrs, elementNodes = childs }:els) - | n `elem` ["td", "th"], Just key <- "-argo-sortkey" `M.lookup` attrs, Just rest <- tds2keys els = - Just (Prelude.replicate colspan key ++ rest) - | n `elem` ["td", "th"], Just rest <- tds2keys els = - Just (Prelude.replicate colspan (nodesText childs) ++ rest) - where - colspan | Just n <- "colspan" `M.lookup` M.mapKeys nameLocalName attrs, - Just m <- readMaybe $ unpack n = m - | otherwise = 1 -tds2keys [] = Just [] -tds2keys _ = Nothing - -groupTrs (el@Element {elementName = Name "tr" _ _}:els) n - | rowRowspan n el <= 1 = Just (el:[], els) - | Just (tail, rest) <- groupTrs els $ pred n = Just (el:tail, rest) -groupTrs (_:els) n = groupTrs els n -groupTrs _ _ = Nothing - -rowRowspan n Element {elementName = Name "tr" _ _, elementNodes = childs } = - Prelude.maximum (n : [n | - NodeElement (Element (Name name _ _) attrs _) <- childs, - name `elem` ["td", "th"], - rowspan <- maybeToList ("rowspan" `M.lookup` M.mapKeys nameLocalName attrs), - n <- maybeToList $ readMaybe $ unpack rowspan]) - - ---- Utils - -(+++) = append -nodesText :: [Node] -> Text -nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes -nodesText (NodeContent text:nodes) = text +++ nodesText nodes -nodesText (_:nodes) = nodesText nodes -nodesText [] = "" - -setAt :: Int -> (a -> a) -> [a] -> [a] -setAt i a ls - | i < 0 = ls - | otherwise = go i ls - where - go 0 (x:xs) = a x : xs - go n (x:xs) = x : go (n-1) xs - go _ [] = [] - -pattern (:.) :: Char -> Txt.Text -> Txt.Text -pattern x :. xs <- (Txt.uncons -> Just (x, xs)) - -infixr 5 :. - -compareAs :: Text -> Text -> Text -> Ordering ---- Hueristic that readily handles both numbers & text -compareAs (a:.as) (b:.bs) "alphanumeric" - | isDigit a && isDigit b = - let (a', as') = Txt.break (not . isDigit) as - (b', bs') = Txt.break (not . isDigit) bs - in if Txt.length a' == Txt.length b' && a == b - then compareAs as bs "alphanumeric" - else if Txt.length a' == Txt.length b' then a `compare` b - else Txt.length a' `compare` Txt.length b' - | a == b = compareAs as bs "alphanumeric" - | otherwise = a `compare` b -compareAs as bs "text" = as `compare` bs -compareAs as bs "number" = readInt as `compare` readInt bs - where - readInt :: Text -> Maybe Float - readInt = readMaybe . Prelude.filter (`elem` '-':'.':['0'..'9']) . unpack -compareAs as bs fmt = readTime as `compare` readTime bs - where - readTime :: Text -> Maybe UTCTime - readTime = parseTimeM True defaultTimeLocale (unpack fmt) . unpack diff --git a/src/Network/URI/Fetch/XML.hs b/src/Network/URI/Fetch/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Fetch/XML.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Network.URI.Fetch.XML(Page(..), loadVisited, + fetchDocument, pageForText, applyCSScharset, readStrict) where + +import Data.Text.Lazy (fromStrict) +import qualified Data.Text as Txt +import Data.Text (Text) +import qualified Data.Text.IO as Txt +import Data.Text.Encoding +import qualified Data.Text.Lazy as LTxt +import qualified Data.ByteString.Lazy as B +import qualified Text.HTML.DOM as HTML +import qualified Text.XML as XML +import Text.XML (Document(..)) +import Network.URI +import Network.URI.Fetch +import Network.URI.Charset +import qualified Data.Map as M +import qualified Data.Set as Set +import Data.Set (Set(..)) +import Data.List (intercalate) +import Data.Time.Clock + +-- For alternative styles +import qualified Data.CSS.Syntax.Tokens as CSSTok +import Stylist.Parse + +import System.IO +import System.IO.Temp +import Data.Default.Class +import System.Directory +import System.FilePath (()) +import Data.FileEmbed +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) + +import Network.URI.Fetch.XML.Table -- Apply table sorting here... +import Data.HTML2CSS (html2css) + +data Page styles = Page { + pageURL :: URI, + css :: styles, + initCSS :: URI -> String -> styles, + domain :: String, + html :: Document, + pageTitle :: String, + pageMIME :: String, + apps :: [Application], + backStack :: [(String, URI)], + forwardStack :: [(String, URI)], + -- Probably don't need an MVar here, but let's be safe! + visitedURLs :: Set Text, + appName :: String +} + +loadVisited :: String -> IO (Set Text) +loadVisited appname = do + dir <- getXdgDirectory XdgData appname + let path = dir "history.gmni" + exists <- doesFileExist path + + if exists then do + file <- readStrict path + let hist = Set.fromList [Txt.pack uri | _:uri:_ <- map words $ lines file] + return hist + else return Set.empty + +readStrict path = do s <- Prelude.readFile path; length s `seq` return s + +utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes +aCCEPT = ["text/xml", "application/xml", "text/html", "text/gemini", + "text/csv", "text/tab-separated-values", "text/css", "text/*", "*/*"] + +fetchDocument http referer URI { uriScheme = "action:", uriPath = "nocache" } = + fetchDocument http { cachingEnabled = False } referer $ pageURL referer +fetchDocument http referer URI { uriScheme = "action:", uriPath = "novalidate" } = + fetchDocument http { validateCertificates = False } referer $ pageURL referer +fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/back" } = + fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False + where referer' = shiftHistory referer (-1) +fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/forward" } = + fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False + where referer' = shiftHistory referer 1 +fetchDocument http referer URI { + uriScheme = "action:", uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x + } | Just x' <- readMaybe x, referer' <- shiftHistory referer x' = + fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer http False +fetchDocument http referer URI { uriScheme = "app:", uriPath = appID } = do + dispatchByApp http Application { + name = "", icon = nullURI, description = "", + appId = appID + } (pageMIME referer) $ pageURL referer + return referer -- TODO play an error or success sound +fetchDocument http referer@Page { pageURL = uri0 } uri@URI { uriFragment = anchor } + | uri { uriFragment = "" } == uri0 { uriFragment = "" } = return referer { + html = applySortDoc anchor $ html referer, + pageURL = uri + } +fetchDocument http referer uri = fetchURL' http aCCEPT uri >>= parseDocument' referer http True + +shiftHistory :: Page style -> Integer -> Page style +shiftHistory self 0 = self +shiftHistory self@Page { backStack = (title, url):bs } delta | delta < 0 = + shiftHistory self { + backStack = bs, + forwardStack = (pageTitle self, pageURL self):forwardStack self, + pageTitle = title, + pageURL = url + } $ succ delta +shiftHistory self@Page { forwardStack = (title, url):fs } delta | delta > 0 = + shiftHistory self { + forwardStack = fs, + backStack = (pageTitle self, pageURL self):backStack self, + pageTitle = title, + pageURL = url + } $ pred delta +shiftHistory self _ = self -- Error case. + +parseDocument' ref@Page {visitedURLs = hist} sess saveHist resp@(URI {uriFragment = anch}, mime, _) = do + page <- parseDocument ref {domain = "document"} sess resp >>= logHistory hist + apps' <- appsForMIME sess mime + return $ attachHistory page { + pageMIME = mime, + apps = apps', + html = applySortDoc anch $ html page + } + where + attachHistory x@Page { pageTitle = title, pageURL = url } + | saveHist = x { backStack = (title, url):backStack ref, forwardStack = forwardStack ref } + | otherwise = x +parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString) + -> IO (Page s) +parseDocument ref sess (uri, "html/x-error\t", resp) = + parseDocument ref { domain = "error" } sess (uri, "text/html", resp) +parseDocument p _ (uri, "text/html", Left text) = + pageForDoc p uri $ HTML.parseLT $ fromStrict text +parseDocument p _(uri, "text/html", Right bytes) = + pageForDoc p uri $ HTML.parseLBS bytes +parseDocument p _ + (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Left text) = + pageForDoc p uri $ parseGemini (Just lang) text +parseDocument p _ + (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Right bytes) = + pageForDoc p uri $ parseGemini (Just lang) $ utf8' bytes +parseDocument p _ (uri, "text/gemini", Left text) = + pageForDoc p uri $ parseGemini Nothing text +parseDocument p _ (uri, "text/gemini", Right bytes) = + pageForDoc p uri $ parseGemini Nothing $ utf8' bytes +parseDocument a b (a', b'@"text/css", Right bytes) = + parseDocument a b (a', b', Left $ applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes) +parseDocument referer@Page {pageURL = uri', initCSS = css', appName = name} _ + (uri, "text/css", Left text) + | URI {uriAuthority = Just host} <- pageURL referer = do + -- Save this per-domain setting + dir <- ( "domain") <$> getXdgDirectory XdgConfig name + createDirectoryIfMissing True dir + Txt.writeFile (dir uriRegName host) $ + CSSTok.serialize $ map absolutizeCSS $ CSSTok.tokenize text + + return ret + | otherwise = return ret + where + ret = referer { + css = parseForURL (css' uri' "document") uri text + } + absolutizeCSS (CSSTok.Url text) | Just rel <- parseRelativeReference $ Txt.unpack text = + CSSTok.Url $ Txt.pack $ uriToStr' $ relativeTo rel uri' + absolutizeCSS tok = tok +parseDocument ref _ (uri, "text/csv", Left body) = + pageForDoc ref uri $ parseDelimitedToTable ',' body +parseDocument ref _ (uri, "text/tab-separated-values", Left body) = + pageForDoc ref uri $ parseDelimitedToTable '\t' body +parseDocument ref _ (uri, "text/csv", Right body) = + pageForDoc ref uri $ parseDelimitedToTable ',' $ utf8' body +parseDocument ref _ (uri, "text/tab-separated-values", Right body) = + pageForDoc ref uri $ parseDelimitedToTable '\t' $ utf8' body + +parseDocument ref sess (uri, mime, body) | mime' /= mime = parseDocument ref sess (uri, mime', body) + where mime' = takeWhile (/= ';') mime +parseDocument p _ (uri, _, Left text) + | Right doc <- XML.parseText def $ fromStrict text = pageForDoc p uri doc + | otherwise = pageForText p uri text +parseDocument p _ (uri, _, Right bytes) + | Right doc <- XML.parseLBS def bytes = pageForDoc p uri doc +parseDocument p _ (uri, 't':'e':'x':'t':'/':_, Right bytes) = + -- charset wasn't specified, so assume utf-8. + pageForText p uri $ utf8' bytes +parseDocument p sess resp@(uri, mime, _) = do + dir <- getCurrentDirectory -- TODO find Downloads directory. + ret <- saveDownload nullURI { + uriScheme = "file:", + uriAuthority = Just (URIAuth "" "" "") + } dir resp >>= dispatchByMIME sess mime + pageForDoc p uri $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret + +pageForText referer uri txt = pageForDoc referer uri XML.Document { + XML.documentPrologue = XML.Prologue [] Nothing [], + XML.documentRoot = XML.Element { + XML.elementName = "pre", + XML.elementAttributes = M.empty, + XML.elementNodes = [XML.NodeContent txt] + }, + XML.documentEpilogue = [] + } + +pageForDoc :: StyleSheet s => Page s -> URI -> Document -> IO (Page s) +pageForDoc referer@Page {initCSS = css', appName = appname, domain = d} uri doc = do + -- See if the user has configured an alternate stylesheet for this domain. + let authorStyle = return $ html2css doc uri $ css' uri d + styles <- case uriAuthority uri of + Nothing -> authorStyle + Just host -> do + dir <- getXdgDirectory XdgConfig appname + let path = dir "domain" uriRegName host + hasAltStyle <- doesFileExist path + if not hasAltStyle then authorStyle else parse (css' uri d) <$> Txt.readFile path + + return referer {pageURL = uri, html = doc, css = styles} + +logHistory hist ret@Page {pageURL = url', html = doc, appName = name} = do + dir <- getXdgDirectory XdgData name + createDirectoryIfMissing True dir + now <- getCurrentTime + let title = Txt.unpack $ getTitle $ XML.documentRoot doc + appendFile (dir "history.gmni") $ '\n' : intercalate " " [ + "=>", uriToStr' url', show now, title + ] + + return ret { pageTitle = title, visitedURLs = Set.insert (Txt.pack $ uriToStr' url') hist} + where + getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs] + getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs] + getTitle (XML.Element _ _ childs) + | title:_ <- [getTitle el | XML.NodeElement el <- childs] = title + | otherwise = "" + +uriToStr' :: URI -> String +uriToStr' uri = uriToString id uri "" + +-------- +---- CSS charset sniffing +-------- +applyCSScharset (charset:charsets) bytes + | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text + | otherwise = applyCSScharset charsets bytes + where + text = convertCharset charset bytes +applyCSScharset _ bytes = convertCharset "utf-8" bytes +cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks, + (CSSTok.String charset:_) <- skipCSSspace toks' = charset + | otherwise = "" +skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks +skipCSSspace toks = toks + +-------- +---- Gemini implementation +-------- +-- Copied from css-syntax. +pattern (:.) :: Char -> Txt.Text -> Txt.Text +pattern x :. xs <- (Txt.uncons -> Just (x, xs)) + +infixr 5 :. + +el name text = XML.Element name M.empty [XML.NodeContent text] + +parseGemini :: Maybe String -> Txt.Text -> XML.Document +parseGemini lang txt = XML.Document { + XML.documentPrologue = XML.Prologue [] Nothing [], + XML.documentRoot = XML.Element { + XML.elementName = "body", + XML.elementAttributes = M.fromList [ + ("lang", Txt.pack lang') | Just langs <- [lang], lang' <- [csv langs]], + XML.elementNodes = map XML.NodeElement $ parseGemini' $ Txt.lines txt + }, + XML.documentEpilogue = [] + } + +csv (',':_) = "" +csv (c:rest) = c:csv rest +csv "" = "" + +parseGemini' :: [Txt.Text] -> [XML.Element] +parseGemini' (('#':.'#':.'#' :. '#':.'#':.'#':.line):lines) = + el "h6" line : parseGemini' lines +parseGemini' (('#':.'#':.'#' :. '#':.'#':.line):lines) = + el "h5" line : parseGemini' lines +parseGemini' (('#':.'#':.'#' :. '#':.line):lines) = + el "h4" line : parseGemini' lines +parseGemini' (('#':.'#':.'#':.line):lines) = el "h3" line : parseGemini' lines +parseGemini' (('#':.'#':.line):lines) = el "h2" line : parseGemini' lines +parseGemini' (('#':.line):lines) = el "h1" line : parseGemini' lines +-- Not properly structured, but still sounds fine... +parseGemini' (('*':.line):lines) = el "li" line : parseGemini' lines +parseGemini' (('>':.line):lines) = el "blockquote" line : parseGemini' lines + +parseGemini' (('=':.'>':.line):lines) + | (url:text@(_:_)) <- Txt.words line = (el "a" $ Txt.unwords text) { + XML.elementAttributes = M.insert "href" url M.empty + } : parseGemini' lines + | otherwise = (el "a" $ Txt.strip line) { + XML.elementAttributes = M.insert "href" (Txt.strip line) M.empty + } : parseGemini' lines +parseGemini' (('`':.'`':.'`':.line):lines) = el "p" line : go lines + where + go (('`':.'`':.'`':._):lines) = parseGemini' lines + go (_:lines) = go lines + go [] = [] +parseGemini' ("```":lines) = go [] lines + where + go texts (('`':.'`':.'`':._):lines) = + el "pre" (Txt.unlines texts) : parseGemini' lines + go texts (line:lines) = go (texts ++ [line]) lines + go texts [] = [] + +parseGemini' (line:lines) = el "p" line : parseGemini' lines +parseGemini' [] = [] + +-------- +---- TSV, CSV, etc +-------- + +parseDelimitedValues _ "" row rows = reverse (reverse row : rows) +parseDelimitedValues delim ('\r':.cs) row rows = parseDelimitedValues delim cs row rows +parseDelimitedValues delim ('\n':.cs) row rows = parseDelimitedValues delim cs [] (reverse row : rows) +parseDelimitedValues delim (c:.'"':.cs) row rows | c == delim = + let (value, cs') = inner cs in parseDelimitedValues delim cs' (value:row) rows + where + inner (x:.y:.cs) | x == delim && y == delim = let (a, b) = inner cs in (delim `Txt.cons` a, b) + inner (c:.cs) | c == delim = ("", cs) + | otherwise = let (a, b) = inner cs in (c `Txt.cons` a, b) + inner "" = ("", "") +parseDelimitedValues delim (c:.cs) row rows | c == delim = + let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs + in parseDelimitedValues delim cs' (value:row) rows +parseDelimitedValues delim cs row rows = + let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs + in parseDelimitedValues delim cs (value:row) rows + +escapeDelimitedValues delim source = map (map inner) $ parseDelimitedValues delim source [] [] + where + inner = Txt.strip . Txt.replace "\\\\" "\\" . Txt.replace "\\n" "\n" . + Txt.replace "\\t" "\t" . Txt.replace "\\r" "\r" + +parseDelimitedToTable delim source + | (head:body) <- filter (not . null) $ escapeDelimitedValues delim source = + XML.Document { + XML.documentPrologue = XML.Prologue [] Nothing [], + XML.documentRoot = XML.Element { + XML.elementName = "table", + XML.elementAttributes = M.empty, + XML.elementNodes = rowToTr "th" head : map (rowToTr "td") body + }, + XML.documentEpilogue = [] + } + | otherwise = XML.Document { -- Empty TSV/CSV/etc + XML.documentPrologue = XML.Prologue [] Nothing [], + XML.documentRoot = XML.Element "table" M.empty [], + XML.documentEpilogue = [] + } +rowToTr tagname values = XML.NodeElement $ XML.Element "tr" M.empty $ map inner values + where + inner = XML.NodeElement . XML.Element tagname M.empty . singleton . XML.NodeContent + singleton a = [a] diff --git a/src/Network/URI/Fetch/XML/Table.hs b/src/Network/URI/Fetch/XML/Table.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Fetch/XML/Table.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} +module Network.URI.Fetch.XML.Table(applySort, applySortDoc, splitTable) where + +import Text.XML +import Data.Text as Txt +import qualified Data.Map as M + +import Data.Maybe +import qualified Data.List as L +import Text.Read (readMaybe) + +-- For smarter comparisons... +import Data.Time.Format (parseTimeM, defaultTimeLocale) +import Data.Time.Clock (UTCTime) +import Data.Char (isDigit) + +applySortDoc :: String -> Document -> Document +applySortDoc anchor doc@Document {documentRoot = el} = doc {documentRoot = applySort anchor el} + +applySort :: String -> Element -> Element +applySort ('#':'-':'a':'r':'g':'o':'-':'%':anchor) el + | (id', ord:col) <- L.break (`elem` ['<', '>']) anchor, Just col' <- readMaybe col = + applySort' id' (ord == '<') col' el +applySort _ el = el + +applySort' :: String -> Bool -> Int -> Element -> Element +applySort' ('.':id') asc col el@Element { elementNodes = childs } + | (ix, subpath) <- L.break (== '.') id', Just ix' <- readMaybe ix = + el { elementNodes = setAt ix' (rewriteNode subpath) childs } + | otherwise = el + where + rewriteNode p (NodeElement child) = NodeElement $ applySort' p asc col child + rewriteNode _ x = x +applySort' "" asc col el = applySort'' asc col el + +applySort' id' asc col el@Element { elementAttributes = attrs, elementNodes = childs } + | Just actual <- "id" `M.lookup` M.mapKeys nameLocalName attrs, pack id' == actual = + applySort'' asc col el + | otherwise = el { elementNodes = L.map searchNode childs } + where + searchNode (NodeElement child) = NodeElement $ applySort' id' asc col child + searchNode x = x + +applySort'' asc col el + | Just sortable <- table2sorttable el = el { + elementNodes = annotateTHead header asc col ++ + (L.concatMap (L.map NodeElement . markup) $ L.sortBy compareRows sortable) + ++ footer + } + | otherwise = el + where + compareRows (TableRow a _) (TableRow b _) + | asc = compareAs (a !! col) (b !! col) (comparators !! col) + | otherwise = compareAs (b !! col) (a !! col) (comparators !! col) + (header, _, footer) = splitTable $ elementNodes el + comparators = tableHeadComparators header + +data TableRow = TableRow { keys :: [Text], markup :: [Element] } + +table2sorttable Element { + elementName = Name "table" _ _, + elementAttributes = attrs, + elementNodes = childs + } | "-argo-unsortable" `notElem` attrs, (_, body, _) <- splitTable childs = + trs2sorttable body +table2sorttable _ = Nothing + +splitTable :: [Node] -> ([Node], [Element], [Node]) +splitTable (NodeElement el@Element { elementName = Name "caption" _ _}:els) = + let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer) +splitTable (NodeElement el@Element { elementName = Name "colgroup" _ _}:els) = + let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer) +splitTable (NodeElement el@Element { elementName = Name "thead" _ _}:els) = + let (body, footer) = splitTableBody els in ([NodeElement el], body, footer) +splitTable (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs}:els) + | L.all (== "th") [nameLocalName $ elementName el | NodeElement el <- childs] = + let (body, footer) = splitTableBody els in ([NodeElement el], body, footer) +splitTable els@(NodeElement _:_) = + let (body, footer) = splitTableBody els in ([], body, footer) +splitTable (_:els) = splitTable els +splitTable [] = ([], [], []) + +splitTableBody :: [Node] -> ([Element], [Node]) +splitTableBody (NodeElement el@Element { elementName = Name "tbody" _ _, elementNodes = childs }:els) = + ([el | NodeElement el@Element { elementName = Name "tr" _ _ } <- childs], els) +splitTableBody (NodeElement el@Element { elementName = Name "tr" _ _ }:els) = + let (body, footer) = splitTableBody els in (el:body, footer) +splitTableBody els@(NodeElement _:_) = ([], els) +splitTableBody (_:els) = splitTableBody els +splitTableBody [] = ([], []) + +tableHeadComparators :: [Node] -> [Text] +tableHeadComparators = Prelude.map (fromMaybe "alphanumeric") . tableHeadComparators' +tableHeadComparators' :: [Node] -> [Maybe Text] +tableHeadComparators' (NodeElement el@Element { elementName = Name name _ _, elementNodes = childs}:els) + | name == "thead" = tableHeadComparators' childs `mergeRight` tableHeadComparators' els + | name `elem` ["colgroup", "tr"] = tableRowComparators childs `mergeRight` tableHeadComparators' els + | otherwise = tableHeadComparators' els +tableHeadComparators' [] = [] +tableRowComparators :: [Node] -> [Maybe Text] +tableRowComparators (NodeElement el@(Element (Name "col" _ _) attrs _):els) = + let colspan = fromMaybe 1 (M.lookup "span" attrs >>= readMaybe . unpack) + in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els +tableRowComparators (NodeElement el@(Element (Name n _ _) attrs _):els) | n `elem` ["td", "th"] = + let colspan = fromMaybe 1 (M.lookup "colspan" attrs >>= readMaybe . unpack) + in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els +tableRowComparators (_:els) = tableRowComparators els +tableRowComparators [] = [] +mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a] +mergeRight (_:as) (Just b:bs) = Just b : mergeRight as bs +mergeRight (a:as) (_:bs) = a : mergeRight as bs +mergeRight [] bs = bs +mergeRight as [] = as + +annotateTHead (NodeElement el@Element { elementName = Name "thead" _ _, elementNodes = childs }:nodes) a c = + NodeElement el { elementNodes = annotateTHead childs a c } : nodes +annotateTHead (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs }:nodes) a c = + NodeElement el { elementNodes = annotateTR childs a c 0 } : nodes +annotateTHead (child:childs) a c = child:annotateTHead childs a c +annotateTHead [] _ _ = [] + +annotateTR (NodeElement el@Element { elementName = Name n _ _, elementAttributes = attrs }:nodes) asc col count + | n `elem` ["th", "td"], count >= col = + NodeElement el { elementAttributes = M.insert "aria-sort" asc' attrs }:nodes + | n `elem` ["th", "td"] = NodeElement el:annotateTR nodes asc col (count + colspan) + where + colspan = fromMaybe 1 (readMaybe =<< unpack <$> M.lookup "colspan" attrs') + attrs' = M.mapKeys nameLocalName attrs + asc' | asc = "ascending" + | otherwise = "descending" +annotateTR (node:nodes) a c n = node:annotateTR nodes a c n +annotateTR [] _ _ _ = [] + +trs2sorttable els@(el@Element { elementName = Name "tr" _ _, elementNodes = childs }:_) + | Just keys' <- tds2keys [el | NodeElement el <- childs], + Just (group, rest) <- groupTrs els 1, + Just rest' <- trs2sorttable rest = Just (TableRow keys' group : rest') +trs2sorttable [] = Just [] +trs2sorttable _ = Nothing + +tds2keys :: [Element] -> Maybe [Text] +tds2keys (el@Element {elementName = Name n _ _, elementAttributes = attrs, elementNodes = childs }:els) + | n `elem` ["td", "th"], Just key <- "-argo-sortkey" `M.lookup` attrs, Just rest <- tds2keys els = + Just (Prelude.replicate colspan key ++ rest) + | n `elem` ["td", "th"], Just rest <- tds2keys els = + Just (Prelude.replicate colspan (nodesText childs) ++ rest) + where + colspan | Just n <- "colspan" `M.lookup` M.mapKeys nameLocalName attrs, + Just m <- readMaybe $ unpack n = m + | otherwise = 1 +tds2keys [] = Just [] +tds2keys _ = Nothing + +groupTrs (el@Element {elementName = Name "tr" _ _}:els) n + | rowRowspan n el <= 1 = Just (el:[], els) + | Just (tail, rest) <- groupTrs els $ pred n = Just (el:tail, rest) +groupTrs (_:els) n = groupTrs els n +groupTrs _ _ = Nothing + +rowRowspan n Element {elementName = Name "tr" _ _, elementNodes = childs } = + Prelude.maximum (n : [n | + NodeElement (Element (Name name _ _) attrs _) <- childs, + name `elem` ["td", "th"], + rowspan <- maybeToList ("rowspan" `M.lookup` M.mapKeys nameLocalName attrs), + n <- maybeToList $ readMaybe $ unpack rowspan]) + + +--- Utils + +(+++) = append +nodesText :: [Node] -> Text +nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes +nodesText (NodeContent text:nodes) = text +++ nodesText nodes +nodesText (_:nodes) = nodesText nodes +nodesText [] = "" + +setAt :: Int -> (a -> a) -> [a] -> [a] +setAt i a ls + | i < 0 = ls + | otherwise = go i ls + where + go 0 (x:xs) = a x : xs + go n (x:xs) = x : go (n-1) xs + go _ [] = [] + +pattern (:.) :: Char -> Txt.Text -> Txt.Text +pattern x :. xs <- (Txt.uncons -> Just (x, xs)) + +infixr 5 :. + +compareAs :: Text -> Text -> Text -> Ordering +--- Hueristic that readily handles both numbers & text +compareAs (a:.as) (b:.bs) "alphanumeric" + | isDigit a && isDigit b = + let (a', as') = Txt.break (not . isDigit) as + (b', bs') = Txt.break (not . isDigit) bs + in if Txt.length a' == Txt.length b' && a == b + then compareAs as bs "alphanumeric" + else if Txt.length a' == Txt.length b' then a `compare` b + else Txt.length a' `compare` Txt.length b' + | a == b = compareAs as bs "alphanumeric" + | otherwise = a `compare` b +compareAs as bs "text" = as `compare` bs +compareAs as bs "number" = readInt as `compare` readInt bs + where + readInt :: Text -> Maybe Float + readInt = readMaybe . Prelude.filter (`elem` '-':'.':['0'..'9']) . unpack +compareAs as bs fmt = readTime as `compare` readTime bs + where + readTime :: Text -> Maybe UTCTime + readTime = parseTimeM True defaultTimeLocale (unpack fmt) . unpack