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
16 import qualified Data.Map as M
19 import qualified Data.Set as S hiding (Set)
21 import Network.HTTP.Lucu hiding (redirect)
22 import Rakka.Attachment
24 import Rakka.SystemConfig
26 import Rakka.W3CDateTime
27 import Subversion.FileSystem
28 import Subversion.FileSystem.DirEntry
29 import Subversion.FileSystem.Revision
30 import Subversion.FileSystem.Root
31 import Subversion.FileSystem.Transaction
32 import Subversion.Repository
33 import Subversion.Types
34 import System.FilePath.Posix
37 mkPagePath :: PageName -> FilePath
39 = "/pages" </> encodePageName name <.> "page"
42 mkDirPath :: PageName -> FilePath
44 = "/pages" </> encodePageName dir
47 mkAttachmentPath :: PageName -> String -> FilePath
48 mkAttachmentPath pName aName
49 = "/attachments" </> encodePageName pName <.> "page" </> aName
52 mkAttachmentDirPath :: PageName -> FilePath
53 mkAttachmentDirPath pName
54 = "/attachments" </> encodePageName pName <.> "page"
57 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
58 findAllPagesInRevision repos rev
59 = do fs <- getRepositoryFS repos
61 $ do exists <- isDirectory root
70 traverse :: FilePath -> Rev (Set PageName)
72 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
74 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
76 = let path = dir </> entName entry
78 do kind <- checkPath path
80 NoNode -> return S.empty
81 FileNode -> return $ S.singleton (decodePath path)
82 DirNode -> traverse path
84 decodePath :: FilePath -> PageName
85 decodePath = decodePageName . makeRelative root . dropExtension
88 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
89 getDirContentsInRevision repos dir rev
90 = do fs <- getRepositoryFS repos
92 Nothing -> getYoungestRev fs
95 $ do exists <- isDirectory path
97 return . S.fromList =<< getDir'
104 getDir' :: Rev [PageName]
105 getDir' = liftM (map entToName) (getDirEntries path)
107 entToName :: DirEntry -> PageName
108 entToName = (dir </>) . decodePageName . dropExtension . entName
111 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
112 findChangedPagesAtRevision repos rev
113 = do fs <- getRepositoryFS repos
115 $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
117 accumulatePages :: Set PageName -> FilePath -> Set PageName
118 accumulatePages s path
119 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
120 = let encoded = makeRelative "/pages" $ dropExtension path
121 name = decodePageName encoded
128 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
129 loadPageInRepository repos name rev
130 = do fs <- getRepositoryFS repos
132 Nothing -> getYoungestRev fs
135 $ do exists <- isFile path
137 return . Just =<< loadPage' fs
142 path = mkPagePath name
144 loadPage' :: FileSystem -> Rev Page
146 = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
148 Just (MIMEType "application" "x-rakka-redirection" _)
149 -> loadPageRedirect fs
153 loadPageEntity :: FileSystem -> Rev Page
155 = do props <- getNodePropList path
156 hist <- getNodeHistory True path
157 content <- getFileContentsLBS path
159 let pageRev = fst $ head hist
161 $ fromMaybe "text/x-rakka"
162 $ fmap chomp (lookup "svn:mime-type" props)
164 lastMod <- unsafeIOToFS $
165 liftM (fromJust . parseW3CDateTime . chomp . fromJust)
166 (getRevisionProp' fs pageRev "svn:date")
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 :: FileSystem -> 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 <- unsafeIOToFS $
200 liftM (fromJust . parseW3CDateTime . chomp . fromJust)
201 (getRevisionProp' fs pageRev "svn:date")
203 isLocked <- liftM isJust (getNodeProp path "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
217 = do let name = pageName page
218 author = fromMaybe "[Rakka]" userID
219 case pageUpdateInfo page of
221 -> do let oldRev = uiOldRevision ui
222 denied <- case uiOldName ui of
223 Nothing -> checkDenial oldRev name
224 Just oldName -> checkDenial oldRev oldName
228 do rev <- if oldRev == 0 then
229 getRepositoryFS repos >>= getYoungestRev
236 (Just "Automatic commit by Rakka for page update")
240 Just oldName -> do exists <- isFile (mkPagePath oldName)
242 $ do movePage (uiOldRevision ui) oldName name
243 moveAttachments (uiOldRevision ui) oldName name
244 exists <- isFile (mkPagePath name)
249 Left _ -> return Conflict
250 Right _ -> return Created
252 -> do fs <- getRepositoryFS repos
253 rev <- getYoungestRev fs
258 (Just "Automatic commit by Rakka for page creation")
262 Left _ -> return Conflict
263 Right _ -> return Created
265 checkDenial :: RevNum -> PageName -> IO Bool
267 = do fs <- getRepositoryFS repos
269 $ do exists <- isFile (mkPagePath name)
271 do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
273 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
274 Nothing -> return False
276 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
278 movePage :: RevNum -> PageName -> PageName -> Txn ()
279 movePage oldRev oldName newName
280 = do let oldPath = mkPagePath oldName
281 newPath = mkPagePath newName
282 createParentDirectories newPath
283 copyEntry oldRev oldPath newPath
285 deleteEmptyParentDirectories oldPath
287 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
288 moveAttachments oldRev oldName newName
289 = do let oldPath = mkAttachmentDirPath oldName
290 newPath = mkAttachmentDirPath newName
291 createParentDirectories newPath
292 copyEntry oldRev oldPath newPath
294 deleteEmptyParentDirectories oldPath
296 createPage :: PageName -> Txn ()
298 = do let path = mkPagePath name
299 createParentDirectories path
302 updatePage :: PageName -> Txn ()
304 | isRedirect page = updatePageRedirect name
305 | isEntity page = updatePageEntity name
306 | otherwise = fail "neither redirection nor page"
308 updatePageRedirect :: PageName -> Txn ()
309 updatePageRedirect name
310 = do let path = mkPagePath name
311 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
312 setNodeProp path "rakka:lang" Nothing
313 setNodeProp path "rakka:isTheme" Nothing
314 setNodeProp path "rakka:isFeed" Nothing
315 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
316 setNodeProp path "rakka:isBinary" Nothing
317 setNodeProp path "rakka:summary" Nothing
318 setNodeProp path "rakka:otherLang" Nothing
319 applyText path Nothing (encodeString (redirDest page) ++ "\n")
321 updatePageEntity :: PageName -> Txn ()
322 updatePageEntity name
323 = do let path = mkPagePath name
324 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
325 setNodeProp path "rakka:lang" (entityLanguage page)
326 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
327 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
328 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
329 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
330 setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
331 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
333 if M.null otherLang then
336 Just (encodeString $ serializeStringPairs $ M.toList otherLang))
337 applyTextLBS path Nothing (entityContent page)
339 encodeFlag :: Bool -> Maybe String
340 encodeFlag True = Just "*"
341 encodeFlag False = Nothing
344 createParentDirectories :: FilePath -> Txn ()
345 createParentDirectories path
346 = do let parentPath = takeDirectory path
347 kind <- checkPath parentPath
349 NoNode -> do createParentDirectories parentPath
350 makeDirectory parentPath
351 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
355 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
356 deletePageFromRepository repos userID name
357 = do let pagePath = mkPagePath name
358 attachmentPath = mkAttachmentDirPath name
359 fs <- getRepositoryFS repos
360 rev <- getYoungestRev fs
361 status <- withRevision fs rev
362 $ do exists <- isFile pagePath
364 do prop <- getNodeProp pagePath "rakka:isLocked"
365 return $ case prop of
367 -> if isNothing userID then
376 when (status == NoContent)
377 $ do doReposTxn repos
380 (Just "Automatic commit by Rakka for page deleting")
381 $ do deleteEntry pagePath
382 deleteEmptyParentDirectories pagePath
384 attachmentExists <- isDirectory attachmentPath
385 when attachmentExists
386 $ do deleteEntry attachmentPath
387 deleteEmptyParentDirectories attachmentPath
392 deleteEmptyParentDirectories :: FilePath -> Txn ()
393 deleteEmptyParentDirectories path
394 = do let parentPath = takeDirectory path
395 contents <- getDirEntries parentPath
397 $ do deleteEntry parentPath
398 deleteEmptyParentDirectories parentPath
401 loadAttachmentInRepository :: forall a. Attachment a =>
407 loadAttachmentInRepository repos pName aName rev
408 = do fs <- getRepositoryFS repos
410 Nothing -> getYoungestRev fs
413 $ do exists <- isFile path
415 return . Just =<< loadAttachment'
420 path = mkAttachmentPath pName aName
422 loadAttachment' :: Rev a
423 loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
426 putAttachmentIntoRepository :: Attachment a =>
434 putAttachmentIntoRepository repos userID oldRev pName aName attachment
435 = do let author = fromMaybe "[Rakka]" userID
436 path = mkAttachmentPath pName aName
437 fs <- getRepositoryFS repos
438 oldRev' <- case oldRev of
439 Nothing -> getYoungestRev fs
445 (Just "Automatic commit by Rakka for putting attachment")
446 $ do exists <- isFile path
448 $ do createParentDirectories path
450 applyText path Nothing (serializeToString attachment)
452 Left _ -> return Conflict
453 Right _ -> return NoContent