Rakka/Storage/DefaultPage.hs

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