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 qualified Codec.Binary.Base64 as B64
  11 import           Control.Arrow
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Arrow.ArrowList
  14 import qualified Data.ByteString.Lazy as L
  15 import           Data.Encoding
  16 import           Data.Encoding.UTF8
  17 import           Data.Generics
  18 import           Data.Map (Map)
  19 import qualified Data.Map as M
  20 import           Data.Maybe
  21 import           Network.HTTP.Lucu
  22 import           Network.URI
  23 import           Rakka.Page
  24 import           Rakka.Storage
  25 import           Rakka.SystemConfig
  26 import           Rakka.Utils
  27 import           Rakka.Wiki
  28 import           Rakka.Wiki.Parser
  29 import           Rakka.Wiki.Formatter
  30 import           Rakka.Wiki.Interpreter
  31 import           Text.HyperEstraier hiding (getText)
  32 import           Text.ParserCombinators.Parsec
  33 import           Text.XML.HXT.Arrow.XmlArrow
  34 import           Text.XML.HXT.Arrow.XmlNodeSet
  35 import           Text.XML.HXT.DOM.TypeDefs
  36
  37
  38 type InterpTable = Map String Interpreter
  39
  40
  41 {-
  42   <page name="Foo/Bar"
  43         type="text/x-rakka"
  44         lang="ja"            -- 存在しない場合もある
  45         fileName="bar.rakka" -- 存在しない場合もある
  46         isTheme="no"         -- text/css の場合のみ存在
  47         isFeed="no"          -- text/x-rakka の場合のみ存在
  48         isLocked="no"
  49         isBinary="no"
  50         revision="112">      -- デフォルトでない場合のみ存在
  51         lastModified="2000-01-01T00:00:00">
  52
  53     <summary>
  54         blah blah...
  55     </summary> -- 存在しない場合もある
  56
  57     <otherLang> -- 存在しない場合もある
  58       <link lang="ja" page="Bar/Baz" />
  59     </otherLang>
  60
  61     <!-- 何れか一方のみ -->
  62     <textData>
  63       blah blah...
  64     </textData>
  65     <binaryData>
  66       SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
  67     </binaryData>
  68   </page>
  69 -}
  70 xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
  71 xmlizePage
  72     = proc page
  73     -> (eelem "/"
  74         += ( eelem "page"
  75              += sattr "name" (pageName page)
  76              += sattr "type" (show $ pageType page)
  77              += ( case pageLanguage page of
  78                     Just x  -> sattr "lang" x
  79                     Nothing -> none
  80                 )
  81              += ( case pageFileName page of
  82                     Just x  -> sattr "fileName" x
  83                     Nothing -> none
  84                 )
  85              += ( case pageType page of
  86                     MIMEType "text" "css" _
  87                         -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
  88                     MIMEType "text" "x-rakka" _
  89                         -> sattr "isFeed"  (yesOrNo $ pageIsFeed page)
  90                     _
  91                         -> none
  92                 )
  93              += sattr "isLocked" (yesOrNo $ pageIsLocked page)
  94              += sattr "isBoring" (yesOrNo $ pageIsBoring page)
  95              += sattr "isBinary" (yesOrNo $ pageIsBinary page)
  96              += sattr "revision" (show $ pageRevision page)
  97              += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
  98              += ( case pageSummary page of
  99                     Just s  -> eelem "summary" += txt s
 100                     Nothing -> none
 101                 )
 102              += ( if M.null (pageOtherLang page) then
 103                       none
 104                   else
 105                       selem "otherLang"
 106                                 [ eelem "link"
 107                                   += sattr "lang" lang
 108                                   += sattr "page" page
 109                                       | (lang, page) <- M.toList (pageOtherLang page) ]
 110                 )
 111              += ( if pageIsBinary page then
 112                       ( eelem "binaryData"
 113                         += txt (B64.encode $ L.unpack $ pageContent page)
 114                       )
 115                   else
 116                       ( eelem "textData"
 117                         += txt (decodeLazy UTF8 $ pageContent page)
 118                       )
 119                 )
 120            )
 121        ) -<< ()
 122
 123
 124 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
 125 wikifyPage interpTable
 126     = proc tree
 127     -> do pName      <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
 128           pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
 129           pIsBinary  <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
 130           pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< tree
 131           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 132
 133           case pType of
 134             MIMEType "text" "x-rakka" _
 135                 -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
 136                      Left err -> wikifyParseError -< err
 137                      Right xs -> returnA -< xs
 138
 139             MIMEType "image" _ _
 140                 -> returnA -< [ Paragraph [Image pName Nothing] ]
 141
 142             _   -> if pIsBinary == "yes" then
 143                        returnA -< [ Paragraph [ ObjectLink {
 144                                                   objLinkPage = pName
 145                                                 , objLinkText = Just $ fromMaybe (defaultFileName pType pName) pFileName
 146                                                 }
 147                                               ]
 148                                   ]
 149                    else
 150                        -- pre
 151                        returnA -< [ Preformatted [Text $ fromJust textData] ]
 152     where
 153       cmdTypeOf :: String -> Maybe CommandType
 154       cmdTypeOf name
 155           = fmap commandType (M.lookup name interpTable)
 156
 157       binToURI :: MIMEType -> String -> URI
 158       binToURI pType base64Data
 159           = nullURI {
 160               uriScheme = "data:"
 161             , uriPath   = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
 162             }
 163
 164       stripWhiteSpace :: String -> String
 165       stripWhiteSpace []     = []
 166       stripWhiteSpace (x:xs)
 167           | x `elem` " \t\n" = stripWhiteSpace xs
 168           | otherwise        = x : stripWhiteSpace xs
 169
 170
 171 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 172                  Storage
 173               -> SystemConfig
 174               -> InterpTable
 175               -> a XmlTree XmlTree
 176 makeMainXHTML sto sysConf interpTable
 177     = proc tree
 178     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 179           wiki            <- wikifyPage interpTable -< tree
 180           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
 181           interpreted     <- interpretCommands sto sysConf interpTable
 182                              -< (pName, Just (tree, wiki), wiki)
 183           formatWikiBlocks -< (baseURI, interpreted)
 184
 185
 186 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 187                 Storage
 188              -> SystemConfig
 189              -> InterpTable
 190              -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
 191 makeSubXHTML sto sysConf interpTable
 192     = proc (mainPageName, mainPage, subPage)
 193     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 194           mainWiki        <- case mainPage of
 195                                Just page
 196                                    -> do wiki <- wikifyPage interpTable -< page
 197                                          returnA -< Just (page, wiki)
 198                                Nothing
 199                                    -> returnA -< Nothing
 200           subWiki         <- wikifyPage interpTable -< subPage
 201           interpreted     <- interpretCommands sto sysConf interpTable
 202                              -< (mainPageName, mainWiki, subWiki)
 203           formatWikiBlocks -< (baseURI, interpreted)
 204
 205
 206 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 207                      Storage
 208                   -> SystemConfig
 209                   -> InterpTable
 210                   -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
 211 interpretCommands sto sysConf interpTable
 212     = proc (name, mainPageAndWiki, targetWiki)
 213     -> let ctx = InterpreterContext {
 214                    ctxPageName   = name
 215                  , ctxMainPage   = fmap fst mainPageAndWiki
 216                  , ctxMainWiki   = fmap snd mainPageAndWiki
 217                  , ctxTargetWiki = targetWiki
 218                  , ctxStorage    = sto
 219                  , ctxSysConf    = sysConf
 220                  }
 221        in
 222          ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
 223            >>>
 224            arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
 225          ) -<< targetWiki
 226     where
 227       interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
 228       interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
 229       interpBlockCmd _   others         = return others
 230
 231       interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
 232       interpBlockCmd' ctx cmd
 233           = case M.lookup (bCmdName cmd) interpTable of
 234               Nothing
 235                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 236
 237               Just interp
 238                   -> bciInterpret interp ctx cmd
 239
 240
 241       interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
 242       interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
 243       interpInlineCmd _   others          = return others
 244
 245       interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
 246       interpInlineCmd' ctx cmd
 247           = case M.lookup (iCmdName cmd) interpTable of
 248               Nothing
 249                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 250
 251               Just interp
 252                   -> iciInterpret interp ctx cmd
 253
 254
 255 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
 256 makeDraft interpTable
 257     = proc tree ->
 258       do doc <- arrIO0 newDocument -< ()
 259
 260          pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
 261          pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
 262          pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
 263          pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
 264          pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
 265          pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
 266          pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
 267          pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 268          pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
 269          pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
 270          pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
 271          pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
 272
 273          arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
 274          arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
 275          arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
 276          arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
 277          arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
 278          arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
 279          arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
 280          arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
 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                      wikiPage <- wikifyPage interpTable -< tree
 308                      arrIO0 (everywhereM' (mkM (addBlockText  doc)) wikiPage) -<< ()
 309                      arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< ()
 310                      returnA -< ()
 311
 312            MIMEType _ _ _
 313                -> returnA -< ()
 314
 315          returnA -< doc
 316     where
 317       addBlockText :: Document -> BlockElement -> IO BlockElement
 318       addBlockText doc b
 319           = do case b of
 320                  Heading _ text
 321                      -> addText doc text
 322                  _   -> return ()
 323                return b
 324
 325       addInlineText :: Document -> InlineElement -> IO InlineElement
 326       addInlineText doc i
 327           = do case i of
 328                  Text text
 329                      -> addText doc text
 330                  ObjectLink page Nothing
 331                      -> addText doc page
 332                  ObjectLink page (Just text)
 333                      -> do addHiddenText doc page
 334                            addText doc text
 335                  PageLink page fragment Nothing
 336                      -> addText doc (fromMaybe "" page ++
 337                                      fromMaybe "" fragment)
 338                  PageLink page fragment (Just text)
 339                      -> do addHiddenText doc (fromMaybe "" page ++
 340                                               fromMaybe "" fragment)
 341                            addText doc text
 342                  ExternalLink uri Nothing
 343                      -> addText doc (uriToString id uri "")
 344                  ExternalLink uri (Just text)
 345                      -> do addHiddenText doc (uriToString id uri "")
 346                            addText doc text
 347                  _   -> return ()
 348                return i
 349
 350 -- Perform monadic transformation in top-down order.
 351 everywhereM' :: Monad m => GenericM m -> GenericM m
 352 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 353
 354
 355 wikifyParseError :: Arrow a => a ParseError WikiPage
 356 wikifyParseError = proc err
 357                  -> returnA -< [Div [("class", "error")]
 358                                 [ Block (Preformatted [Text (show err)]) ]]