]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Wiki/Engine.hs
72effb3ed2414817ae7a4d09e6062082a657d06d
[Rakka.git] / Rakka / Wiki / Engine.hs
1 module Rakka.Wiki.Engine
2     ( InterpTable
3     , makeMainXHTML
4     , makeSubXHTML
5     , makeDraft
6     , makePreviewXHTML
7     )
8     where
9
10 import qualified Codec.Binary.Base64 as B64
11 import qualified Codec.Binary.UTF8.String as UTF8
12 import           Control.Arrow
13 import           Control.Arrow.ArrowIO
14 import           Control.Arrow.ArrowList
15 import qualified Data.ByteString.Lazy as Lazy
16 import           Data.Map (Map)
17 import qualified Data.Map as M
18 import           Data.Maybe
19 import           Network.HTTP.Lucu
20 import           Network.URI
21 import           Rakka.Page
22 import           Rakka.Storage
23 import           Rakka.SystemConfig
24 import           Rakka.Utils
25 import           Rakka.Wiki
26 import           Rakka.Wiki.Parser
27 import           Rakka.Wiki.Formatter
28 import           Rakka.Wiki.Interpreter
29 import           Text.HyperEstraier hiding (getText)
30 import           Text.ParserCombinators.Parsec
31 import           Text.XML.HXT.Arrow.XmlArrow hiding (err)
32 import           Text.XML.HXT.Arrow.XmlNodeSet
33 import           Text.XML.HXT.DOM.TypeDefs
34
35
36 type InterpTable = Map String Interpreter
37
38
39 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
40 wikifyPage interpTable
41     = proc tree
42     -> do pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
43           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
44           base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
45
46           let dataURI = fmap (binToURI pType) base64Data
47
48           case pType of
49             MIMEType "text" "x-rakka" _
50                 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
51                      Left err -> wikifyParseError -< err
52                      Right xs -> returnA -< xs
53
54             MIMEType "image" _ _
55                 -- <img src="data:image/png;base64,..." />
56                 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
57
58             _   -> if isJust dataURI then
59                        -- <a href="data:application/zip;base64,...">
60                        --   application/zip
61                        -- </a>
62                        returnA -< [ Paragraph [ Anchor
63                                                 [("href", show dataURI)]
64                                                 [Text (show pType)]
65                                               ]
66                                   ]
67                    else
68                        -- pre
69                        returnA -< [ Preformatted [Text $ fromJust textData] ]
70     where
71       binToURI :: MIMEType -> String -> URI
72       binToURI pType base64Data
73           = nullURI {
74               uriScheme = "data:"
75             , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
76             }
77
78       stripWhiteSpace :: String -> String
79       stripWhiteSpace []     = []
80       stripWhiteSpace (x:xs)
81           | x `elem` " \t\n" = stripWhiteSpace xs
82           | otherwise        = x : stripWhiteSpace xs
83
84
85 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
86 wikifyBin interpTable
87     = proc (pType, pBin)
88     -> do let text    = UTF8.decode $ Lazy.unpack pBin
89               dataURI = binToURI pType pBin
90
91           case pType of
92             MIMEType "text" "x-rakka" _
93                 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
94                      Left err -> wikifyParseError -< err
95                      Right xs -> returnA -< xs
96
97             MIMEType "image" _ _
98                 -- <img src="data:image/png;base64,..." />
99                 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
100
101             
102             _
103                 -- <a href="data:application/zip;base64,...">
104                 --   application/zip (19372 bytes)
105                 -- </a>
106                 -> returnA -< [ Paragraph [ Anchor
107                                             [("href", show dataURI)]
108                                             [Text (show pType ++
109                                                    " (" ++
110                                                    show (Lazy.length pBin) ++
111                                                    " bytes)")]
112                                           ]
113                               ]
114     where
115       binToURI :: MIMEType -> Lazy.ByteString -> URI
116       binToURI m b
117           = nullURI {
118               uriScheme = "data:"
119             , uriPath   = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
120             }
121
122
123 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
124 cmdTypeOf interpTable name
125     = fmap commandType (M.lookup name interpTable)
126
127
128 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
129                  Storage
130               -> SystemConfig
131               -> InterpTable
132               -> a XmlTree XmlTree
133 makeMainXHTML sto sysConf interpTable
134     = proc tree
135     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
136           wiki            <- wikifyPage interpTable -< tree
137           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
138           interpreted     <- interpretCommands sto sysConf interpTable
139                              -< (pName, Just tree, Just wiki, wiki)
140           formatWikiBlocks -< (baseURI, interpreted)
141
142
143 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
144                 Storage
145              -> SystemConfig
146              -> InterpTable
147              -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
148 makeSubXHTML sto sysConf interpTable
149     = proc (mainPageName, mainPage, subPage)
150     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
151           mainWiki        <- case mainPage of
152                                Just page
153                                    -> do wiki <- wikifyPage interpTable -< page
154                                          returnA -< Just (page, wiki)
155                                Nothing
156                                    -> returnA -< Nothing
157           subWiki         <- wikifyPage interpTable -< subPage
158           interpreted     <- interpretCommands sto sysConf interpTable
159                              -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
160           formatWikiBlocks -< (baseURI, interpreted)
161
162
163 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
164                     Storage
165                  -> SystemConfig
166                  -> InterpTable
167                  -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
168 makePreviewXHTML sto sysConf interpTable
169     = proc (name, pageType, pageBin)
170     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
171           wiki            <- wikifyBin interpTable -< (pageType, pageBin)
172           interpreted     <- interpretCommands sto sysConf interpTable
173                              -< (name, Nothing, Just wiki, wiki)
174           formatWikiBlocks -< (baseURI, interpreted)
175
176
177 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
178                      Storage
179                   -> SystemConfig
180                   -> InterpTable
181                   -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
182 interpretCommands sto sysConf interpTable
183     = proc (name, mainPage, mainWiki, targetWiki)
184     -> let ctx = InterpreterContext {
185                    ctxPageName   = name
186                  , ctxMainPage   = mainPage
187                  , ctxMainWiki   = mainWiki
188                  , ctxTargetWiki = targetWiki
189                  , ctxStorage    = sto
190                  , ctxSysConf    = sysConf
191                  }
192        in
193          arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
194     where
195       interpElem :: InterpreterContext -> Element -> IO Element
196       interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
197       interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
198
199       interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
200       interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
201       interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
202       interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
203       interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
204       interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
205       interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
206       interpBlock _ x = return x
207
208       interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
209       interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
210       interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
211       interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
212       interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
213       interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
214       interpInline _ x = return x
215
216       interpListItem :: InterpreterContext -> ListItem -> IO ListItem
217       interpListItem = mapM . interpElem
218
219       interpDefinition :: InterpreterContext -> Definition -> IO Definition
220       interpDefinition ctx (Definition term desc)
221           = do term' <- mapM (interpInline ctx) term
222                desc' <- mapM (interpInline ctx) desc
223                return (Definition term' desc')
224
225       interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
226       interpBlockCommand ctx cmd
227           = case M.lookup (bCmdName cmd) interpTable of
228               Nothing
229                   -> fail ("no such interpreter: " ++ bCmdName cmd)
230
231               Just interp
232                   -> bciInterpret interp ctx cmd
233                      >>=
234                      interpBlock ctx
235
236       interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
237       interpInlineCommand ctx cmd
238           = case M.lookup (iCmdName cmd) interpTable of
239               Nothing
240                   -> fail ("no such interpreter: " ++ iCmdName cmd)
241
242               Just interp
243                   -> iciInterpret interp ctx cmd
244                      >>=
245                      interpInline ctx
246
247
248 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
249 makeDraft interpTable
250     = proc tree ->
251       do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
252          case redir of
253            Nothing -> makeEntityDraft   -< tree
254            Just _  -> makeRedirectDraft -< tree
255     where
256       makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
257       makeEntityDraft 
258           = proc tree ->
259             do doc <- arrIO0 newDocument -< ()
260          
261                pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
262                pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
263                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
264                pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
265                pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
266                pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
267                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
268                pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
269                pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
270                pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
271                pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
272                pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
273
274                arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
275                arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
276                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
277                arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
278                arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
279                arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
280                arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
281                arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
282                arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
283                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
284                arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
285
286                arrIO2 addHiddenText -< (doc, pName)
287
288                case pSummary of
289                  Just s  -> arrIO2 addHiddenText -< (doc, s)
290                  Nothing -> returnA -< ()
291
292                -- otherLang はリンク先ページ名を hidden text で入れる。
293                otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
294                listA ( (arr fst &&& arrL snd)
295                        >>>
296                        arrIO2 addHiddenText
297                        >>>
298                        none
299                      ) -< (doc, otherLangs)
300
301                case read pType of
302                  MIMEType "text" "css" _
303                      -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
304            
305                  MIMEType "text" "x-rakka" _
306                    -- wikify して興味のある部分を addText する。
307                    -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
308                          wiki <- wikifyPage interpTable -< tree
309                          arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
310
311                  MIMEType _ _ _
312                      -> returnA -< ()
313
314                returnA -< doc
315
316       makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
317       makeRedirectDraft
318           = proc tree ->
319             do doc <- arrIO0 newDocument -< ()
320
321                pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
322                pRedir    <- getXPathTreesInDoc "/page/@redirect/text()"     >>> getText -< tree
323                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
324                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
325
326                arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
327                arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
328                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")
329                arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
330                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
331
332                -- リダイレクト先ページ名はテキストとして入れる
333                arrIO2 addText -< (doc, pRedir)
334
335                returnA -< doc
336
337       addElemText :: Document -> Element -> IO ()
338       addElemText doc (Block  b) = addBlockText  doc b
339       addElemText doc (Inline i) = addInlineText doc i
340
341       addBlockText :: Document -> BlockElement -> IO ()
342       addBlockText doc (Heading _ text)       = addText doc text
343       addBlockText _    HorizontalLine        = return ()
344       addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
345       addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
346       addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
347       addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
348       addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
349       addBlockText _    EmptyBlock            = return ()
350       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
351
352       addInlineText :: Document -> InlineElement -> IO ()
353       addInlineText doc (Text text)                       = addText doc text
354       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
355       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
356       addInlineText doc (ObjectLink page Nothing)         = addText doc page
357       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
358                                                             >> addText doc text
359       addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
360       addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
361                                                             >> addText doc text
362       addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
363       addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
364                                                             >> addText doc text
365       addInlineText _   (LineBreak _)                     = return ()
366       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
367       addInlineText doc (Image src alt)                   = do case src of
368                                                                  Left  uri  -> addHiddenText doc (uriToString id uri "")
369                                                                  Right page -> addHiddenText doc page
370                                                                case alt of
371                                                                  Just text -> addHiddenText doc text
372                                                                  Nothing   -> return ()
373       addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
374       addInlineText _   (Input _)                         = return ()
375       addInlineText _    EmptyInline                      = return ()
376       addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
377
378       addListItemText :: Document -> ListItem -> IO ()
379       addListItemText = mapM_ . addElemText
380
381       addDefinitionText :: Document -> Definition -> IO ()
382       addDefinitionText doc (Definition term desc)
383           = do mapM_ (addInlineText doc) term
384                mapM_ (addInlineText doc) desc
385
386       addBlockCmdText :: Document -> BlockCommand -> IO ()
387       addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
388
389       addInlineCmdText :: Document -> InlineCommand -> IO ()
390       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
391
392
393 wikifyParseError :: Arrow a => a ParseError WikiPage
394 wikifyParseError = proc err
395                  -> returnA -< [Div [("class", "error")]
396                                 [ Block (Preformatted [Text (show err)]) ]]