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
{-# LANGUAGE OverloadedStrings #-}
module CExports where
import Types
import Network.URI.Fetch (Session)
import Render (c_renderDoc)
import Links (c_extractLinks)
import qualified Text.XML as XML
import qualified Data.Text as Txt
import qualified Data.Text.Lazy as Txt (fromStrict)
import qualified Data.Map as M
-- Types I can export to C
import Foreign.StablePtr
import Foreign.C.String
import Foreign.Marshal.Array
-- 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)
-- FIXME: Segfaults, was intended for the sake of easy concurrency.
foreign export ccall c_docLinksAndRendering :: StablePtr Session -> StablePtr Page -> Bool -> IO (CArray CString)
c_docLinksAndRendering c_session c_page rewriteUrls = do
c_links <- c_extractLinks c_page
ssml <- c_renderDoc c_session c_page rewriteUrls
-- (c_links, ssml) <- c_extractLinks c_page `concurrently` c_renderDoc c_session c_page rewriteUrls
nil <- newCString ""
links <- peekArray0 nil c_links
newArray0 nil (ssml : links)
-- Since I have XML Conduit here...
ssmlHasMark :: Txt.Text -> XML.Element -> Bool
ssmlHasMark ident (XML.Element "mark" attrs _) = Just ident == M.lookup "name" attrs
ssmlHasMark ident (XML.Element _ _ childs) = or [ssmlHasMark ident el | XML.NodeElement el <- childs]
foreign export ccall c_ssmlHasMark :: CString -> CString -> IO Bool
c_ssmlHasMark c_ident c_ssml = do
ident <- peekCString c_ident
ssml <- peekCString c_ssml
case XML.parseText XML.def $ Txt.fromStrict $ Txt.pack ssml of
Left _ -> return False
Right doc -> return $ ssmlHasMark (Txt.pack ident) $ XML.documentRoot doc