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 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
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' = liftM (map entToName) (getDirEntries path)
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 $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
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 liftM (fromJust . parseW3CDateTime . chomp . fromJust)
168 (getRevisionProp' fs pageRev "svn:date")
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 liftM (fromJust . parseW3CDateTime . chomp . fromJust)
203 (getRevisionProp' fs pageRev "svn:date")
205 isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
210 , redirIsLocked = isLocked
211 , redirRevision = pageRev
212 , redirLastMod = zonedTimeToUTC lastMod
213 , redirUpdateInfo = undefined
217 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
218 putPageIntoRepository repos userID page
220 do let name = pageName page
221 author = fromMaybe "[Rakka]" userID
222 case pageUpdateInfo page of
224 -> do let oldRev = uiOldRevision ui
225 denied <- case uiOldName ui of
226 Nothing -> checkDenial oldRev name
227 Just oldName -> checkDenial oldRev oldName
231 do rev <- if oldRev == 0 then
232 getRepositoryFS repos >>= getYoungestRev
239 (Just "Automatic commit by Rakka for page update")
243 Just oldName -> do exists <- isFile (mkPagePath oldName)
245 $ do movePage (uiOldRevision ui) oldName name
246 moveAttachments (uiOldRevision ui) oldName name
247 exists <- isFile (mkPagePath name)
252 Left _ -> return Conflict
253 Right _ -> return Created
255 -> do fs <- getRepositoryFS repos
256 rev <- getYoungestRev fs
261 (Just "Automatic commit by Rakka for page creation")
265 Left _ -> return Conflict
266 Right _ -> return Created
268 checkDenial :: RevNum -> PageName -> IO Bool
270 = do fs <- getRepositoryFS repos
272 $ do exists <- isFile (mkPagePath name)
274 do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
276 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
277 Nothing -> return False
279 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
281 movePage :: RevNum -> PageName -> PageName -> Txn ()
282 movePage oldRev oldName newName
283 = do let oldPath = mkPagePath oldName
284 newPath = mkPagePath newName
285 createParentDirectories newPath
286 copyEntry oldRev oldPath newPath
288 deleteEmptyParentDirectories oldPath
290 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
291 moveAttachments oldRev oldName newName
292 = do let oldPath = mkAttachmentDirPath oldName
293 newPath = mkAttachmentDirPath newName
294 createParentDirectories newPath
295 copyEntry oldRev oldPath newPath
297 deleteEmptyParentDirectories oldPath
299 createPage :: PageName -> Txn ()
301 = do let path = mkPagePath name
302 createParentDirectories path
305 updatePage :: PageName -> Txn ()
307 | isRedirect page = updatePageRedirect name
308 | isEntity page = updatePageEntity name
309 | otherwise = fail "neither redirection nor page"
311 updatePageRedirect :: PageName -> Txn ()
312 updatePageRedirect name
313 = do let path = mkPagePath name
314 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
315 setNodeProp path "rakka:lang" Nothing
316 setNodeProp path "rakka:isTheme" Nothing
317 setNodeProp path "rakka:isFeed" Nothing
318 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
319 setNodeProp path "rakka:isBinary" Nothing
320 setNodeProp path "rakka:summary" Nothing
321 setNodeProp path "rakka:otherLang" Nothing
322 applyText path Nothing (encodeString (redirDest page) ++ "\n")
324 updatePageEntity :: PageName -> Txn ()
325 updatePageEntity name
326 = do let path = mkPagePath name
327 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
328 setNodeProp path "rakka:lang" (entityLanguage page)
329 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
330 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
331 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
332 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
333 setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
334 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
336 if M.null otherLang then
339 Just (encodeString $ serializeStringPairs $ M.toList otherLang))
340 applyTextLBS path Nothing (entityContent page)
342 encodeFlag :: Bool -> Maybe String
343 encodeFlag True = Just "*"
344 encodeFlag False = Nothing
347 createParentDirectories :: FilePath -> Txn ()
348 createParentDirectories path
349 = do let parentPath = takeDirectory path
350 kind <- checkPath parentPath
352 NoNode -> do createParentDirectories parentPath
353 makeDirectory parentPath
354 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
358 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
359 deletePageFromRepository repos userID name
361 do let pagePath = mkPagePath name
362 attachmentPath = mkAttachmentDirPath name
363 fs <- getRepositoryFS repos
364 rev <- getYoungestRev fs
365 status <- withRevision fs rev
366 $ do exists <- isFile pagePath
368 do prop <- getNodeProp pagePath "rakka:isLocked"
369 return $ case prop of
371 -> if isNothing userID then
380 when (status == NoContent)
381 $ do doReposTxn repos
384 (Just "Automatic commit by Rakka for page deleting")
385 $ do deleteEntry pagePath
386 deleteEmptyParentDirectories pagePath
388 attachmentExists <- isDirectory attachmentPath
389 when attachmentExists
390 $ do deleteEntry attachmentPath
391 deleteEmptyParentDirectories attachmentPath
396 deleteEmptyParentDirectories :: FilePath -> Txn ()
397 deleteEmptyParentDirectories path
398 = do let parentPath = takeDirectory path
399 contents <- getDirEntries parentPath
401 $ do deleteEntry parentPath
402 deleteEmptyParentDirectories parentPath
405 loadAttachmentInRepository :: forall a. Attachment a =>
411 loadAttachmentInRepository repos pName aName rev
412 = do fs <- getRepositoryFS repos
414 Nothing -> getYoungestRev fs
417 $ do exists <- isFile path
419 return . Just =<< loadAttachment'
424 path = mkAttachmentPath pName aName
426 loadAttachment' :: Rev a
427 loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
430 putAttachmentIntoRepository :: Attachment a =>
438 putAttachmentIntoRepository repos userID oldRev pName aName attachment
440 do let author = fromMaybe "[Rakka]" userID
441 path = mkAttachmentPath pName aName
442 fs <- getRepositoryFS repos
443 oldRev' <- case oldRev of
444 Nothing -> getYoungestRev fs
450 (Just "Automatic commit by Rakka for putting attachment")
451 $ do exists <- isFile path
453 $ do createParentDirectories path
455 applyText path Nothing (serializeToString attachment)
457 Left _ -> return Conflict
458 Right _ -> return NoContent
461 filterSvnError :: IO a -> IO a
462 filterSvnError f = catchDyn f rethrow
464 rethrow :: SvnError -> IO a
466 = let code = svnErrCode err
469 fail $ "SvnError: " ++ show code ++ ": " ++ msg