Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( InterpTable
   3     , makeMainXHTML
   4     , makeSubXHTML
   5     , makeDraft
   6     )
   7     where
   8
   9 import           Control.Arrow
  10 import           Control.Arrow.ArrowIO
  11 import           Control.Arrow.ArrowList
  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           Rakka.Page
  18 import           Rakka.Storage
  19 import           Rakka.SystemConfig
  20 import           Rakka.Utils
  21 import           Rakka.Wiki
  22 import           Rakka.Wiki.Parser
  23 import           Rakka.Wiki.Formatter
  24 import           Rakka.Wiki.Interpreter
  25 import           Text.HyperEstraier hiding (getText)
  26 import           Text.ParserCombinators.Parsec
  27 import           Text.XML.HXT.Arrow.XmlArrow hiding (err)
  28 import           Text.XML.HXT.Arrow.XmlNodeSet
  29 import           Text.XML.HXT.DOM.TypeDefs
  30
  31
  32 type InterpTable = Map String Interpreter
  33
  34
  35 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
  36 wikifyPage interpTable
  37     = proc tree
  38     -> do pName      <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
  39           pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
  40           pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< 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) "" (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,...">foo.zip</a>
  58                        returnA -< [ Paragraph [ Anchor
  59                                                 [("href", show dataURI)]
  60                                                 [Text (fromMaybe (defaultFileName pType pName) pFileName)]
  61                                               ]
  62                                   ]
  63                    else
  64                        -- pre
  65                        returnA -< [ Preformatted [Text $ fromJust textData] ]
  66     where
  67       cmdTypeOf :: String -> Maybe CommandType
  68       cmdTypeOf name
  69           = fmap commandType (M.lookup name interpTable)
  70
  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 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  86                  Storage
  87               -> SystemConfig
  88               -> InterpTable
  89               -> a XmlTree XmlTree
  90 makeMainXHTML sto sysConf interpTable
  91     = proc tree
  92     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
  93           wiki            <- wikifyPage interpTable -< tree
  94           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
  95           interpreted     <- interpretCommands sto sysConf interpTable
  96                              -< (pName, Just (tree, wiki), wiki)
  97           formatWikiBlocks -< (baseURI, interpreted)
  98
  99
 100 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 101                 Storage
 102              -> SystemConfig
 103              -> InterpTable
 104              -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
 105 makeSubXHTML sto sysConf interpTable
 106     = proc (mainPageName, mainPage, subPage)
 107     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 108           mainWiki        <- case mainPage of
 109                                Just page
 110                                    -> do wiki <- wikifyPage interpTable -< page
 111                                          returnA -< Just (page, wiki)
 112                                Nothing
 113                                    -> returnA -< Nothing
 114           subWiki         <- wikifyPage interpTable -< subPage
 115           interpreted     <- interpretCommands sto sysConf interpTable
 116                              -< (mainPageName, mainWiki, subWiki)
 117           formatWikiBlocks -< (baseURI, interpreted)
 118
 119
 120 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 121                      Storage
 122                   -> SystemConfig
 123                   -> InterpTable
 124                   -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
 125 interpretCommands sto sysConf interpTable
 126     = proc (name, mainPageAndWiki, targetWiki)
 127     -> let ctx = InterpreterContext {
 128                    ctxPageName   = name
 129                  , ctxMainPage   = fmap fst mainPageAndWiki
 130                  , ctxMainWiki   = fmap snd mainPageAndWiki
 131                  , ctxTargetWiki = targetWiki
 132                  , ctxStorage    = sto
 133                  , ctxSysConf    = sysConf
 134                  }
 135        in
 136          arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
 137     where
 138       interpElem :: InterpreterContext -> Element -> IO Element
 139       interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
 140       interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
 141
 142       interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
 143       interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
 144       interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
 145       interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
 146       interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
 147       interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
 148       interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
 149       interpBlock _ x = return x
 150
 151       interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
 152       interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
 153       interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
 154       interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
 155       interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
 156       interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
 157       interpInline _ x = return x
 158
 159       interpListItem :: InterpreterContext -> ListItem -> IO ListItem
 160       interpListItem = mapM . interpElem
 161
 162       interpDefinition :: InterpreterContext -> Definition -> IO Definition
 163       interpDefinition ctx (Definition term desc)
 164           = do term' <- mapM (interpInline ctx) term
 165                desc' <- mapM (interpInline ctx) desc
 166                return (Definition term' desc')
 167
 168       interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
 169       interpBlockCommand ctx cmd
 170           = case M.lookup (bCmdName cmd) interpTable of
 171               Nothing
 172                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 173
 174               Just interp
 175                   -> bciInterpret interp ctx cmd
 176                      >>=
 177                      interpBlock ctx
 178
 179       interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
 180       interpInlineCommand ctx cmd
 181           = case M.lookup (iCmdName cmd) interpTable of
 182               Nothing
 183                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 184
 185               Just interp
 186                   -> iciInterpret interp ctx cmd
 187                      >>=
 188                      interpInline ctx
 189
 190
 191 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
 192 makeDraft interpTable
 193     = proc tree ->
 194       do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
 195          case redir of
 196            Nothing -> makeEntityDraft   -< tree
 197            Just _  -> makeRedirectDraft -< tree
 198     where
 199       makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
 200       makeEntityDraft
 201           = proc tree ->
 202             do doc <- arrIO0 newDocument -< ()
 203
 204                pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
 205                pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
 206                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
 207                pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
 208                pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
 209                pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
 210                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 211                pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 212                pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
 213                pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
 214                pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
 215                pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
 216
 217                arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
 218                arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
 219                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
 220                arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
 221                arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
 222                arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
 223                arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
 224                arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
 225                arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
 226                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
 227                arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
 228
 229                arrIO2 addHiddenText -< (doc, pName)
 230
 231                case pSummary of
 232                  Just s  -> arrIO2 addHiddenText -< (doc, s)
 233                  Nothing -> returnA -< ()
 234
 235                -- otherLang はリンク先ページ名を hidden text で入れる。
 236                otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
 237                listA ( (arr fst &&& arrL snd)
 238                        >>>
 239                        arrIO2 addHiddenText
 240                        >>>
 241                        none
 242                      ) -< (doc, otherLangs)
 243
 244                case read pType of
 245                  MIMEType "text" "css" _
 246                      -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
 247
 248                  MIMEType "text" "x-rakka" _
 249                    -- wikify して興味のある部分を addText する。
 250                    -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
 251                          wiki <- wikifyPage interpTable -< tree
 252                          arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
 253
 254                  MIMEType _ _ _
 255                      -> returnA -< ()
 256
 257                returnA -< doc
 258
 259       makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
 260       makeRedirectDraft
 261           = proc tree ->
 262             do doc <- arrIO0 newDocument -< ()
 263
 264                pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
 265                pRedir    <- getXPathTreesInDoc "/page/@redirect/text()"     >>> getText -< tree
 266                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 267                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
 268
 269                arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
 270                arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
 271                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")
 272                arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
 273                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
 274
 275                -- リダイレクト先ページ名はテキストとして入れる
 276                arrIO2 addText -< (doc, pRedir)
 277
 278                returnA -< doc
 279
 280       addElemText :: Document -> Element -> IO ()
 281       addElemText doc (Block  b) = addBlockText  doc b
 282       addElemText doc (Inline i) = addInlineText doc i
 283
 284       addBlockText :: Document -> BlockElement -> IO ()
 285       addBlockText doc (Heading _ text)       = addText doc text
 286       addBlockText _    HorizontalLine        = return ()
 287       addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
 288       addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
 289       addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
 290       addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
 291       addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
 292       addBlockText _    EmptyBlock            = return ()
 293       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 294
 295       addInlineText :: Document -> InlineElement -> IO ()
 296       addInlineText doc (Text text)                       = addText doc text
 297       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
 298       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
 299       addInlineText doc (ObjectLink page Nothing)         = addText doc page
 300       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
 301                                                             >> addText doc text
 302       addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 303       addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
 304                                                             >> addText doc text
 305       addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
 306       addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
 307                                                             >> addText doc text
 308       addInlineText _   (LineBreak _)                     = return ()
 309       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
 310       addInlineText doc (Image src alt)                   = do case src of
 311                                                                  Left  uri  -> addHiddenText doc (uriToString id uri "")
 312                                                                  Right page -> addHiddenText doc page
 313                                                                case alt of
 314                                                                  Just text -> addHiddenText doc text
 315                                                                  Nothing   -> return ()
 316       addInlineText doc (Anchor _ inlines)                = mapM_ (addInlineText doc) inlines
 317       addInlineText _   (Input _)                         = return ()
 318       addInlineText _    EmptyInline                      = return ()
 319       addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
 320
 321       addListItemText :: Document -> ListItem -> IO ()
 322       addListItemText = mapM_ . addElemText
 323
 324       addDefinitionText :: Document -> Definition -> IO ()
 325       addDefinitionText doc (Definition term desc)
 326           = do mapM_ (addInlineText doc) term
 327                mapM_ (addInlineText doc) desc
 328
 329       addBlockCmdText :: Document -> BlockCommand -> IO ()
 330       addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
 331
 332       addInlineCmdText :: Document -> InlineCommand -> IO ()
 333       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 334
 335
 336 wikifyParseError :: Arrow a => a ParseError WikiPage
 337 wikifyParseError = proc err
 338                  -> returnA -< [Div [("class", "error")]
 339                                 [ Block (Preformatted [Text (show err)]) ]]