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