From 489dd5c7d2e71f8b8e2427c8d3895e0537213e8c Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 4 Apr 2020 16:15:54 +1300 Subject: [PATCH] Switch to C for I/O. FIXME currently segfaults. --- rhapsode.cabal | 15 +++++-- src/CExports.hs | 108 +++++++++++++++++++++++++++--------------------- src/Input.hs | 2 +- src/Stub.hs | 1 + src/main.c | 34 +++++++++++++++ 5 files changed, 107 insertions(+), 53 deletions(-) create mode 100644 src/Stub.hs create mode 100644 src/main.c diff --git a/rhapsode.cabal b/rhapsode.cabal index fb655ed..ef5e7f8 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -49,12 +49,12 @@ extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 -executable rhapsode +library -- .hs or .lhs file containing the Main module. - main-is: Main.hs + exposed-modules: CExports - -- Modules included in this executable, other than Main. - -- other-modules: + -- Modules included in this library. + other-modules: DefaultCSS, Input, Links, Render, SSML, StyleTree -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -72,3 +72,10 @@ executable rhapsode -- Base language which the package is written in. default-language: Haskell2010 +executable rhapsode + main-is: main.c + ghc-options: -no-hs-main + build-depends: base >=4.9 && <=4.12, rhapsode + other-modules: Stub + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/CExports.hs b/src/CExports.hs index cfe6393..9a9e61c 100644 --- a/src/CExports.hs +++ b/src/CExports.hs @@ -16,9 +16,10 @@ import Control.Monad (forM) -- For c_fetchURLs import System.Directory (getCurrentDirectory) -- default referer URI import Control.Concurrent.Async (forConcurrently, concurrently) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) -import Input (fetchURLs) +import Input (fetchURLs, fetchDocument, docForText) +import Data.HTML2CSS (html2css) -- For c_renderDoc import Render (retreiveStyles, renderDoc) @@ -48,76 +49,87 @@ c_freeSession = freeStablePtr data Page = Page {url :: URI, css :: ConditionalStyles StyleTree, html :: Document} type PtrPage = Ptr () -foreign export ccall c_freePages :: CArray PtrPage -> IO () +foreign export ccall c_initialReferer :: IO (StablePtr Page) -c_freePages c_pages = do - pages <- peekArray0 nullPtr c_pages - forM pages (freeStablePtr . castPtrToStablePtr) - free c_pages +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 () -foreign export ccall c_fetchURLs :: StablePtr Session -> PtrPage -> CArray CString -> IO (CArray PtrPage) +c_freePage = freeStablePtr -c_fetchURLs c_session c_referer c_srcs = do + +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 - referer <- if c_referer == nullPtr -- Can't check for NULL - then deRefStablePtr $ castPtrToStablePtr c_referer - else do - cwd <- getCurrentDirectory - return $ 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 = [] - } - } - emptyCStr <- newCString "" - srcCStrs <- peekArray0 emptyCStr c_srcs - srcs <- forConcurrently (pairs srcCStrs) $ \(c_mime, c_uri) -> do - mime <- peekCString c_mime - uri <- peekCString c_uri - return $ pair (words mime) <$> parseURIReference uri - ret <- fetchURLs session (html referer) (url referer) $ catMaybes srcs - c_ret <- forM ret $ \(url, html, css) -> - newStablePtr $ Page url css html - newArray0 nullPtr $ map castStablePtrToPtr c_ret - -pairs (a:b:c) = (a, b):pairs c -pairs _ = [] -pair a b = (a, b) - - -foreign export ccall c_renderDoc :: StablePtr Session -> PtrPage -> IO CString -- Hard to C bindings without IO + 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) +-- +--c_fetchURLs c_session c_referer c_srcs = do +-- session <- deRefStablePtr c_session +-- referer <- deRefStablePtr $ castPtrToStablePtr c_referer +-- nil <- newCString "" +-- srcCStrs <- peekArray0 nil c_srcs +-- srcs <- forConcurrently (pairs srcCStrs) $ \(c_mime, c_uri) -> do +-- mime <- peekCString c_mime +-- uri <- peekCString c_uri +-- return $ pair (words mime) <$> parseURIReference uri +-- ret <- fetchURLs session (html referer) (url referer) $ catMaybes srcs +-- c_ret <- forM ret $ \(url, html, css) -> +-- newStablePtr $ Page url css html +-- newArray0 nullPtr $ map castStablePtrToPtr c_ret +-- +--pairs (a:b:c) = (a, b):pairs c +--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 $ castPtrToStablePtr c_page + 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 :: PtrPage -> IO (CArray CString) +foreign export ccall c_extractLinks :: StablePtr Page -> IO (CArray CString) c_extractLinks c_page = do - page <- deRefStablePtr $ castPtrToStablePtr c_page + page <- deRefStablePtr c_page ret <- forM (extractLinks $ html page) $ \link -> do c_label <- text2cstring $ label link c_title <- text2cstring $ title link c_href <- newCString $ uriToString id (href link) "" return [c_label, c_title, c_href] - emptyCStr <- newCString "" - newArray0 emptyCStr $ concat ret + nil <- newCString "" + newArray0 nil $ concat ret text2cstring txt = Txt.withCStringLen txt $ \s -> (peekCStringLen s >>= newCString) -foreign export ccall c_docLinksAndRendering :: StablePtr Session -> PtrPage -> IO (CArray CString) +foreign export ccall c_docLinksAndRendering :: StablePtr Session -> StablePtr Page -> IO (CArray CString) c_docLinksAndRendering c_session c_page = do (c_links, ssml) <- c_extractLinks c_page `concurrently` c_renderDoc c_session c_page diff --git a/src/Input.hs b/src/Input.hs index ecc89fa..46f0788 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Input(parseArgs, ProgramCtl(..), fetchURLs) where +module Input(parseArgs, ProgramCtl(..), fetchURLs, fetchDocument, docForText) where import Data.Text.Lazy (fromStrict) import qualified Data.Text as Txt diff --git a/src/Stub.hs b/src/Stub.hs new file mode 100644 index 0000000..7298e4b --- /dev/null +++ b/src/Stub.hs @@ -0,0 +1 @@ +module Stub where diff --git a/src/main.c b/src/main.c new file mode 100644 index 0000000..9ddce50 --- /dev/null +++ b/src/main.c @@ -0,0 +1,34 @@ +#include +#include +#include +#include "HsFFI.h" + +struct session; +struct session *c_newSession(); +void c_freeSession(struct session*); + +struct page; +struct page *c_initialReferer(); +void *c_fetchURL(struct session*, char*, char*); +//struct page **c_fetchURLs(struct session*, struct page*, char**); +void c_freePage(struct page*); + +char *c_renderDoc(struct session*, struct page*); +char **c_extractLinks(struct page*); +char **c_docLinksAndRendering(struct session*, struct page*); + +int main(int argc, char **argv) { + hs_init(&argc, &argv); + struct session *session = c_newSession(); + + struct page *referer = c_initialReferer(); + struct page *page = c_fetchURL(session, "text/xml text/html text/plain", argv[1]); + // char *ssml = c_renderDoc(session, page); // FIXME segfaults alongside extractLinks & the combined function. + + printf("%i Hello, world!\n", argc); + + c_freePage(page); + c_freePage(referer); + c_freeSession(session); + hs_exit(); +} -- 2.30.2