Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , findChangedPagesAtRevision
   4     , loadPageInRepository
   5     , putPageIntoRepository
   6     )
   7     where
   8
   9 import           Control.Monad
  10 import           Data.List
  11 import qualified Data.Map as M
  12 import           Data.Maybe
  13 import           Data.Set (Set)
  14 import qualified Data.Set as S hiding (Set)
  15 import           Data.Time
  16 import           Network.HTTP.Lucu hiding (redirect)
  17 import           Rakka.Page
  18 import           Rakka.SystemConfig
  19 import           Rakka.Utils
  20 import           Rakka.W3CDateTime
  21 import           Subversion.Types
  22 import           Subversion.FileSystem
  23 import           Subversion.FileSystem.DirEntry
  24 import           Subversion.FileSystem.Revision
  25 import           Subversion.FileSystem.Root
  26 import           Subversion.FileSystem.Transaction
  27 import           Subversion.Repository
  28 import           System.FilePath.Posix
  29
  30
  31 mkPagePath :: PageName -> FilePath
  32 mkPagePath name
  33     = "pages" </> encodePageName name <.> "page"
  34
  35
  36 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  37 findAllPagesInRevision repos rev
  38     = do fs <- getRepositoryFS repos
  39          withRevision fs rev
  40              $ do exists <- isDirectory root
  41                   if exists then
  42                       traverse root
  43                     else
  44                       return S.empty
  45     where
  46       root :: FilePath
  47       root = "/pages"
  48
  49       traverse :: FilePath -> Rev (Set PageName)
  50       traverse dir
  51           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  52
  53       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  54       traverse' dir entry
  55           = let path = dir </> entName entry
  56             in
  57               do kind <- checkPath path
  58                  case kind of
  59                    NoNode   -> return S.empty
  60                    FileNode -> return $ S.singleton (decodePath path)
  61                    DirNode  -> traverse path
  62
  63       decodePath :: FilePath -> PageName
  64       decodePath = decodePageName . makeRelative root . dropExtension
  65
  66
  67 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
  68 findChangedPagesAtRevision repos rev
  69     = do fs <- getRepositoryFS repos
  70          withRevision fs rev
  71              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
  72     where
  73       accumulatePages :: Set PageName -> FilePath -> Set PageName
  74       accumulatePages s path
  75           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
  76               = let encoded = makeRelative "/pages" $ dropExtension path
  77                     name    = decodePageName encoded
  78                 in
  79                   S.insert name s
  80           | otherwise
  81               = s
  82
  83
  84 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  85 loadPageInRepository repos name rev
  86     = do fs   <- getRepositoryFS repos
  87          rev' <- case rev of
  88                    Nothing -> getYoungestRev fs
  89                    Just r  -> return r
  90          withRevision fs rev'
  91              $ do exists <- isFile path
  92                   case exists of
  93                     True
  94                         -> return . Just =<< loadPage'
  95                     False
  96                         -> return Nothing
  97     where
  98       path :: FilePath
  99       path = mkPagePath name
 100
 101       loadPage' :: Rev Page
 102       loadPage' = do redirect <- getNodeProp path "rakka:redirect"
 103                      case redirect of
 104                        Nothing
 105                            -> loadPageEntity
 106                        Just _
 107                            -> loadPageRedirect
 108
 109       loadPageEntity :: Rev Page
 110       loadPageEntity
 111           = do props   <- getNodePropList path
 112                hist    <- getNodeHistory True path
 113                content <- getFileContentsLBS path
 114
 115                let pageRev  = fst $ head hist
 116                    mimeType = read
 117                               $ fromMaybe "text/x-rakka"
 118                               $ fmap chomp (lookup "svn:mime-type" props)
 119
 120                lastMod <- getRevisionProp "svn:date"
 121                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 122
 123                return Entity {
 124                             entityName       = name
 125                           , entityType       = mimeType
 126                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 127                           , entityFileName   = fmap chomp (lookup "rakka:fileName" props)
 128                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 129                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 130                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 131                           , entityIsBoring   = any ((== "rakka:isBoring") . fst) props
 132                           , entityIsBinary   = case mimeType of
 133                                                  MIMEType "text" _ _
 134                                                      -> any ((== "rakka:isBinary") . fst) props
 135                                                  _
 136                                                      -> True
 137                           , entityRevision   = pageRev
 138                           , entityLastMod    = zonedTimeToUTC lastMod
 139                           , entitySummary    = lookup "rakka:summary" props
 140                           , entityOtherLang  = fromMaybe M.empty
 141                                              $ fmap
 142                                                    (M.fromList . fromJust . deserializeStringPairs)
 143                                                    (lookup "rakka:otherLang" props)
 144                           , entityContent    = content
 145                           , entityUpdateInfo = undefined
 146                           }
 147
 148       loadPageRedirect :: Rev Page
 149       loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented"
 150
 151
 152 putPageIntoRepository :: Repository -> Page -> IO StatusCode
 153 putPageIntoRepository repos page
 154     = do let Just ui = pageUpdateInfo page
 155              name    = pageName page
 156          ret <- doReposTxn
 157                 repos
 158                 (uiOldRevision ui)
 159                 "[Rakka]"
 160                 (Just "Automatic commit by Rakka for page updating")
 161                 $ do case uiOldName ui of
 162                        Nothing      -> return ()
 163                        Just oldName -> renamePage oldName name
 164                      createPageIfNeeded name
 165                      updatePage name
 166          case ret of
 167            Left _ ->
 168                return Conflict
 169            Right _ ->
 170                return Created
 171     where
 172       renamePage :: PageName -> PageName -> Txn ()
 173       renamePage oldName newName
 174           = fail "FIXME: renamePage: not implemented yet"
 175
 176       createPageIfNeeded :: PageName -> Txn ()
 177       createPageIfNeeded name
 178           = do let path = mkPagePath name
 179                kind <- checkPath path
 180                case kind of
 181                  NoNode   -> do createParentDirectories path
 182                                 makeFile path
 183                  FileNode -> return ()
 184                  DirNode  -> fail ("createPageIfNeeded: already exists a directory: " ++ path)
 185
 186       createParentDirectories :: FilePath -> Txn ()
 187       createParentDirectories path
 188           = do let parentPath = takeDirectory path
 189                kind <- checkPath parentPath
 190                case kind of
 191                  NoNode   -> createParentDirectories parentPath
 192                  FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 193                  DirNode  -> return ()
 194
 195       updatePage :: PageName -> Txn ()
 196       updatePage name
 197           | isRedirect page = updatePageRedirect name
 198           | isEntity   page = updatePageEntity name
 199           | otherwise       = fail "neither redirection nor page"
 200
 201       updatePageRedirect :: PageName -> Txn ()
 202       updatePageRedirect name
 203           = fail "FIXME: updatePageRedirect: not implemented yet"
 204
 205       updatePageEntity :: PageName -> Txn ()
 206       updatePageEntity name
 207           = do let path = mkPagePath name
 208                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 209                setNodeProp path "rakka:lang"      (entityLanguage page)
 210                setNodeProp path "rakka:fileName"  (entityFileName page)
 211                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 212                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 213                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 214                setNodeProp path "rakka:isBoring"  (encodeFlag $ entityIsBoring page)
 215                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 216                setNodeProp path "rakka:summary"   (entitySummary page)
 217                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 218                                                    in
 219                                                      if M.null otherLang then
 220                                                          Nothing
 221                                                      else
 222                                                          Just (serializeStringPairs $ M.toList otherLang))
 223                applyTextLBS path Nothing (entityContent page)
 224
 225       encodeFlag :: Bool -> Maybe String
 226       encodeFlag True  = Just "*\n"
 227       encodeFlag False = Nothing