Rakka/Storage/DefaultPage.hs

   1 module Rakka.Storage.DefaultPage
   2     ( loadDefaultPage
   3     )
   4     where
   5
   6 import qualified Codec.Binary.Base64.String as B64
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import qualified Data.ByteString.Lazy.Char8 as L8
  10 import           Paths_Rakka -- Cabal が用意する。
  11 import           Rakka.Page
  12 import           Rakka.Utils
  13 import           System.Directory
  14 import           Text.XML.HXT.Arrow.ReadDocument
  15 import           Text.XML.HXT.Arrow.XmlArrow
  16 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  17 import           Text.XML.HXT.Arrow.XmlNodeSet
  18 import           Text.XML.HXT.DOM.TypeDefs
  19 import           Text.XML.HXT.DOM.XmlKeywords
  20
  21
  22 loadDefaultPage :: PageName -> IO (Maybe Page)
  23 loadDefaultPage pageName
  24     -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
  25     = do let pagePath = encodePageName pageName
  26          isInDataDir <- doesFileExist ("./data/" ++ pagePath)
  27          if isInDataDir then
  28              return . Just =<< loadPageFile pageName ("./data/" ++ pagePath)
  29            else
  30              do fpath       <- getDataFileName ("defaultPages/" ++ pagePath)
  31                 isInstalled <- doesFileExist fpath
  32                 if isInstalled then
  33                     return . Just =<< loadPageFile pageName fpath
  34                   else
  35                     return Nothing
  36
  37
  38 loadPageFile :: PageName -> FilePath -> IO Page
  39 loadPageFile name path
  40     = do [page] <- runX ( constA (name, path)
  41                           >>>
  42                           loadPageFileA
  43                         )
  44          return page
  45
  46
  47 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
  48 loadPageFileA
  49     = proc (name, fpath) ->
  50       do tree <- readFromDocument [ (a_validate         , v_0)
  51                                   , (a_check_namespaces , v_1)
  52                                   , (a_remove_whitespace, v_1)
  53                                   ] -< fpath
  54          parsePage -< (name, tree)
  55
  56
  57 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
  58 parsePage
  59     = proc (name, tree)
  60     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
  61                        >>> arr read) -< tree
  62
  63           isTheme  <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
  64                        >>> defaultTo "no"
  65                        >>> parseYesOrNo) -< tree
  66           isFeed   <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
  67                        >>> defaultTo "no"
  68                        >>> parseYesOrNo) -< tree
  69           isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
  70                        >>> defaultTo "no"
  71                        >>> parseYesOrNo) -< tree
  72           isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
  73                        >>> defaultTo "no"
  74                        >>> parseYesOrNo) -< tree
  75
  76           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
  77                               >>> getText
  78                               >>> deleteIfEmpty)) -< tree
  79
  80           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
  81                               >>>
  82                               (getAttrValue0 "lang"
  83                                &&&
  84                                getAttrValue0 "page")) -< tree
  85
  86           textData   <- maybeA (getXPathTreesInDoc "/page/textData"   >>> getText) -< tree
  87           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
  88
  89           let content = case (textData, binaryData) of
  90                           (Just text, _          ) -> L8.pack text
  91                           (_        , Just binary) -> L8.pack $ B64.decode binary
  92
  93           returnA -< Page {
  94                         pageName      = name
  95                       , pageType      = mimeType
  96                       , pageIsTheme   = isTheme
  97                       , pageIsFeed    = isFeed
  98                       , pageIsLocked  = isLocked
  99                       , pageIsBoring  = isBoring
 100                       , pageRevision  = Nothing
 101                       , pageSummary   = summary
 102                       , pageOtherLang = otherLang
 103                       , pageContent   = content
 104                       }