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