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' fs
144 path = mkPagePath name
146 loadPage' :: FileSystem -> Rev Page
148 = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
150 Just (MIMEType "application" "x-rakka-redirection" _)
151 -> loadPageRedirect fs
155 loadPageEntity :: FileSystem -> Rev Page
157 = do props <- getNodePropList path
158 hist <- getNodeHistory True path
159 content <- getFileContentsLBS path
161 let pageRev = fst $ head hist
163 $ fromMaybe "text/x-rakka"
164 $ fmap chomp (lookup "svn:mime-type" props)
166 lastMod <- unsafeIOToFS $
167 getRevisionProp' fs pageRev "svn:date"
168 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
172 , entityType = mimeType
173 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
174 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
175 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
176 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
177 , entityIsBinary = case mimeType of
179 -> any ((== "rakka:isBinary") . fst) props
182 , entityRevision = pageRev
183 , entityLastMod = zonedTimeToUTC lastMod
184 , entitySummary = fmap decodeString (lookup "rakka:summary" props)
185 , entityOtherLang = fromMaybe M.empty
187 (M.fromList . fromJust . deserializeStringPairs . decodeString)
188 (lookup "rakka:otherLang" props)
189 , entityContent = content
190 , entityUpdateInfo = undefined
193 loadPageRedirect :: FileSystem -> Rev Page
195 = do hist <- getNodeHistory True path
196 content <- getFileContents path
198 let pageRev = fst $ head hist
199 dest = chomp $ decodeString content
201 lastMod <- unsafeIOToFS $
202 getRevisionProp' fs pageRev "svn:date"
203 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
205 isLocked <- getNodeProp path "rakka:isLocked"
211 , redirIsLocked = isLocked
212 , redirRevision = pageRev
213 , redirLastMod = zonedTimeToUTC lastMod
214 , redirUpdateInfo = undefined
218 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
219 putPageIntoRepository repos userID page
221 do let name = pageName page
222 author = fromMaybe "[Rakka]" userID
223 case pageUpdateInfo page of
225 -> do let oldRev = uiOldRevision ui
226 denied <- case uiOldName ui of
227 Nothing -> checkDenial oldRev name
228 Just oldName -> checkDenial oldRev oldName
232 do rev <- if oldRev == 0 then
233 getRepositoryFS repos >>= getYoungestRev
240 (Just "Automatic commit by Rakka for page update")
244 Just oldName -> do exists <- isFile (mkPagePath oldName)
246 $ do movePage (uiOldRevision ui) oldName name
247 moveAttachments (uiOldRevision ui) oldName name
248 exists <- isFile (mkPagePath name)
253 Left _ -> return Conflict
254 Right _ -> return Created
256 -> do fs <- getRepositoryFS repos
257 rev <- getYoungestRev fs
262 (Just "Automatic commit by Rakka for page creation")
266 Left _ -> return Conflict
267 Right _ -> return Created
269 checkDenial :: RevNum -> PageName -> IO Bool
271 = do fs <- getRepositoryFS repos
273 $ do exists <- isFile (mkPagePath name)
275 do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
277 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
278 Nothing -> return False
280 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
282 movePage :: RevNum -> PageName -> PageName -> Txn ()
283 movePage oldRev oldName newName
284 = do let oldPath = mkPagePath oldName
285 newPath = mkPagePath newName
286 createParentDirectories newPath
287 copyEntry oldRev oldPath newPath
289 deleteEmptyParentDirectories oldPath
291 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
292 moveAttachments oldRev oldName newName
293 = do let oldPath = mkAttachmentDirPath oldName
294 newPath = mkAttachmentDirPath newName
295 createParentDirectories newPath
296 copyEntry oldRev oldPath newPath
298 deleteEmptyParentDirectories oldPath
300 createPage :: PageName -> Txn ()
302 = do let path = mkPagePath name
303 createParentDirectories path
306 updatePage :: PageName -> Txn ()
308 | isRedirect page = updatePageRedirect name
309 | isEntity page = updatePageEntity name
310 | otherwise = fail "neither redirection nor page"
312 updatePageRedirect :: PageName -> Txn ()
313 updatePageRedirect name
314 = do let path = mkPagePath name
315 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
316 setNodeProp path "rakka:lang" Nothing
317 setNodeProp path "rakka:isTheme" Nothing
318 setNodeProp path "rakka:isFeed" Nothing
319 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
320 setNodeProp path "rakka:isBinary" Nothing
321 setNodeProp path "rakka:summary" Nothing
322 setNodeProp path "rakka:otherLang" Nothing
323 applyText path Nothing (encodeString (redirDest page) ++ "\n")
325 updatePageEntity :: PageName -> Txn ()
326 updatePageEntity name
327 = do let path = mkPagePath name
328 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
329 setNodeProp path "rakka:lang" (entityLanguage page)
330 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
331 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
332 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
333 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
334 setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
335 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
337 if M.null otherLang then
340 Just (encodeString $ serializeStringPairs $ M.toList otherLang))
341 applyTextLBS path Nothing (entityContent page)
343 encodeFlag :: Bool -> Maybe String
344 encodeFlag True = Just "*"
345 encodeFlag False = Nothing
348 createParentDirectories :: FilePath -> Txn ()
349 createParentDirectories path
350 = do let parentPath = takeDirectory path
351 kind <- checkPath parentPath
353 NoNode -> do createParentDirectories parentPath
354 makeDirectory parentPath
355 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
359 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
360 deletePageFromRepository repos userID name
362 do let pagePath = mkPagePath name
363 attachmentPath = mkAttachmentDirPath name
364 fs <- getRepositoryFS repos
365 rev <- getYoungestRev fs
366 status <- withRevision fs rev
367 $ do exists <- isFile pagePath
369 do prop <- getNodeProp pagePath "rakka:isLocked"
370 return $ case prop of
372 -> if isNothing userID then
381 when (status == NoContent)
382 $ do doReposTxn repos
385 (Just "Automatic commit by Rakka for page deleting")
386 $ do deleteEntry pagePath
387 deleteEmptyParentDirectories pagePath
389 attachmentExists <- isDirectory attachmentPath
390 when attachmentExists
391 $ do deleteEntry attachmentPath
392 deleteEmptyParentDirectories attachmentPath
397 deleteEmptyParentDirectories :: FilePath -> Txn ()
398 deleteEmptyParentDirectories path
399 = do let parentPath = takeDirectory path
400 contents <- getDirEntries parentPath
402 $ do deleteEntry parentPath
403 deleteEmptyParentDirectories parentPath
406 loadAttachmentInRepository :: forall a. Attachment a =>
412 loadAttachmentInRepository repos pName aName rev
413 = do fs <- getRepositoryFS repos
415 Nothing -> getYoungestRev fs
418 $ do exists <- isFile path
420 return . Just =<< loadAttachment'
425 path = mkAttachmentPath pName aName
427 loadAttachment' :: Rev a
428 loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
431 putAttachmentIntoRepository :: Attachment a =>
439 putAttachmentIntoRepository repos userID oldRev pName aName attachment
441 do let author = fromMaybe "[Rakka]" userID
442 path = mkAttachmentPath pName aName
443 fs <- getRepositoryFS repos
444 oldRev' <- case oldRev of
445 Nothing -> getYoungestRev fs
451 (Just "Automatic commit by Rakka for putting attachment")
452 $ do exists <- isFile path
454 $ do createParentDirectories path
456 applyText path Nothing (serializeToString attachment)
458 Left _ -> return Conflict
459 Right _ -> return NoContent
462 filterSvnError :: IO a -> IO a
463 filterSvnError f = catchDyn f rethrow
465 rethrow :: SvnError -> IO a
467 = let code = svnErrCode err
470 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg