From 4777781c993cd203ea4ed19aa19926eaf011eb60 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 6 Apr 2020 13:21:30 +1200 Subject: [PATCH] Export C APIs from files defining underlying functions. --- src/CExports.hs | 108 +++--------------------------------------------- src/Input.hs | 26 ++++++++++++ src/Links.hs | 24 ++++++++++- src/Render.hs | 19 ++++++++- 4 files changed, 73 insertions(+), 104 deletions(-) diff --git a/src/CExports.hs b/src/CExports.hs index f25efd7..cf49bd3 100644 --- a/src/CExports.hs +++ b/src/CExports.hs @@ -1,87 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module CExports(c_newSession) where +module CExports where --- For c_newSession -import Network.URI.Fetch (Session, newSession) +import Types +import Network.URI.Fetch (Session) --- For data Page -import StyleTree (StyleTree) -import Data.CSS.Preprocessor.Conditions (ConditionalStyles, conditionalStyles) -import Text.XML -import qualified Data.Map.Strict as M -import Network.URI - -import Control.Monad (forM) - --- For c_fetchURLs -import System.Directory (getCurrentDirectory) -- default referer URI -import Control.Concurrent.Async (forConcurrently, concurrently) -import Data.Maybe (catMaybes, fromMaybe) - -import Input (fetchDocument, docForText) -import Data.HTML2CSS (html2css) - --- For c_renderDoc -import Render (retreiveStyles, renderDoc) -import Data.ByteString.Lazy (toStrict) -import Data.ByteString (useAsCString) - --- For c_extractLinks -import Links (Link(..), extractLinks) -import qualified Data.Text.Foreign as Txt -import Data.Text (strip) +import Render (c_renderDoc) +import Links (c_extractLinks) -- Types I can export to C -import Foreign.Ptr import Foreign.StablePtr import Foreign.C.String import Foreign.Marshal.Array -import Foreign.Marshal.Alloc - -type CArray a = Ptr a - -foreign export ccall c_newSession :: IO (StablePtr Session) -foreign export ccall c_freeSession :: StablePtr Session -> IO () - -c_newSession = newSession >>= newStablePtr -c_freeSession = freeStablePtr - - -data Page = Page {url :: URI, css :: ConditionalStyles StyleTree, html :: Document} -type PtrPage = Ptr () - -foreign export ccall c_initialReferer :: IO (StablePtr Page) - -c_initialReferer = do - cwd <- getCurrentDirectory - newStablePtr $ Page { - -- Default to URIs being relative to CWD. - url = URI {uriScheme = "file:", uriPath = cwd, - uriAuthority = Nothing, uriQuery = "", uriFragment = ""}, - -- Blank values: - css = conditionalStyles nullURI "temp", - html = Document { - documentPrologue = Prologue [] Nothing [], - documentRoot = Element "temp" M.empty [], - documentEpilogue = [] - } - } - -foreign export ccall c_freePage :: StablePtr Page -> IO () - -c_freePage = freeStablePtr - - -foreign export ccall c_fetchURL :: StablePtr Session -> CString -> StablePtr Page -> CString -> IO (StablePtr Page) - -c_fetchURL c_session c_mimes c_referer c_uri = do - session <- deRefStablePtr c_session - mimes <- peekCString c_mimes - referer <- deRefStablePtr c_referer - uri <- peekCString c_uri - let uri' = nullURI `fromMaybe` parseURIReference uri `relativeTo` url referer - doc <- fetchDocument session (words mimes) uri' - newStablePtr $ Page {url = uri', html = doc, css = html2css doc uri'} -- FIXME: Segfaults, was intended for a playlist feature --foreign export ccall c_fetchURLs :: StablePtr Session -> PtrPage -> CArray CString -> IO (CArray PtrPage) @@ -104,32 +33,7 @@ c_fetchURL c_session c_mimes c_referer c_uri = do --pairs _ = [] --pair a b = (a, b) - -foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr Page -> IO CString -- Hard to C bindings without IO - -c_renderDoc c_session c_page = do - session <- deRefStablePtr c_session - page <- deRefStablePtr c_page - css' <- retreiveStyles session $ css page - toStrict (renderDoc css' $ documentRoot $ html page) `useAsCString` \cstr -> do - str <- peekCString cstr - newCString str - - -foreign export ccall c_extractLinks :: StablePtr Page -> IO (CArray CString) - -c_extractLinks c_page = do - page <- deRefStablePtr c_page - ret <- forM (extractLinks $ html page) $ \link -> do - c_label <- text2cstring $ strip $ label link - c_title <- text2cstring $ strip $ title link - c_href <- newCString $ uriToString id (href link) "" - return [c_label, c_title, c_href] - nil <- newCString " " - newArray0 nil $ concat ret - -text2cstring txt = Txt.withCStringLen txt $ \s -> (peekCStringLen s >>= newCString) - +-- FIXME: Segfaults, was intended for the sake of easy concurrency. foreign export ccall c_docLinksAndRendering :: StablePtr Session -> StablePtr Page -> IO (CArray CString) c_docLinksAndRendering c_session c_page = do diff --git a/src/Input.hs b/src/Input.hs index 4e8b26b..ffe9f11 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -15,6 +15,13 @@ import System.IO import System.IO.Temp import Data.Default.Class +-- For C API +import Types +import Data.HTML2CSS (html2css) +import Data.Maybe (fromMaybe) +import Foreign.StablePtr +import Foreign.C.String + -- FIXME segfaults when exposed to C. --fetchURLs session refererDoc refererURL srcs = forConcurrently srcs $ \(mime, url) -> do -- let u = relativeTo url refererURL @@ -72,3 +79,22 @@ docForText txt = XML.Document { }, XML.documentEpilogue = [] } + +-- C API +foreign export ccall c_newSession :: IO (StablePtr Session) +foreign export ccall c_freeSession :: StablePtr Session -> IO () + +c_newSession = newSession >>= newStablePtr +c_freeSession = freeStablePtr + + +foreign export ccall c_fetchURL :: StablePtr Session -> CString -> StablePtr Page -> CString -> IO (StablePtr Page) + +c_fetchURL c_session c_mimes c_referer c_uri = do + session <- deRefStablePtr c_session + mimes <- peekCString c_mimes + referer <- deRefStablePtr c_referer + uri <- peekCString c_uri + let uri' = nullURI `fromMaybe` parseURIReference uri `relativeTo` url referer + doc <- fetchDocument session (words mimes) uri' + newStablePtr $ Page {url = uri', html = doc, css = html2css doc uri'} diff --git a/src/Links.hs b/src/Links.hs index 8ea0f6c..0b47c92 100644 --- a/src/Links.hs +++ b/src/Links.hs @@ -1,12 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} -module Links(extractLinks, linkToText, Link(..)) where +module Links(extractLinks, linkToText, Link(..), c_extractLinks) where import Text.XML import qualified Data.Map as M import Network.URI import Data.Text (Text, unpack, append, pack, replace, strip) +import qualified Data.Text.Foreign as FTxt import Data.Maybe +import Types +import Foreign.StablePtr +import Foreign.C.String +import Foreign.Marshal.Array +import Control.Monad (forM) + data Link = Link { label :: Text, title :: Text, @@ -57,3 +64,18 @@ nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children ++ nodesText (NodeContent text:nodes) = text +++ nodesText nodes nodesText (_:nodes) = nodesText nodes nodesText [] = "" + +-- C API +foreign export ccall c_extractLinks :: StablePtr Page -> IO (CArray CString) + +c_extractLinks c_page = do + page <- deRefStablePtr c_page + ret <- forM (extractLinks $ html page) $ \link -> do + c_label <- text2cstring $ strip $ label link + c_title <- text2cstring $ strip $ title link + c_href <- newCString $ uriToString id (href link) "" + return [c_label, c_title, c_href] + nil <- newCString " " + newArray0 nil $ concat ret + +text2cstring txt = FTxt.withCStringLen txt $ \s -> (peekCStringLen s >>= newCString) diff --git a/src/Render.hs b/src/Render.hs index f70aa5f..d5673c5 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Render(retreiveStyles, renderDoc) where +module Render(retreiveStyles, renderDoc, c_renderDoc) where import qualified Data.ByteString.Lazy as B import qualified Text.XML as XML @@ -22,6 +22,12 @@ import DefaultCSS import StyleTree import SSML +-- C API +import Types +import Foreign.StablePtr +import Foreign.C.String +import Data.ByteString (useAsCString) + renderDoc style html = renderElLBS $ styleToSSML $ applyCounters $ stylize style html @@ -140,3 +146,14 @@ applyCounters root = root { incrementCounters path (counterIncrement node) $ instantiateCounters path (counterReset node) $ inheritCounters path counterSource valueSource + +-- C API +foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr Page -> IO CString -- Hard to C bindings without IO + +c_renderDoc c_session c_page = do + session <- deRefStablePtr c_session + page <- deRefStablePtr c_page + css' <- retreiveStyles session $ css page + B.toStrict (renderDoc css' $ XML.documentRoot $ html page) `useAsCString` \cstr -> do + str <- peekCString cstr + newCString str -- 2.30.2