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                return Redirection {
 162                             redirName       = name
 163                           , redirDest       = dest
 164                           , redirRevision   = pageRev
 165                           , redirLastMod    = zonedTimeToUTC lastMod
 166                           , redirUpdateInfo = undefined
 167                           }
 168
 169
 170 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
 171 putPageIntoRepository repos userID page
 172     = filterSvnError $
 173       do let name   = pageName page
 174              author = fromMaybe "[Rakka]" userID
 175          case pageUpdateInfo page of
 176            Just ui
 177                -> do let oldRev = uiOldRevision ui
 178                      denied <- case uiOldName ui of
 179                                  Nothing      -> checkDenial oldRev name
 180                                  Just oldName -> checkDenial oldRev oldName
 181                      if denied then
 182                          return Forbidden
 183                        else
 184                          do ret <- doReposTxn
 185                                    repos
 186                                    (uiOldRevision ui)
 187                                    author
 188                                    (Just "Automatic commit by Rakka for page update")
 189                                    $ do case uiOldName ui of
 190                                           Nothing      -> return ()
 191                                           Just oldName -> renamePage (uiOldRevision ui) oldName name
 192                                         updatePage name
 193                             case ret of
 194                               Left  _ -> return Conflict
 195                               Right _ -> return Created
 196            Nothing
 197                -> do fs  <- getRepositoryFS repos
 198                      rev <- getYoungestRev fs
 199                      ret <- doReposTxn
 200                             repos
 201                             rev
 202                             author
 203                             (Just "Automatic commit by Rakka for page creation")
 204                             $ do createPage name
 205                                  updatePage name
 206                      case ret of
 207                        Left  _ -> return Conflict
 208                        Right _ -> return Created
 209     where
 210       checkDenial :: RevNum -> PageName -> IO Bool
 211       checkDenial rev name
 212           = do fs <- getRepositoryFS repos
 213                withRevision fs rev
 214                    $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
 215                         case prop of
 216                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
 217                           Nothing -> return False
 218
 219       renamePage :: RevNum -> PageName -> PageName -> Txn ()
 220       renamePage oldRev oldName newName
 221           = do let oldPath = mkPagePath oldName
 222                    newPath = mkPagePath newName
 223                createParentDirectories newPath
 224                copyEntry oldRev oldPath newPath
 225                deleteEntry oldPath
 226                deleteEmptyParentDirectories oldPath
 227
 228       createPage :: PageName -> Txn ()
 229       createPage name
 230           = do let path = mkPagePath name
 231                createParentDirectories path
 232                makeFile path
 233
 234       updatePage :: PageName -> Txn ()
 235       updatePage name
 236           | isRedirect page = updatePageRedirect name
 237           | isEntity   page = updatePageEntity name
 238           | otherwise       = fail "neither redirection nor page"
 239
 240       updatePageRedirect :: PageName -> Txn ()
 241       updatePageRedirect name
 242           = do let path = mkPagePath name
 243                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
 244                setNodeProp path "rakka:lang"      Nothing
 245                setNodeProp path "rakka:isTheme"   Nothing
 246                setNodeProp path "rakka:isFeed"    Nothing
 247                setNodeProp path "rakka:isLocked"  Nothing
 248                setNodeProp path "rakka:isBinary"  Nothing
 249                setNodeProp path "rakka:summary"   Nothing
 250                setNodeProp path "rakka:otherLang" Nothing
 251                applyText path Nothing (encodeString (redirDest page) ++ "\n")
 252
 253       updatePageEntity :: PageName -> Txn ()
 254       updatePageEntity name
 255           = do let path = mkPagePath name
 256                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
 257                setNodeProp path "rakka:lang"      (entityLanguage page)
 258                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
 259                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
 260                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
 261                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
 262                setNodeProp path "rakka:summary"   (entitySummary page)
 263                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
 264                                                    in
 265                                                      if M.null otherLang then
 266                                                          Nothing
 267                                                      else
 268                                                          Just (serializeStringPairs $ M.toList otherLang))
 269                applyTextLBS path Nothing (entityContent page)
 270
 271       encodeFlag :: Bool -> Maybe String
 272       encodeFlag True  = Just "*"
 273       encodeFlag False = Nothing
 274
 275
 276 createParentDirectories :: FilePath -> Txn ()
 277 createParentDirectories path
 278     = do let parentPath = takeDirectory path
 279          kind <- checkPath parentPath
 280          case kind of
 281            NoNode   -> do createParentDirectories parentPath
 282                           makeDirectory parentPath
 283            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
 284            DirNode  -> return ()
 285
 286
 287 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 288 deletePageFromRepository repos userID name
 289     = filterSvnError $
 290       do let path = mkPagePath name
 291          fs     <- getRepositoryFS repos
 292          rev    <- getYoungestRev fs
 293          status <- withRevision fs rev
 294                    $ do exists <- isFile path
 295                         if exists then
 296                             do prop <- getNodeProp path "rakka:isLocked"
 297                                return $ case prop of
 298                                           Just _
 299                                               -> if isNothing userID then
 300                                                      -- 施錠されてゐるので匿名では駄目
 301                                                      Forbidden
 302                                                  else
 303                                                      NoContent
 304                                           Nothing
 305                                               -> NoContent
 306                           else
 307                             return NotFound
 308          when (status == NoContent)
 309              $ do doReposTxn repos
 310                              rev
 311                              "[Rakka]"
 312                              (Just "Automatic commit by Rakka for page deleting")
 313                              $ do deleteEntry path
 314                                   deleteEmptyParentDirectories path
 315                   return ()
 316          return status
 317
 318
 319 deleteEmptyParentDirectories :: FilePath -> Txn ()
 320 deleteEmptyParentDirectories path
 321     = do let parentPath = takeDirectory path
 322          contents <- getDirEntries parentPath
 323          when (null contents)
 324                   $ do deleteEntry parentPath
 325                        deleteEmptyParentDirectories parentPath
 326
 327
 328 filterSvnError :: IO a -> IO a
 329 filterSvnError f = catchDyn f rethrow
 330     where
 331       rethrow :: SvnError -> IO a
 332       rethrow err
 333           = let code = svnErrCode err
 334                 msg  = svnErrMsg  err
 335             in
 336               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg