Rakka/Storage/Repos.hs

   1 module Rakka.Storage.Repos
   2     ( findAllPagesInRevision
   3     , getDirContentsInRevision
   4     , findChangedPagesAtRevision
   5     , loadPageInRepository
   6     , putPageIntoRepository
   7     , deletePageFromRepository
   8     , loadAttachmentInRepository
   9     , putAttachmentIntoRepository
  10     )
  11     where
  12
  13 import           Codec.Binary.UTF8.String
  14 import           Control.Exception
  15 import           Control.Monad
  16 import           Data.List
  17 import qualified Data.Map as M
  18 import           Data.Maybe
  19 import           Data.Set (Set)
  20 import qualified Data.Set as S hiding (Set)
  21 import           Data.Time
  22 import           Network.HTTP.Lucu hiding (redirect)
  23 import           Rakka.Attachment
  24 import           Rakka.Page
  25 import           Rakka.SystemConfig
  26 import           Rakka.Utils
  27 import           Rakka.W3CDateTime
  28 import           Subversion.Error
  29 import           Subversion.FileSystem
  30 import           Subversion.FileSystem.DirEntry
  31 import           Subversion.FileSystem.Revision
  32 import           Subversion.FileSystem.Root
  33 import           Subversion.FileSystem.Transaction
  34 import           Subversion.Repository
  35 import           Subversion.Types
  36 import           System.FilePath.Posix
  37
  38
  39 mkPagePath :: PageName -> FilePath
  40 mkPagePath name
  41     = "/pages" </> encodePageName name <.> "page"
  42
  43
  44 mkDirPath :: PageName -> FilePath
  45 mkDirPath dir
  46     = "/pages" </> encodePageName dir
  47
  48
  49 mkAttachmentPath :: PageName -> String -> FilePath
  50 mkAttachmentPath pName aName
  51     = "/attachments" </> encodePageName pName <.> "page" </> aName
  52
  53
  54 mkAttachmentDirPath :: PageName -> FilePath
  55 mkAttachmentDirPath pName
  56     = "/attachments" </> encodePageName pName <.> "page"
  57
  58
  59 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
  60 findAllPagesInRevision repos rev
  61     = do fs <- getRepositoryFS repos
  62          withRevision fs rev
  63              $ do exists <- isDirectory root
  64                   if exists then
  65                       traverse root
  66                     else
  67                       return S.empty
  68     where
  69       root :: FilePath
  70       root = "/pages"
  71
  72       traverse :: FilePath -> Rev (Set PageName)
  73       traverse dir
  74           = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
  75
  76       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
  77       traverse' dir entry
  78           = let path = dir </> entName entry
  79             in
  80               do kind <- checkPath path
  81                  case kind of
  82                    NoNode   -> return S.empty
  83                    FileNode -> return $ S.singleton (decodePath path)
  84                    DirNode  -> traverse path
  85
  86       decodePath :: FilePath -> PageName
  87       decodePath = decodePageName . makeRelative root . dropExtension
  88
  89
  90 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
  91 getDirContentsInRevision repos dir rev
  92     = do fs   <- getRepositoryFS repos
  93          rev' <- case rev of
  94                    Nothing -> getYoungestRev fs
  95                    Just r  -> return r
  96          withRevision fs rev'
  97              $ do exists <- isDirectory path
  98                   if exists then
  99                       return . S.fromList =<< getDir'
 100                     else
 101                       return S.empty
 102     where
 103       path :: FilePath
 104       path = mkDirPath dir
 105
 106       getDir' :: Rev [PageName]
 107       getDir' = liftM (map entToName) (getDirEntries path)
 108
 109       entToName :: DirEntry -> PageName
 110       entToName = (dir </>) . decodePageName . dropExtension . entName
 111
 112
 113 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
 114 findChangedPagesAtRevision repos rev
 115     = do fs <- getRepositoryFS repos
 116          withRevision fs rev
 117              $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
 118     where
 119       accumulatePages :: Set PageName -> FilePath -> Set PageName
 120       accumulatePages s path
 121           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
 122               = let encoded = makeRelative "/pages" $ dropExtension path
 123                     name    = decodePageName encoded
 124                 in
 125                   S.insert name s
 126           | otherwise
 127               = s
 128
 129
 130 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
 131 loadPageInRepository repos name rev
 132     = do fs   <- getRepositoryFS repos
 133          rev' <- case rev of
 134                    Nothing -> getYoungestRev fs
 135                    Just r  -> return r
 136          withRevision fs rev'
 137              $ do exists <- isFile path
 138                   if exists then
 139                       return . Just =<< loadPage' fs
 140                     else
 141                       return Nothing
 142     where
 143       path :: FilePath
 144       path = mkPagePath name
 145
 146       loadPage' :: FileSystem -> Rev Page
 147       loadPage' fs
 148           = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
 149                case mType of
 150                  Just (MIMEType "application" "x-rakka-redirection" _)
 151                      -> loadPageRedirect fs
 152                  _
 153                      -> loadPageEntity fs
 154
 155       loadPageEntity :: FileSystem -> Rev Page
 156       loadPageEntity fs
 157           = do props   <- getNodePropList path
 158                hist    <- getNodeHistory True path
 159                content <- getFileContentsLBS path
 160
 161                let pageRev  = fst $ head hist
 162                    mimeType = read
 163                               $ fromMaybe "text/x-rakka"
 164                               $ fmap chomp (lookup "svn:mime-type" props)
 165
 166                lastMod <- unsafeIOToFS $
 167                           liftM (fromJust . parseW3CDateTime . chomp . fromJust)
 168                                 (getRevisionProp' fs pageRev "svn:date")
 169
 170                return Entity {
 171                             entityName       = name
 172                           , entityType       = mimeType
 173                           , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
 174                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
 175                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
 176                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
 177                           , entityIsBinary   = case mimeType of
 178                                                  MIMEType "text" _ _
 179                                                      -> any ((== "rakka:isBinary") . fst) props
 180                                                  _
 181                                                      -> True
 182                           , entityRevision   = pageRev
 183                           , entityLastMod    = zonedTimeToUTC lastMod
 184                           , entitySummary    = fmap decodeString (lookup "rakka:summary" props)
 185                           , entityOtherLang  = fromMaybe M.empty
 186                                              $ fmap
 187                                                    (M.fromList . fromJust . deserializeStringPairs . decodeString)
 188                                                    (lookup "rakka:otherLang" props)
 189                           , entityContent    = content
 190                           , entityUpdateInfo = undefined
 191                           }
 192
 193       loadPageRedirect :: FileSystem -> Rev Page
 194       loadPageRedirect fs
 195           = do hist    <- getNodeHistory True path
 196                content <- getFileContents path
 197
 198                let pageRev = fst $ head hist
 199                    dest    = chomp $ decodeString content
 200
 201                lastMod <- unsafeIOToFS $
 202                           liftM (fromJust . parseW3CDateTime . chomp . fromJust)
 203                                 (getRevisionProp' fs pageRev "svn:date")
 204
 205                isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
 206
 207                return Redirection {
 208                             redirName       = name
 209                           , redirDest       = dest
 210                           , redirIsLocked   = isLocked
 211                           , redirRevision   = pageRev
 212                           , redirLastMod    = zonedTimeToUTC lastMod
 213                           , redirUpdateInfo = undefined
 214                           }
 215
 216
 217 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 218 putPageIntoRepository repos userID page
 219     = filterSvnError $
 220       do let name   = pageName page
 221              author = fromMaybe "[Rakka]" userID
 222          case pageUpdateInfo page of
 223            Just ui
 224                -> do let oldRev = uiOldRevision ui
 225                      denied <- case uiOldName ui of
 226                                  Nothing      -> checkDenial oldRev name
 227                                  Just oldName -> checkDenial oldRev oldName
 228                      if denied then
 229                          return Forbidden
 230                        else
 231                          do rev <- if oldRev == 0 then
 232                                        getRepositoryFS repos >>= getYoungestRev
 233                                    else
 234                                        return oldRev
 235                             ret <- doReposTxn
 236                                    repos
 237                                    rev
 238                                    author
 239                                    (Just "Automatic commit by Rakka for page update")
 240                                    $ do
 241                                         case uiOldName ui of
 242                                           Nothing      -> return ()
 243                                           Just oldName -> do exists <- isFile (mkPagePath oldName)
 244                                                              when exists
 245                                                                   $ do movePage (uiOldRevision ui) oldName name
 246                                                                        moveAttachments (uiOldRevision ui) oldName name
 247                                         exists <- isFile (mkPagePath name)
 248                                         unless exists
 249                                                $ createPage name
 250                                         updatePage name
 251                             case ret of
 252                               Left  _ -> return Conflict
 253                               Right _ -> return Created
 254            Nothing
 255                -> do fs  <- getRepositoryFS repos
 256                      rev <- getYoungestRev fs
 257                      ret <- doReposTxn
 258                             repos
 259                             rev
 260                             author
 261                             (Just "Automatic commit by Rakka for page creation")
 262                             $ do createPage name
 263                                  updatePage name
 264                      case ret of
 265                        Left  _ -> return Conflict
 266                        Right _ -> return Created
 267     where
 268       checkDenial :: RevNum -> PageName -> IO Bool
 269       checkDenial rev name
 270           = do fs <- getRepositoryFS repos
 271                withRevision fs rev
 272                    $ do exists <- isFile (mkPagePath name)
 273                         if exists then
 274                             do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 275                                case prop of
 276                                  Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 277                                  Nothing -> return False
 278                           else
 279                             return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
 280
 281       movePage :: RevNum -> PageName -> PageName -> Txn ()
 282       movePage oldRev oldName newName
 283           = do let oldPath = mkPagePath oldName
 284                    newPath = mkPagePath newName
 285                createParentDirectories newPath
 286                copyEntry oldRev oldPath newPath
 287                deleteEntry oldPath
 288                deleteEmptyParentDirectories oldPath
 289
 290       moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
 291       moveAttachments oldRev oldName newName
 292           = do let oldPath = mkAttachmentDirPath oldName
 293                    newPath = mkAttachmentDirPath newName
 294                createParentDirectories newPath
 295                copyEntry oldRev oldPath newPath
 296                deleteEntry oldPath
 297                deleteEmptyParentDirectories oldPath
 298
 299       createPage :: PageName -> Txn ()
 300       createPage name
 301           = do let path = mkPagePath name
 302                createParentDirectories path
 303                makeFile path
 304
 305       updatePage :: PageName -> Txn ()
 306       updatePage name
 307           | isRedirect page = updatePageRedirect name
 308           | isEntity   page = updatePageEntity name
 309           | otherwise       = fail "neither redirection nor page"
 310
 311       updatePageRedirect :: PageName -> Txn ()
 312       updatePageRedirect name
 313           = do let path = mkPagePath name
 314                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 315                setNodeProp path "rakka:lang"      Nothing
 316                setNodeProp path "rakka:isTheme"   Nothing
 317                setNodeProp path "rakka:isFeed"    Nothing
 318                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
 319                setNodeProp path "rakka:isBinary"  Nothing
 320                setNodeProp path "rakka:summary"   Nothing
 321                setNodeProp path "rakka:otherLang" Nothing
 322                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 323
 324       updatePageEntity :: PageName -> Txn ()
 325       updatePageEntity name
 326           = do let path = mkPagePath name
 327                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 328                setNodeProp path "rakka:lang"      (entityLanguage page)
 329                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 330                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 331                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 332                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 333                setNodeProp path "rakka:summary"   (fmap encodeString $ entitySummary page)
 334                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 335                                                    in
 336                                                      if M.null otherLang then
 337                                                          Nothing
 338                                                      else
 339                                                          Just (encodeString $ serializeStringPairs $ M.toList otherLang))
 340                applyTextLBS path Nothing (entityContent page)
 341
 342       encodeFlag :: Bool -> Maybe String
 343       encodeFlag True  = Just "*"
 344       encodeFlag False = Nothing
 345
 346
 347 createParentDirectories :: FilePath -> Txn ()
 348 createParentDirectories path
 349     = do let parentPath = takeDirectory path
 350          kind <- checkPath parentPath
 351          case kind of
 352            NoNode   -> do createParentDirectories parentPath
 353                           makeDirectory parentPath
 354            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 355            DirNode  -> return ()
 356
 357
 358 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 359 deletePageFromRepository repos userID name
 360     = filterSvnError $
 361       do let pagePath       = mkPagePath name
 362              attachmentPath = mkAttachmentDirPath name
 363          fs     <- getRepositoryFS repos
 364          rev    <- getYoungestRev fs
 365          status <- withRevision fs rev
 366                    $ do exists <- isFile pagePath
 367                         if exists then
 368                             do prop <- getNodeProp pagePath "rakka:isLocked"
 369                                return $ case prop of
 370                                           Just _
 371                                               -> if isNothing userID then
 372                                                      -- 施錠されてゐるので匿名では駄目
 373                                                      Forbidden
 374                                                  else
 375                                                      NoContent
 376                                           Nothing
 377                                               -> NoContent
 378                           else
 379                             return NotFound
 380          when (status == NoContent)
 381              $ do doReposTxn repos
 382                              rev
 383                              "[Rakka]"
 384                              (Just "Automatic commit by Rakka for page deleting")
 385                              $ do deleteEntry pagePath
 386                                   deleteEmptyParentDirectories pagePath
 387
 388                                   attachmentExists <- isDirectory attachmentPath
 389                                   when attachmentExists
 390                                       $ do deleteEntry attachmentPath
 391                                            deleteEmptyParentDirectories attachmentPath
 392                   return ()
 393          return status
 394
 395
 396 deleteEmptyParentDirectories :: FilePath -> Txn ()
 397 deleteEmptyParentDirectories path
 398     = do let parentPath = takeDirectory path
 399          contents <- getDirEntries parentPath
 400          when (null contents)
 401                   $ do deleteEntry parentPath
 402                        deleteEmptyParentDirectories parentPath
 403
 404
 405 loadAttachmentInRepository :: forall a. Attachment a =>
 406                               Repository
 407                            -> PageName
 408                            -> String
 409                            -> Maybe RevNum
 410                            -> IO (Maybe a)
 411 loadAttachmentInRepository repos pName aName rev
 412     = do fs   <- getRepositoryFS repos
 413          rev' <- case rev of
 414                    Nothing -> getYoungestRev fs
 415                    Just r  -> return r
 416          withRevision fs rev'
 417              $ do exists <- isFile path
 418                   if exists then
 419                       return . Just =<< loadAttachment'
 420                     else
 421                       return Nothing
 422     where
 423       path :: FilePath
 424       path = mkAttachmentPath pName aName
 425
 426       loadAttachment' :: Rev a
 427       loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
 428
 429
 430 putAttachmentIntoRepository :: Attachment a =>
 431                                Repository
 432                             -> Maybe String
 433                             -> Maybe RevNum
 434                             -> PageName
 435                             -> String
 436                             -> a
 437                             -> IO StatusCode
 438 putAttachmentIntoRepository repos userID oldRev pName aName attachment
 439     = filterSvnError $
 440       do let author = fromMaybe "[Rakka]" userID
 441              path   = mkAttachmentPath pName aName
 442          fs      <- getRepositoryFS repos
 443          oldRev' <- case oldRev of
 444                       Nothing -> getYoungestRev fs
 445                       Just r  -> return r
 446          ret <- doReposTxn
 447                 repos
 448                 oldRev'
 449                 author
 450                 (Just "Automatic commit by Rakka for putting attachment")
 451                 $ do exists <- isFile path
 452                      unless exists
 453                          $ do createParentDirectories path
 454                               makeFile path
 455                      applyText path Nothing (serializeToString attachment)
 456          case ret of
 457            Left  _ -> return Conflict
 458            Right _ -> return NoContent
 459
 460
 461 filterSvnError :: IO a -> IO a
 462 filterSvnError f = catchDyn f rethrow
 463     where
 464       rethrow :: SvnError -> IO a
 465       rethrow err
 466           = let code = svnErrCode err
 467                 msg  = svnErrMsg  err
 468             in
 469               fail $ "SvnError: " ++ show code ++ ": " ++ msg