1 -- -*- coding: utf-8 -*-
2 module Rakka.Storage.Repos
3 ( findAllPagesInRevision
4 , getDirContentsInRevision
5 , findChangedPagesAtRevision
7 , putPageIntoRepository
8 , deletePageFromRepository
9 , loadAttachmentInRepository
10 , putAttachmentIntoRepository
15 import qualified Data.Map as M
18 import qualified Data.Set as S hiding (Set)
20 import qualified Data.Time.W3C as W3C
21 import Network.HTTP.Lucu hiding (redirect)
22 import Rakka.Attachment
24 import Rakka.SystemConfig
26 import Subversion.FileSystem
27 import Subversion.FileSystem.DirEntry
28 import Subversion.FileSystem.Revision
29 import Subversion.FileSystem.Root
30 import Subversion.FileSystem.Transaction
31 import Subversion.Repository
32 import Subversion.Types
33 import System.FilePath.Posix
36 mkPagePath :: PageName -> FilePath
38 = "/pages" </> encodePageName name <.> "page"
41 mkDirPath :: PageName -> FilePath
43 = "/pages" </> encodePageName dir
46 mkAttachmentPath :: PageName -> String -> FilePath
47 mkAttachmentPath pName aName
48 = "/attachments" </> encodePageName pName <.> "page" </> aName
51 mkAttachmentDirPath :: PageName -> FilePath
52 mkAttachmentDirPath pName
53 = "/attachments" </> encodePageName pName <.> "page"
56 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
57 findAllPagesInRevision repos rev
58 = do fs <- getRepositoryFS repos
60 $ do exists <- isDirectory root
69 traverse :: FilePath -> Rev (Set PageName)
71 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
73 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
75 = let path = dir </> entName entry
77 do kind <- checkPath path
79 NoNode -> return S.empty
80 FileNode -> return $ S.singleton (decodePath path)
81 DirNode -> traverse path
83 decodePath :: FilePath -> PageName
84 decodePath = decodePageName . makeRelative root . dropExtension
87 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
88 getDirContentsInRevision repos dir rev
89 = do fs <- getRepositoryFS repos
91 Nothing -> getYoungestRev fs
94 $ do exists <- isDirectory path
96 return . S.fromList =<< getDir'
103 getDir' :: Rev [PageName]
104 getDir' = liftM (map entToName) (getDirEntries path)
106 entToName :: DirEntry -> PageName
107 entToName = (dir </>) . decodePageName . dropExtension . entName
110 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
111 findChangedPagesAtRevision repos rev
112 = do fs <- getRepositoryFS repos
114 $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
116 accumulatePages :: Set PageName -> FilePath -> Set PageName
117 accumulatePages s path
118 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
119 = let encoded = makeRelative "/pages" $ dropExtension path
120 name = decodePageName encoded
127 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
128 loadPageInRepository repos name rev
129 = do fs <- getRepositoryFS repos
131 Nothing -> getYoungestRev fs
134 $ do exists <- isFile path
136 return . Just =<< loadPage' fs
141 path = mkPagePath name
143 loadPage' :: FileSystem -> Rev Page
145 = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
147 Just (MIMEType "application" "x-rakka-redirection" _)
148 -> loadPageRedirect fs
152 loadPageEntity :: FileSystem -> Rev Page
154 = do props <- getNodePropList path
155 hist <- getNodeHistory True path
156 content <- getFileContentsLBS path
158 let pageRev = fst $ head hist
160 $ fromMaybe "text/x-rakka"
161 $ fmap chomp (lookup "svn:mime-type" props)
163 lastMod <- unsafeIOToFS $
164 liftM (fromJust . W3C.parse . chomp . fromJust)
165 (getRevisionProp' fs pageRev "svn:date")
169 , entityType = mimeType
170 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
171 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
172 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
173 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
174 , entityIsBinary = case mimeType of
176 -> any ((== "rakka:isBinary") . fst) props
179 , entityRevision = pageRev
180 , entityLastMod = zonedTimeToUTC lastMod
181 , entitySummary = fmap decodeString (lookup "rakka:summary" props)
182 , entityOtherLang = fromMaybe M.empty
184 (M.fromList . fromJust . deserializeStringPairs . decodeString)
185 (lookup "rakka:otherLang" props)
186 , entityContent = content
187 , entityUpdateInfo = undefined
190 loadPageRedirect :: FileSystem -> Rev Page
192 = do hist <- getNodeHistory True path
193 content <- getFileContents path
195 let pageRev = fst $ head hist
196 dest = chomp $ decodeString content
198 lastMod <- unsafeIOToFS $
199 liftM (fromJust . W3C.parse . chomp . fromJust)
200 (getRevisionProp' fs pageRev "svn:date")
202 isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
207 , redirIsLocked = isLocked
208 , redirRevision = pageRev
209 , redirLastMod = zonedTimeToUTC lastMod
210 , redirUpdateInfo = undefined
214 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
215 putPageIntoRepository repos userID page
216 = do let name = pageName page
217 author = fromMaybe "[Rakka]" userID
218 case pageUpdateInfo page of
220 -> do let oldRev = uiOldRevision ui
221 denied <- case uiOldName ui of
222 Nothing -> checkDenial oldRev name
223 Just oldName -> checkDenial oldRev oldName
227 do rev <- if oldRev == 0 then
228 getRepositoryFS repos >>= getYoungestRev
235 (Just "Automatic commit by Rakka for page update")
239 Just oldName -> do exists <- isFile (mkPagePath oldName)
241 $ do movePage (uiOldRevision ui) oldName name
242 moveAttachments (uiOldRevision ui) oldName name
243 exists <- isFile (mkPagePath name)
248 Left _ -> return Conflict
249 Right _ -> return Created
251 -> do fs <- getRepositoryFS repos
252 rev <- getYoungestRev fs
257 (Just "Automatic commit by Rakka for page creation")
261 Left _ -> return Conflict
262 Right _ -> return Created
264 checkDenial :: RevNum -> PageName -> IO Bool
266 = do fs <- getRepositoryFS repos
268 $ do exists <- isFile (mkPagePath name)
270 do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
272 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
273 Nothing -> return False
275 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
277 movePage :: RevNum -> PageName -> PageName -> Txn ()
278 movePage oldRev oldName newName
279 = do let oldPath = mkPagePath oldName
280 newPath = mkPagePath newName
281 createParentDirectories newPath
282 copyEntry oldRev oldPath newPath
284 deleteEmptyParentDirectories oldPath
286 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
287 moveAttachments oldRev oldName newName
288 = do let oldPath = mkAttachmentDirPath oldName
289 newPath = mkAttachmentDirPath newName
290 createParentDirectories newPath
291 copyEntry oldRev oldPath newPath
293 deleteEmptyParentDirectories oldPath
295 createPage :: PageName -> Txn ()
297 = do let path = mkPagePath name
298 createParentDirectories path
301 updatePage :: PageName -> Txn ()
303 | isRedirect page = updatePageRedirect name
304 | isEntity page = updatePageEntity name
305 | otherwise = fail "neither redirection nor page"
307 updatePageRedirect :: PageName -> Txn ()
308 updatePageRedirect name
309 = do let path = mkPagePath name
310 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
311 setNodeProp path "rakka:lang" Nothing
312 setNodeProp path "rakka:isTheme" Nothing
313 setNodeProp path "rakka:isFeed" Nothing
314 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
315 setNodeProp path "rakka:isBinary" Nothing
316 setNodeProp path "rakka:summary" Nothing
317 setNodeProp path "rakka:otherLang" Nothing
318 applyText path Nothing (encodeString (redirDest page) ++ "\n")
320 updatePageEntity :: PageName -> Txn ()
321 updatePageEntity name
322 = do let path = mkPagePath name
323 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
324 setNodeProp path "rakka:lang" (entityLanguage page)
325 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
326 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
327 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
328 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
329 setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
330 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
332 if M.null otherLang then
335 Just (encodeString $ serializeStringPairs $ M.toList otherLang))
336 applyTextLBS path Nothing (entityContent page)
338 encodeFlag :: Bool -> Maybe String
339 encodeFlag True = Just "*"
340 encodeFlag False = Nothing
343 createParentDirectories :: FilePath -> Txn ()
344 createParentDirectories path
345 = do let parentPath = takeDirectory path
346 kind <- checkPath parentPath
348 NoNode -> do createParentDirectories parentPath
349 makeDirectory parentPath
350 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
354 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
355 deletePageFromRepository repos userID name
356 = do let pagePath = mkPagePath name
357 attachmentPath = mkAttachmentDirPath name
358 fs <- getRepositoryFS repos
359 rev <- getYoungestRev fs
360 status <- withRevision fs rev
361 $ do exists <- isFile pagePath
363 do prop <- getNodeProp pagePath "rakka:isLocked"
364 return $ case prop of
366 -> if isNothing userID then
375 when (status == NoContent)
376 $ ( (doReposTxn repos
379 (Just "Automatic commit by Rakka for page deleting")
380 $ do deleteEntry pagePath
381 deleteEmptyParentDirectories pagePath
383 attachmentExists <- isDirectory attachmentPath
384 when attachmentExists
385 $ do deleteEntry attachmentPath
386 deleteEmptyParentDirectories attachmentPath)
391 deleteEmptyParentDirectories :: FilePath -> Txn ()
392 deleteEmptyParentDirectories path
393 = do let parentPath = takeDirectory path
394 contents <- getDirEntries parentPath
396 $ do deleteEntry parentPath
397 deleteEmptyParentDirectories parentPath
400 loadAttachmentInRepository :: forall a. Attachment a =>
406 loadAttachmentInRepository repos pName aName rev
407 = do fs <- getRepositoryFS repos
409 Nothing -> getYoungestRev fs
412 $ do exists <- isFile path
414 return . Just =<< loadAttachment'
419 path = mkAttachmentPath pName aName
421 loadAttachment' :: Rev a
422 loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
425 putAttachmentIntoRepository :: Attachment a =>
433 putAttachmentIntoRepository repos userID oldRev pName aName attachment
434 = do let author = fromMaybe "[Rakka]" userID
435 path = mkAttachmentPath pName aName
436 fs <- getRepositoryFS repos
437 oldRev' <- case oldRev of
438 Nothing -> getYoungestRev fs
444 (Just "Automatic commit by Rakka for putting attachment")
445 $ do exists <- isFile path
447 $ do createParentDirectories path
449 applyText path Nothing (encodeString $ serializeToString attachment)
451 Left _ -> return Conflict
452 Right _ -> return NoContent