~alcinnz/rhapsode

ref: 489dd5c7d2e71f8b8e2427c8d3895e0537213e8c rhapsode/src/CExports.hs -rw-r--r-- 4.6 KiB
489dd5c7 — Adrian Cochrane Switch to C for I/O. FIXME currently segfaults. 4 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{-# LANGUAGE OverloadedStrings #-}
module CExports(c_newSession) where

-- For c_newSession
import Network.URI.Fetch (Session, newSession)

-- 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 (fetchURLs, 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

-- 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)
--
--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 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 $ label link
        c_title <- text2cstring $ 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)

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
    nil <- newCString ""
    links <- peekArray0 nil c_links
    newArray0 nil (ssml : links)