Rakka/Wiki/Engine.hs

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