1 -- -*- coding: utf-8 -*-
2 module Rakka.Storage.Repos
3 ( findAllPagesInRevision
4 , getDirContentsInRevision
5 , findChangedPagesAtRevision
7 , putPageIntoRepository
8 , deletePageFromRepository
9 , loadAttachmentInRepository
10 , putAttachmentIntoRepository
14 import Codec.Binary.UTF8.String
17 import qualified Data.Map as M
20 import qualified Data.Set as S hiding (Set)
22 import qualified Data.Time.W3C as W3C
23 import Network.HTTP.Lucu hiding (redirect)
24 import Rakka.Attachment
26 import Rakka.SystemConfig
28 import Subversion.FileSystem
29 import Subversion.FileSystem.DirEntry
30 import Subversion.FileSystem.Revision
31 import Subversion.FileSystem.Root
32 import Subversion.FileSystem.Transaction
33 import Subversion.Repository
34 import Subversion.Types
35 import System.FilePath.Posix
38 mkPagePath :: PageName -> FilePath
40 = "/pages" </> encodePageName name <.> "page"
43 mkDirPath :: PageName -> FilePath
45 = "/pages" </> encodePageName dir
48 mkAttachmentPath :: PageName -> String -> FilePath
49 mkAttachmentPath pName aName
50 = "/attachments" </> encodePageName pName <.> "page" </> aName
53 mkAttachmentDirPath :: PageName -> FilePath
54 mkAttachmentDirPath pName
55 = "/attachments" </> encodePageName pName <.> "page"
58 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
59 findAllPagesInRevision repos rev
60 = do fs <- getRepositoryFS repos
62 $ do exists <- isDirectory root
71 traverse :: FilePath -> Rev (Set PageName)
73 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
75 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
77 = let path = dir </> entName entry
79 do kind <- checkPath path
81 NoNode -> return S.empty
82 FileNode -> return $ S.singleton (decodePath path)
83 DirNode -> traverse path
85 decodePath :: FilePath -> PageName
86 decodePath = decodePageName . makeRelative root . dropExtension
89 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
90 getDirContentsInRevision repos dir rev
91 = do fs <- getRepositoryFS repos
93 Nothing -> getYoungestRev fs
96 $ do exists <- isDirectory path
98 return . S.fromList =<< getDir'
105 getDir' :: Rev [PageName]
106 getDir' = liftM (map entToName) (getDirEntries path)
108 entToName :: DirEntry -> PageName
109 entToName = (dir </>) . decodePageName . dropExtension . entName
112 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
113 findChangedPagesAtRevision repos rev
114 = do fs <- getRepositoryFS repos
116 $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
118 accumulatePages :: Set PageName -> FilePath -> Set PageName
119 accumulatePages s path
120 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
121 = let encoded = makeRelative "/pages" $ dropExtension path
122 name = decodePageName encoded
129 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
130 loadPageInRepository repos name rev
131 = do fs <- getRepositoryFS repos
133 Nothing -> getYoungestRev fs
136 $ do exists <- isFile path
138 return . Just =<< loadPage' fs
143 path = mkPagePath name
145 loadPage' :: FileSystem -> Rev Page
147 = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
149 Just (MIMEType "application" "x-rakka-redirection" _)
150 -> loadPageRedirect fs
154 loadPageEntity :: FileSystem -> 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 <- unsafeIOToFS $
166 liftM (fromJust . W3C.parse . chomp . fromJust)
167 (getRevisionProp' fs pageRev "svn:date")
171 , entityType = mimeType
172 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
173 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
174 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
175 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
176 , entityIsBinary = case mimeType of
178 -> any ((== "rakka:isBinary") . fst) props
181 , entityRevision = pageRev
182 , entityLastMod = zonedTimeToUTC lastMod
183 , entitySummary = fmap decodeString (lookup "rakka:summary" props)
184 , entityOtherLang = fromMaybe M.empty
186 (M.fromList . fromJust . deserializeStringPairs . decodeString)
187 (lookup "rakka:otherLang" props)
188 , entityContent = content
189 , entityUpdateInfo = undefined
192 loadPageRedirect :: FileSystem -> Rev Page
194 = do hist <- getNodeHistory True path
195 content <- getFileContents path
197 let pageRev = fst $ head hist
198 dest = chomp $ decodeString content
200 lastMod <- unsafeIOToFS $
201 liftM (fromJust . W3C.parse . chomp . fromJust)
202 (getRevisionProp' fs pageRev "svn:date")
204 isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
209 , redirIsLocked = isLocked
210 , redirRevision = pageRev
211 , redirLastMod = zonedTimeToUTC lastMod
212 , redirUpdateInfo = undefined
216 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
217 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
358 = do let pagePath = mkPagePath name
359 attachmentPath = mkAttachmentDirPath name
360 fs <- getRepositoryFS repos
361 rev <- getYoungestRev fs
362 status <- withRevision fs rev
363 $ do exists <- isFile pagePath
365 do prop <- getNodeProp pagePath "rakka:isLocked"
366 return $ case prop of
368 -> if isNothing userID then
377 when (status == NoContent)
378 $ ( (doReposTxn repos
381 (Just "Automatic commit by Rakka for page deleting")
382 $ do deleteEntry pagePath
383 deleteEmptyParentDirectories pagePath
385 attachmentExists <- isDirectory attachmentPath
386 when attachmentExists
387 $ do deleteEntry attachmentPath
388 deleteEmptyParentDirectories attachmentPath)
393 deleteEmptyParentDirectories :: FilePath -> Txn ()
394 deleteEmptyParentDirectories path
395 = do let parentPath = takeDirectory path
396 contents <- getDirEntries parentPath
398 $ do deleteEntry parentPath
399 deleteEmptyParentDirectories parentPath
402 loadAttachmentInRepository :: forall a. Attachment a =>
408 loadAttachmentInRepository repos pName aName rev
409 = do fs <- getRepositoryFS repos
411 Nothing -> getYoungestRev fs
414 $ do exists <- isFile path
416 return . Just =<< loadAttachment'
421 path = mkAttachmentPath pName aName
423 loadAttachment' :: Rev a
424 loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
427 putAttachmentIntoRepository :: Attachment a =>
435 putAttachmentIntoRepository repos userID oldRev pName aName attachment
436 = do let author = fromMaybe "[Rakka]" userID
437 path = mkAttachmentPath pName aName
438 fs <- getRepositoryFS repos
439 oldRev' <- case oldRev of
440 Nothing -> getYoungestRev fs
446 (Just "Automatic commit by Rakka for putting attachment")
447 $ do exists <- isFile path
449 $ do createParentDirectories path
451 applyText path Nothing (encodeString $ serializeToString attachment)
453 Left _ -> return Conflict
454 Right _ -> return NoContent