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           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
  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' = getDirEntries path >>= return . map entToName
 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              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
 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                           getRevisionProp' fs pageRev "svn:date"
 168                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 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                           getRevisionProp' fs pageRev "svn:date"
 203                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
 204
 205                isLocked <- getNodeProp path "rakka:isLocked"
 206                            >>= return . isJust
 207
 208                return Redirection {
 209                             redirName       = name
 210                           , redirDest       = dest
 211                           , redirIsLocked   = isLocked
 212                           , redirRevision   = pageRev
 213                           , redirLastMod    = zonedTimeToUTC lastMod
 214                           , redirUpdateInfo = undefined
 215                           }
 216
 217
 218 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 219 putPageIntoRepository repos userID page
 220     = filterSvnError $
 221       do let name   = pageName page
 222              author = fromMaybe "[Rakka]" userID
 223          case pageUpdateInfo page of
 224            Just ui
 225                -> do let oldRev = uiOldRevision ui
 226                      denied <- case uiOldName ui of
 227                                  Nothing      -> checkDenial oldRev name
 228                                  Just oldName -> checkDenial oldRev oldName
 229                      if denied then
 230                          return Forbidden
 231                        else
 232                          do rev <- if oldRev == 0 then
 233                                        getRepositoryFS repos >>= getYoungestRev
 234                                    else
 235                                        return oldRev
 236                             ret <- doReposTxn
 237                                    repos
 238                                    rev
 239                                    author
 240                                    (Just "Automatic commit by Rakka for page update")
 241                                    $ do
 242                                         case uiOldName ui of
 243                                           Nothing      -> return ()
 244                                           Just oldName -> do exists <- isFile (mkPagePath oldName)
 245                                                              when (exists)
 246                                                                   $ do movePage (uiOldRevision ui) oldName name
 247                                                                        moveAttachments (uiOldRevision ui) oldName name
 248                                         exists <- isFile (mkPagePath name)
 249                                         unless (exists)
 250                                                $ createPage name
 251                                         updatePage name
 252                             case ret of
 253                               Left  _ -> return Conflict
 254                               Right _ -> return Created
 255            Nothing
 256                -> do fs  <- getRepositoryFS repos
 257                      rev <- getYoungestRev fs
 258                      ret <- doReposTxn
 259                             repos
 260                             rev
 261                             author
 262                             (Just "Automatic commit by Rakka for page creation")
 263                             $ do createPage name
 264                                  updatePage name
 265                      case ret of
 266                        Left  _ -> return Conflict
 267                        Right _ -> return Created
 268     where
 269       checkDenial :: RevNum -> PageName -> IO Bool
 270       checkDenial rev name
 271           = do fs <- getRepositoryFS repos
 272                withRevision fs rev
 273                    $ do exists <- isFile (mkPagePath name)
 274                         if exists then
 275                             do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 276                                case prop of
 277                                  Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 278                                  Nothing -> return False
 279                           else
 280                             return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
 281
 282       movePage :: RevNum -> PageName -> PageName -> Txn ()
 283       movePage oldRev oldName newName
 284           = do let oldPath = mkPagePath oldName
 285                    newPath = mkPagePath newName
 286                createParentDirectories newPath
 287                copyEntry oldRev oldPath newPath
 288                deleteEntry oldPath
 289                deleteEmptyParentDirectories oldPath
 290
 291       moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
 292       moveAttachments oldRev oldName newName
 293           = do let oldPath = mkAttachmentDirPath oldName
 294                    newPath = mkAttachmentDirPath newName
 295                createParentDirectories newPath
 296                copyEntry oldRev oldPath newPath
 297                deleteEntry oldPath
 298                deleteEmptyParentDirectories oldPath
 299
 300       createPage :: PageName -> Txn ()
 301       createPage name
 302           = do let path = mkPagePath name
 303                createParentDirectories path
 304                makeFile path
 305
 306       updatePage :: PageName -> Txn ()
 307       updatePage name
 308           | isRedirect page = updatePageRedirect name
 309           | isEntity   page = updatePageEntity name
 310           | otherwise       = fail "neither redirection nor page"
 311
 312       updatePageRedirect :: PageName -> Txn ()
 313       updatePageRedirect name
 314           = do let path = mkPagePath name
 315                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 316                setNodeProp path "rakka:lang"      Nothing
 317                setNodeProp path "rakka:isTheme"   Nothing
 318                setNodeProp path "rakka:isFeed"    Nothing
 319                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
 320                setNodeProp path "rakka:isBinary"  Nothing
 321                setNodeProp path "rakka:summary"   Nothing
 322                setNodeProp path "rakka:otherLang" Nothing
 323                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 324
 325       updatePageEntity :: PageName -> Txn ()
 326       updatePageEntity name
 327           = do let path = mkPagePath name
 328                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 329                setNodeProp path "rakka:lang"      (entityLanguage page)
 330                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 331                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 332                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 333                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 334                setNodeProp path "rakka:summary"   (fmap encodeString $ entitySummary page)
 335                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 336                                                    in
 337                                                      if M.null otherLang then
 338                                                          Nothing
 339                                                      else
 340                                                          Just (encodeString $ serializeStringPairs $ M.toList otherLang))
 341                applyTextLBS path Nothing (entityContent page)
 342
 343       encodeFlag :: Bool -> Maybe String
 344       encodeFlag True  = Just "*"
 345       encodeFlag False = Nothing
 346
 347
 348 createParentDirectories :: FilePath -> Txn ()
 349 createParentDirectories path
 350     = do let parentPath = takeDirectory path
 351          kind <- checkPath parentPath
 352          case kind of
 353            NoNode   -> do createParentDirectories parentPath
 354                           makeDirectory parentPath
 355            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 356            DirNode  -> return ()
 357
 358
 359 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 360 deletePageFromRepository repos userID name
 361     = filterSvnError $
 362       do let pagePath       = mkPagePath name
 363              attachmentPath = mkAttachmentDirPath name
 364          fs     <- getRepositoryFS repos
 365          rev    <- getYoungestRev fs
 366          status <- withRevision fs rev
 367                    $ do exists <- isFile pagePath
 368                         if exists then
 369                             do prop <- getNodeProp pagePath "rakka:isLocked"
 370                                return $ case prop of
 371                                           Just _
 372                                               -> if isNothing userID then
 373                                                      -- 施錠されてゐるので匿名では駄目
 374                                                      Forbidden
 375                                                  else
 376                                                      NoContent
 377                                           Nothing
 378                                               -> NoContent
 379                           else
 380                             return NotFound
 381          when (status == NoContent)
 382              $ do doReposTxn repos
 383                              rev
 384                              "[Rakka]"
 385                              (Just "Automatic commit by Rakka for page deleting")
 386                              $ do deleteEntry pagePath
 387                                   deleteEmptyParentDirectories pagePath
 388
 389                                   attachmentExists <- isDirectory attachmentPath
 390                                   when attachmentExists
 391                                       $ do deleteEntry attachmentPath
 392                                            deleteEmptyParentDirectories attachmentPath
 393                   return ()
 394          return status
 395
 396
 397 deleteEmptyParentDirectories :: FilePath -> Txn ()
 398 deleteEmptyParentDirectories path
 399     = do let parentPath = takeDirectory path
 400          contents <- getDirEntries parentPath
 401          when (null contents)
 402                   $ do deleteEntry parentPath
 403                        deleteEmptyParentDirectories parentPath
 404
 405
 406 loadAttachmentInRepository :: forall a. Attachment a =>
 407                               Repository
 408                            -> PageName
 409                            -> String
 410                            -> Maybe RevNum
 411                            -> IO (Maybe a)
 412 loadAttachmentInRepository repos pName aName rev
 413     = do fs   <- getRepositoryFS repos
 414          rev' <- case rev of
 415                    Nothing -> getYoungestRev fs
 416                    Just r  -> return r
 417          withRevision fs rev'
 418              $ do exists <- isFile path
 419                   if exists then
 420                       return . Just =<< loadAttachment'
 421                     else
 422                       return Nothing
 423     where
 424       path :: FilePath
 425       path = mkAttachmentPath pName aName
 426
 427       loadAttachment' :: Rev a
 428       loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
 429
 430
 431 putAttachmentIntoRepository :: Attachment a =>
 432                                Repository
 433                             -> Maybe String
 434                             -> Maybe RevNum
 435                             -> PageName
 436                             -> String
 437                             -> a
 438                             -> IO StatusCode
 439 putAttachmentIntoRepository repos userID oldRev pName aName attachment
 440     = filterSvnError $
 441       do let author = fromMaybe "[Rakka]" userID
 442              path   = mkAttachmentPath pName aName
 443          fs      <- getRepositoryFS repos
 444          oldRev' <- case oldRev of
 445                       Nothing -> getYoungestRev fs
 446                       Just r  -> return r
 447          ret <- doReposTxn
 448                 repos
 449                 oldRev'
 450                 author
 451                 (Just "Automatic commit by Rakka for putting attachment")
 452                 $ do exists <- isFile path
 453                      unless exists
 454                          $ do createParentDirectories path
 455                               makeFile path
 456                      applyText path Nothing (serializeToString attachment)
 457          case ret of
 458            Left  _ -> return Conflict
 459            Right _ -> return NoContent
 460
 461
 462 filterSvnError :: IO a -> IO a
 463 filterSvnError f = catchDyn f rethrow
 464     where
 465       rethrow :: SvnError -> IO a
 466       rethrow err
 467           = let code = svnErrCode err
 468                 msg  = svnErrMsg  err
 469             in
 470               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg