Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , findChangedPagesAtRevision
   4     , loadPageInRepository
   5     , putPageIntoRepository
   6     , deletePageFromRepository
   7     )
   8     where
   9
  10 import           Codec.Binary.UTF8.String
  11 import           Control.Exception
  12 import           Control.Monad
  13 import           Data.List
  14 import qualified Data.Map as M
  15 import           Data.Maybe
  16 import           Data.Set (Set)
  17 import qualified Data.Set as S hiding (Set)
  18 import           Data.Time
  19 import           Network.HTTP.Lucu hiding (redirect)
  20 import           Rakka.Page
  21 import           Rakka.SystemConfig
  22 import           Rakka.Utils
  23 import           Rakka.W3CDateTime
  24 import           Subversion.Error
  25 import           Subversion.FileSystem
  26 import           Subversion.FileSystem.DirEntry
  27 import           Subversion.FileSystem.Revision
  28 import           Subversion.FileSystem.Root
  29 import           Subversion.FileSystem.Transaction
  30 import           Subversion.Repository
  31 import           Subversion.Types
  32 import           System.FilePath.Posix
  33
  34
  35 mkPagePath :: PageName -> FilePath
  36 mkPagePath name
  37     = "/pages" </> encodePageName name <.> "page"
  38
  39
  40 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  41 findAllPagesInRevision repos rev
  42     = do fs <- getRepositoryFS repos
  43          withRevision fs rev
  44              $ do exists <- isDirectory root
  45                   if exists then
  46                       traverse root
  47                     else
  48                       return S.empty
  49     where
  50       root :: FilePath
  51       root = "/pages"
  52
  53       traverse :: FilePath -> Rev (Set PageName)
  54       traverse dir
  55           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  56
  57       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  58       traverse' dir entry
  59           = let path = dir </> entName entry
  60             in
  61               do kind <- checkPath path
  62                  case kind of
  63                    NoNode   -> return S.empty
  64                    FileNode -> return $ S.singleton (decodePath path)
  65                    DirNode  -> traverse path
  66
  67       decodePath :: FilePath -> PageName
  68       decodePath = decodePageName . makeRelative root . dropExtension
  69
  70
  71 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
  72 findChangedPagesAtRevision repos rev
  73     = do fs <- getRepositoryFS repos
  74          withRevision fs rev
  75              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
  76     where
  77       accumulatePages :: Set PageName -> FilePath -> Set PageName
  78       accumulatePages s path
  79           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
  80               = let encoded = makeRelative "/pages" $ dropExtension path
  81                     name    = decodePageName encoded
  82                 in
  83                   S.insert name s
  84           | otherwise
  85               = s
  86
  87
  88 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  89 loadPageInRepository repos name rev
  90     = do fs   <- getRepositoryFS repos
  91          rev' <- case rev of
  92                    Nothing -> getYoungestRev fs
  93                    Just r  -> return r
  94          withRevision fs rev'
  95              $ do exists <- isFile path
  96                   case exists of
  97                     True
  98                         -> return . Just =<< loadPage'
  99                     False
 100                         -> return Nothing
 101     where
 102       path :: FilePath
 103       path = mkPagePath name
 104
 105       loadPage' :: Rev Page
 106       loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
 107                      case mType of
 108                        Just (MIMEType "application" "x-rakka-redirection" _)
 109                            -> loadPageRedirect
 110                        _
 111                            -> loadPageEntity
 112
 113       loadPageEntity :: Rev Page
 114       loadPageEntity
 115           = do props   <- getNodePropList path
 116                hist    <- getNodeHistory True path
 117                content <- getFileContentsLBS path
 118
 119                let pageRev  = fst $ head hist
 120                    mimeType = read
 121                               $ fromMaybe "text/x-rakka"
 122                               $ fmap chomp (lookup "svn:mime-type" props)
 123
 124                lastMod <- getRevisionProp "svn:date"
 125                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 126
 127                return Entity {
 128                             entityName       = name
 129                           , entityType       = mimeType
 130                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 131                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 132                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 133                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 134                           , entityIsBinary   = case mimeType of
 135                                                  MIMEType "text" _ _
 136                                                      -> any ((== "rakka:isBinary") . fst) props
 137                                                  _
 138                                                      -> True
 139                           , entityRevision   = pageRev
 140                           , entityLastMod    = zonedTimeToUTC lastMod
 141                           , entitySummary    = lookup "rakka:summary" props
 142                           , entityOtherLang  = fromMaybe M.empty
 143                                              $ fmap
 144                                                    (M.fromList . fromJust . deserializeStringPairs)
 145                                                    (lookup "rakka:otherLang" props)
 146                           , entityContent    = content
 147                           , entityUpdateInfo = undefined
 148                           }
 149
 150       loadPageRedirect :: Rev Page
 151       loadPageRedirect
 152           = do hist    <- getNodeHistory True path
 153                content <- getFileContents path
 154
 155                let pageRev = fst $ head hist
 156                    dest    = chomp $ decodeString content
 157
 158                lastMod <- getRevisionProp "svn:date"
 159                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 160
 161                isLocked <- getRevisionProp "rakka:isLocked"
 162                            >>= return . isJust
 163
 164                return Redirection {
 165                             redirName       = name
 166                           , redirDest       = dest
 167                           , redirIsLocked   = isLocked
 168                           , redirRevision   = pageRev
 169                           , redirLastMod    = zonedTimeToUTC lastMod
 170                           , redirUpdateInfo = undefined
 171                           }
 172
 173
 174 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 175 putPageIntoRepository repos userID page
 176     = filterSvnError $
 177       do let name   = pageName page
 178              author = fromMaybe "[Rakka]" userID
 179          case pageUpdateInfo page of
 180            Just ui
 181                -> do let oldRev = uiOldRevision ui
 182                      denied <- case uiOldName ui of
 183                                  Nothing      -> checkDenial oldRev name
 184                                  Just oldName -> checkDenial oldRev oldName
 185                      if denied then
 186                          return Forbidden
 187                        else
 188                          do ret <- doReposTxn
 189                                    repos
 190                                    (uiOldRevision ui)
 191                                    author
 192                                    (Just "Automatic commit by Rakka for page update")
 193                                    $ do case uiOldName ui of
 194                                           Nothing      -> return ()
 195                                           Just oldName -> renamePage (uiOldRevision ui) oldName name
 196                                         updatePage name
 197                             case ret of
 198                               Left  _ -> return Conflict
 199                               Right _ -> return Created
 200            Nothing
 201                -> do fs  <- getRepositoryFS repos
 202                      rev <- getYoungestRev fs
 203                      ret <- doReposTxn
 204                             repos
 205                             rev
 206                             author
 207                             (Just "Automatic commit by Rakka for page creation")
 208                             $ do createPage name
 209                                  updatePage name
 210                      case ret of
 211                        Left  _ -> return Conflict
 212                        Right _ -> return Created
 213     where
 214       checkDenial :: RevNum -> PageName -> IO Bool
 215       checkDenial rev name
 216           = do fs <- getRepositoryFS repos
 217                withRevision fs rev
 218                    $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 219                         case prop of
 220                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 221                           Nothing -> return False
 222
 223       renamePage :: RevNum -> PageName -> PageName -> Txn ()
 224       renamePage oldRev oldName newName
 225           = do let oldPath = mkPagePath oldName
 226                    newPath = mkPagePath newName
 227                createParentDirectories newPath
 228                copyEntry oldRev oldPath newPath
 229                deleteEntry oldPath
 230                deleteEmptyParentDirectories oldPath
 231
 232       createPage :: PageName -> Txn ()
 233       createPage name
 234           = do let path = mkPagePath name
 235                createParentDirectories path
 236                makeFile path
 237
 238       updatePage :: PageName -> Txn ()
 239       updatePage name
 240           | isRedirect page = updatePageRedirect name
 241           | isEntity   page = updatePageEntity name
 242           | otherwise       = fail "neither redirection nor page"
 243
 244       updatePageRedirect :: PageName -> Txn ()
 245       updatePageRedirect name
 246           = do let path = mkPagePath name
 247                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 248                setNodeProp path "rakka:lang"      Nothing
 249                setNodeProp path "rakka:isTheme"   Nothing
 250                setNodeProp path "rakka:isFeed"    Nothing
 251                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
 252                setNodeProp path "rakka:isBinary"  Nothing
 253                setNodeProp path "rakka:summary"   Nothing
 254                setNodeProp path "rakka:otherLang" Nothing
 255                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 256
 257       updatePageEntity :: PageName -> Txn ()
 258       updatePageEntity name
 259           = do let path = mkPagePath name
 260                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 261                setNodeProp path "rakka:lang"      (entityLanguage page)
 262                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 263                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 264                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 265                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 266                setNodeProp path "rakka:summary"   (entitySummary page)
 267                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 268                                                    in
 269                                                      if M.null otherLang then
 270                                                          Nothing
 271                                                      else
 272                                                          Just (serializeStringPairs $ M.toList otherLang))
 273                applyTextLBS path Nothing (entityContent page)
 274
 275       encodeFlag :: Bool -> Maybe String
 276       encodeFlag True  = Just "*"
 277       encodeFlag False = Nothing
 278
 279
 280 createParentDirectories :: FilePath -> Txn ()
 281 createParentDirectories path
 282     = do let parentPath = takeDirectory path
 283          kind <- checkPath parentPath
 284          case kind of
 285            NoNode   -> do createParentDirectories parentPath
 286                           makeDirectory parentPath
 287            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 288            DirNode  -> return ()
 289
 290
 291 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 292 deletePageFromRepository repos userID name
 293     = filterSvnError $
 294       do let path = mkPagePath name
 295          fs     <- getRepositoryFS repos
 296          rev    <- getYoungestRev fs
 297          status <- withRevision fs rev
 298                    $ do exists <- isFile path
 299                         if exists then
 300                             do prop <- getNodeProp path "rakka:isLocked"
 301                                return $ case prop of
 302                                           Just _
 303                                               -> if isNothing userID then
 304                                                      -- 施錠されてゐるので匿名では駄目
 305                                                      Forbidden
 306                                                  else
 307                                                      NoContent
 308                                           Nothing
 309                                               -> NoContent
 310                           else
 311                             return NotFound
 312          when (status == NoContent)
 313              $ do doReposTxn repos
 314                              rev
 315                              "[Rakka]"
 316                              (Just "Automatic commit by Rakka for page deleting")
 317                              $ do deleteEntry path
 318                                   deleteEmptyParentDirectories path
 319                   return ()
 320          return status
 321
 322
 323 deleteEmptyParentDirectories :: FilePath -> Txn ()
 324 deleteEmptyParentDirectories path
 325     = do let parentPath = takeDirectory path
 326          contents <- getDirEntries parentPath
 327          when (null contents)
 328                   $ do deleteEntry parentPath
 329                        deleteEmptyParentDirectories parentPath
 330
 331
 332 filterSvnError :: IO a -> IO a
 333 filterSvnError f = catchDyn f rethrow
 334     where
 335       rethrow :: SvnError -> IO a
 336       rethrow err
 337           = let code = svnErrCode err
 338                 msg  = svnErrMsg  err
 339             in
 340               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg