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