Rakka/Storage/DefaultPage.hs

   1 module Rakka.Storage.DefaultPage
   2     ( findAllDefaultPages
   3     , loadDefaultPage
   4     )
   5     where
   6
   7 import qualified Codec.Binary.Base64 as B64
   8 import           Codec.Binary.UTF8.String
   9 import           Control.Arrow
  10 import           Control.Arrow.ArrowIO
  11 import           Control.Arrow.ArrowList
  12 import qualified Data.ByteString.Lazy as L
  13 import qualified Data.Map as M
  14 import           Data.Set (Set)
  15 import qualified Data.Set as S
  16 import           Data.Time
  17 import           Data.Time.Clock.POSIX
  18 import           Paths_Rakka -- Cabal が用意する。
  19 import           Rakka.Page
  20 import           Rakka.Utils
  21 import           System.Directory
  22 import           System.FilePath
  23 import           System.FilePath.Find hiding (fileName, modificationTime)
  24 import           System.Posix.Files
  25 import           Text.XML.HXT.Arrow.ReadDocument
  26 import           Text.XML.HXT.Arrow.XmlArrow
  27 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  28 import           Text.XML.HXT.Arrow.XmlNodeSet
  29 import           Text.XML.HXT.DOM.TypeDefs
  30 import           Text.XML.HXT.DOM.XmlKeywords
  31
  32
  33 doesLocalDirExist :: IO Bool
  34 doesLocalDirExist = doesDirectoryExist "defaultPages"
  35
  36
  37 findAllDefaultPages :: IO (Set PageName)
  38 findAllDefaultPages
  39     -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
  40     -- defaultPages を探す。
  41     = do localDirExists <- doesLocalDirExist
  42          if localDirExists then
  43              findAllIn "defaultPages"
  44            else
  45              -- FIXME: この getDataFileName の使ひ方は undocumented
  46              findAllIn =<< getDataFileName "defaultPages"
  47     where
  48       findAllIn :: FilePath -> IO (Set PageName)
  49       findAllIn dirPath
  50           = find always (fileType ==? RegularFile) dirPath
  51             >>=
  52             return . S.fromList . map (decodePageName . makeRelative dirPath)
  53
  54
  55 loadDefaultPage :: PageName -> IO (Maybe Page)
  56 loadDefaultPage name
  57     -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
  58     -- ば Cabal で defaultPages/Foo を探す。
  59     = do let pagePath = "defaultPages" </> encodePageName name
  60
  61          localDirExists <- doesLocalDirExist
  62          if localDirExists then
  63              tryLoad pagePath
  64            else
  65              tryLoad =<< getDataFileName pagePath
  66     where
  67       tryLoad :: FilePath -> IO (Maybe Page)
  68       tryLoad fpath
  69           = do exists <- doesFileExist fpath
  70                if exists then
  71                    return . Just =<< loadPageFile name fpath
  72                  else
  73                    return Nothing
  74
  75
  76 loadPageFile :: PageName -> FilePath -> IO Page
  77 loadPageFile name path
  78     = do [page] <- runX ( setErrorMsgHandler False fail
  79                           >>>
  80                           constA (name, path)
  81                           >>>
  82                           loadPageFileA
  83                         )
  84          return page
  85
  86
  87 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
  88 loadPageFileA
  89     = proc (name, fpath) ->
  90       do tree    <- readFromDocument [ (a_validate         , v_0)
  91                                      , (a_check_namespaces , v_1)
  92                                      , (a_remove_whitespace, v_1)
  93                                      ] -< fpath
  94          lastMod <- arrIO (\ x -> getFileStatus x
  95                                   >>=
  96                                   return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
  97                     -< fpath
  98          parsePage -< (name, lastMod, tree)
  99
 100
 101 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
 102 parsePage
 103     = proc (name, lastMod, tree)
 104     -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
 105           case redirect of
 106             Nothing   -> parseEntity -< (name, lastMod, tree)
 107             Just dest -> returnA     -< (Redirection {
 108                                            redirName     = name
 109                                          , redirDest     = dest
 110                                          , redirRevision = Nothing
 111                                          , redirLastMod  = lastMod
 112                                          })
 113
 114
 115 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
 116 parseEntity
 117     = proc (name, lastMod, tree)
 118     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
 119                        >>> arr read) -< tree
 120
 121           lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
 122           fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
 123
 124           isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
 125                        >>> parseYesOrNo) -< tree
 126           isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
 127                        >>> parseYesOrNo) -< tree
 128           isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
 129                        >>> parseYesOrNo) -< tree
 130           isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
 131                        >>> parseYesOrNo) -< tree
 132
 133           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
 134                               >>> getText
 135                               >>> deleteIfEmpty)) -< tree
 136
 137           otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
 138                               >>>
 139                               (getAttrValue0 "lang"
 140                                &&&
 141                                getAttrValue0 "page")) -< tree
 142
 143           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
 144           binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 145
 146           let (isBinary, content)
 147                   = case (textData, binaryData) of
 148                       (Just text, Nothing    ) -> (False, L.pack $ encode text      )
 149                       (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
 150                       _                        -> error "one of textData or binaryData is required"
 151
 152           returnA -< Entity {
 153                         pageName      = name
 154                       , pageType      = mimeType
 155                       , pageLanguage  = lang
 156                       , pageFileName  = fileName
 157                       , pageIsTheme   = isTheme
 158                       , pageIsFeed    = isFeed
 159                       , pageIsLocked  = isLocked
 160                       , pageIsBoring  = isBoring
 161                       , pageIsBinary  = isBinary
 162                       , pageRevision  = 0
 163                       , pageLastMod   = lastMod
 164                       , pageSummary   = summary
 165                       , pageOtherLang = M.fromList otherLang
 166                       , pageContent   = content
 167                       }