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