Rakka/Storage/Repos.hs

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