Rakka/Wiki/Engine.hs

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