1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , getDirContentsInRevision
4 , findChangedPagesAtRevision
6 , putPageIntoRepository
7 , deletePageFromRepository
8 , loadAttachmentInRepository
9 , putAttachmentIntoRepository
13 import Codec.Binary.UTF8.String
14 import Control.Exception
17 import qualified Data.Map as M
20 import qualified Data.Set as S hiding (Set)
22 import Network.HTTP.Lucu hiding (redirect)
23 import Rakka.Attachment
25 import Rakka.SystemConfig
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
39 mkPagePath :: PageName -> FilePath
41 = "/pages" </> encodePageName name <.> "page"
44 mkDirPath :: PageName -> FilePath
46 = "/pages" </> encodePageName dir
49 mkAttachmentPath :: PageName -> String -> FilePath
50 mkAttachmentPath pName aName
51 = "/attachments" </> encodePageName pName <.> "page" </> aName
54 mkAttachmentDirPath :: PageName -> FilePath
55 mkAttachmentDirPath pName
56 = "/attachments" </> encodePageName pName <.> "page"
59 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
60 findAllPagesInRevision repos rev
61 = do fs <- getRepositoryFS repos
63 $ do exists <- isDirectory root
72 traverse :: FilePath -> Rev (Set PageName)
74 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
76 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
78 = let path = dir </> entName entry
80 do kind <- checkPath path
82 NoNode -> return S.empty
83 FileNode -> return $ S.singleton (decodePath path)
84 DirNode -> traverse path
86 decodePath :: FilePath -> PageName
87 decodePath = decodePageName . makeRelative root . dropExtension
90 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
91 getDirContentsInRevision repos dir rev
92 = do fs <- getRepositoryFS repos
94 Nothing -> getYoungestRev fs
97 $ do exists <- isDirectory path
99 return . S.fromList =<< getDir'
106 getDir' :: Rev [PageName]
107 getDir' = getDirEntries path >>= return . map entToName
109 entToName :: DirEntry -> PageName
110 entToName = (dir </>) . decodePageName . dropExtension . entName
113 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
114 findChangedPagesAtRevision repos rev
115 = do fs <- getRepositoryFS repos
117 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
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
130 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
131 loadPageInRepository repos name rev
132 = do fs <- getRepositoryFS repos
134 Nothing -> getYoungestRev fs
137 $ do exists <- isFile path
139 return . Just =<< loadPage'
144 path = mkPagePath name
146 loadPage' :: Rev Page
147 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
149 Just (MIMEType "application" "x-rakka-redirection" _)
154 loadPageEntity :: Rev Page
156 = do props <- getNodePropList path
157 hist <- getNodeHistory True path
158 content <- getFileContentsLBS path
160 let pageRev = fst $ head hist
162 $ fromMaybe "text/x-rakka"
163 $ fmap chomp (lookup "svn:mime-type" props)
165 lastMod <- getRevisionProp "svn:date"
166 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
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
177 -> any ((== "rakka:isBinary") . fst) props
180 , entityRevision = pageRev
181 , entityLastMod = zonedTimeToUTC lastMod
182 , entitySummary = fmap decodeString (lookup "rakka:summary" props)
183 , entityOtherLang = fromMaybe M.empty
185 (M.fromList . fromJust . deserializeStringPairs . decodeString)
186 (lookup "rakka:otherLang" props)
187 , entityContent = content
188 , entityUpdateInfo = undefined
191 loadPageRedirect :: Rev Page
193 = do hist <- getNodeHistory True path
194 content <- getFileContents path
196 let pageRev = fst $ head hist
197 dest = chomp $ decodeString content
199 lastMod <- getRevisionProp "svn:date"
200 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
202 isLocked <- getRevisionProp "rakka:isLocked"
208 , redirIsLocked = isLocked
209 , redirRevision = pageRev
210 , redirLastMod = zonedTimeToUTC lastMod
211 , redirUpdateInfo = undefined
215 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
216 putPageIntoRepository repos userID page
218 do let name = pageName page
219 author = fromMaybe "[Rakka]" userID
220 case pageUpdateInfo page of
222 -> do let oldRev = uiOldRevision ui
223 denied <- case uiOldName ui of
224 Nothing -> checkDenial oldRev name
225 Just oldName -> checkDenial oldRev oldName
229 do rev <- if oldRev == 0 then
230 getRepositoryFS repos >>= getYoungestRev
237 (Just "Automatic commit by Rakka for page update")
241 Just oldName -> do exists <- isFile (mkPagePath oldName)
243 $ do movePage (uiOldRevision ui) oldName name
244 moveAttachments (uiOldRevision ui) oldName name
245 exists <- isFile (mkPagePath name)
250 Left _ -> return Conflict
251 Right _ -> return Created
253 -> do fs <- getRepositoryFS repos
254 rev <- getYoungestRev fs
259 (Just "Automatic commit by Rakka for page creation")
263 Left _ -> return Conflict
264 Right _ -> return Created
266 checkDenial :: RevNum -> PageName -> IO Bool
268 = do fs <- getRepositoryFS repos
270 $ do exists <- isFile (mkPagePath name)
272 do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
274 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
275 Nothing -> return False
277 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
279 movePage :: RevNum -> PageName -> PageName -> Txn ()
280 movePage oldRev oldName newName
281 = do let oldPath = mkPagePath oldName
282 newPath = mkPagePath newName
283 createParentDirectories newPath
284 copyEntry oldRev oldPath newPath
286 deleteEmptyParentDirectories oldPath
288 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
289 moveAttachments oldRev oldName newName
290 = do let oldPath = mkAttachmentDirPath oldName
291 newPath = mkAttachmentDirPath newName
292 createParentDirectories newPath
293 copyEntry oldRev oldPath newPath
295 deleteEmptyParentDirectories oldPath
297 createPage :: PageName -> Txn ()
299 = do let path = mkPagePath name
300 createParentDirectories path
303 updatePage :: PageName -> Txn ()
305 | isRedirect page = updatePageRedirect name
306 | isEntity page = updatePageEntity name
307 | otherwise = fail "neither redirection nor page"
309 updatePageRedirect :: PageName -> Txn ()
310 updatePageRedirect name
311 = do let path = mkPagePath name
312 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
313 setNodeProp path "rakka:lang" Nothing
314 setNodeProp path "rakka:isTheme" Nothing
315 setNodeProp path "rakka:isFeed" Nothing
316 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
317 setNodeProp path "rakka:isBinary" Nothing
318 setNodeProp path "rakka:summary" Nothing
319 setNodeProp path "rakka:otherLang" Nothing
320 applyText path Nothing (encodeString (redirDest page) ++ "\n")
322 updatePageEntity :: PageName -> Txn ()
323 updatePageEntity name
324 = do let path = mkPagePath name
325 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
326 setNodeProp path "rakka:lang" (entityLanguage page)
327 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
328 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
329 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
330 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
331 setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
332 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
334 if M.null otherLang then
337 Just (encodeString $ serializeStringPairs $ M.toList otherLang))
338 applyTextLBS path Nothing (entityContent page)
340 encodeFlag :: Bool -> Maybe String
341 encodeFlag True = Just "*"
342 encodeFlag False = Nothing
345 createParentDirectories :: FilePath -> Txn ()
346 createParentDirectories path
347 = do let parentPath = takeDirectory path
348 kind <- checkPath parentPath
350 NoNode -> do createParentDirectories parentPath
351 makeDirectory parentPath
352 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
356 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
357 deletePageFromRepository repos userID name
359 do let pagePath = mkPagePath name
360 attachmentPath = mkAttachmentDirPath name
361 fs <- getRepositoryFS repos
362 rev <- getYoungestRev fs
363 status <- withRevision fs rev
364 $ do exists <- isFile pagePath
366 do prop <- getNodeProp pagePath "rakka:isLocked"
367 return $ case prop of
369 -> if isNothing userID then
378 when (status == NoContent)
379 $ do doReposTxn repos
382 (Just "Automatic commit by Rakka for page deleting")
383 $ do deleteEntry pagePath
384 deleteEmptyParentDirectories pagePath
386 attachmentExists <- isDirectory attachmentPath
387 when attachmentExists
388 $ do deleteEntry attachmentPath
389 deleteEmptyParentDirectories attachmentPath
394 deleteEmptyParentDirectories :: FilePath -> Txn ()
395 deleteEmptyParentDirectories path
396 = do let parentPath = takeDirectory path
397 contents <- getDirEntries parentPath
399 $ do deleteEntry parentPath
400 deleteEmptyParentDirectories parentPath
403 loadAttachmentInRepository :: forall a. Attachment a =>
409 loadAttachmentInRepository repos pName aName rev
410 = do fs <- getRepositoryFS repos
412 Nothing -> getYoungestRev fs
415 $ do exists <- isFile path
417 return . Just =<< loadAttachment'
422 path = mkAttachmentPath pName aName
424 loadAttachment' :: Rev a
425 loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
428 putAttachmentIntoRepository :: Attachment a =>
436 putAttachmentIntoRepository repos userID oldRev pName aName attachment
438 do let author = fromMaybe "[Rakka]" userID
439 path = mkAttachmentPath pName aName
440 fs <- getRepositoryFS repos
441 oldRev' <- case oldRev of
442 Nothing -> getYoungestRev fs
448 (Just "Automatic commit by Rakka for putting attachment")
449 $ do exists <- isFile path
451 $ do createParentDirectories path
453 applyText path Nothing (serializeToString attachment)
455 Left _ -> return Conflict
456 Right _ -> return NoContent
459 filterSvnError :: IO a -> IO a
460 filterSvnError f = catchDyn f rethrow
462 rethrow :: SvnError -> IO a
464 = let code = svnErrCode err
467 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg