1 -- -*- coding: utf-8 -*-
8 module Rakka.Storage.Repos
9 ( findAllPagesInRevision
10 , getDirContentsInRevision
11 , findChangedPagesAtRevision
12 , loadPageInRepository
13 , putPageIntoRepository
14 , deletePageFromRepository
15 , loadAttachmentInRepository
16 , putAttachmentIntoRepository
19 import Control.Applicative
20 import Codec.Binary.UTF8.String
22 import Control.Monad.Unicode
23 import qualified Data.CaseInsensitive as CI
25 import qualified Data.Map as M
27 import Data.Monoid.Unicode
29 import qualified Data.Set as S hiding (Set)
30 import qualified Data.Text as T
32 import qualified Data.Time.W3C as W3C
33 import Network.HTTP.Lucu hiding (redirect)
34 import Prelude.Unicode
35 import Rakka.Attachment
37 import Rakka.SystemConfig
39 import Subversion.FileSystem
40 import Subversion.FileSystem.DirEntry
41 import Subversion.FileSystem.Revision
42 import Subversion.FileSystem.Root
43 import Subversion.FileSystem.Transaction
44 import Subversion.Repository
45 import Subversion.Types
46 import System.FilePath.Posix
49 mkPagePath :: PageName -> FilePath
51 = "/pages" </> encodePageName name <.> "page"
54 mkDirPath :: PageName -> FilePath
56 = "/pages" </> encodePageName dir
59 mkAttachmentPath :: PageName -> String -> FilePath
60 mkAttachmentPath pName aName
61 = "/attachments" </> encodePageName pName <.> "page" </> aName
64 mkAttachmentDirPath :: PageName -> FilePath
65 mkAttachmentDirPath pName
66 = "/attachments" </> encodePageName pName <.> "page"
69 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
70 findAllPagesInRevision repos rev
71 = do fs <- getRepositoryFS repos
73 $ do exists <- isDirectory root
82 traverse :: FilePath -> Rev (Set PageName)
84 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
86 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
88 = let path = dir </> entName entry
90 do kind <- checkPath path
92 NoNode -> return S.empty
93 FileNode -> return $ S.singleton (decodePath path)
94 DirNode -> traverse path
96 decodePath :: FilePath -> PageName
97 decodePath = decodePageName . makeRelative root . dropExtension
99 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
100 getDirContentsInRevision repos dir rev
101 = do fs <- getRepositoryFS repos
103 Nothing -> getYoungestRev fs
106 $ do exists <- isDirectory path
108 return . S.fromList =<< getDir'
115 getDir' :: Rev [PageName]
116 getDir' = liftM (map entToName) (getDirEntries path)
118 entToName ∷ DirEntry → PageName
119 entToName = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ dropExtension ∘ entName
121 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
122 findChangedPagesAtRevision repos rev
123 = do fs <- getRepositoryFS repos
125 $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
127 accumulatePages :: Set PageName -> FilePath -> Set PageName
128 accumulatePages s path
129 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
130 = let encoded = makeRelative "/pages" $ dropExtension path
131 name = decodePageName encoded
138 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
139 loadPageInRepository repos name rev
140 = do fs <- getRepositoryFS repos
142 Nothing -> getYoungestRev fs
145 $ do exists <- isFile path
147 return . Just =<< loadPage' fs
152 path = mkPagePath name
154 loadPage' :: FileSystem -> Rev Page
156 = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
158 Just (MIMEType "application" "x-rakka-redirection" _)
159 -> loadPageRedirect fs
163 loadPageEntity :: FileSystem -> Rev Page
165 = do props <- getNodePropList path
166 hist <- getNodeHistory True path
167 content <- getFileContentsLBS path
169 let pageRev = fst $ head hist
171 $ fromMaybe "text/x-rakka"
172 $ fmap chomp (lookup "svn:mime-type" props)
174 lastMod <- unsafeIOToFS $
175 liftM (fromJust . W3C.parse . chomp . fromJust)
176 (getRevisionProp' fs pageRev "svn:date")
180 , entityType = mimeType
181 , entityLanguage = CI.mk ∘ T.pack ∘ chomp <$> lookup "rakka:lang" props
182 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
183 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
184 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
185 , entityIsBinary = case mimeType of
187 -> any ((== "rakka:isBinary") . fst) props
190 , entityRevision = pageRev
191 , entityLastMod = zonedTimeToUTC lastMod
192 , entitySummary = fmap decodeString (lookup "rakka:summary" props)
193 , entityOtherLang = maybe (∅)
194 (fromJust ∘ deserializeMap CI.mk id ∘ T.pack ∘ decodeString)
195 (lookup "rakka:otherLang" props)
196 , entityContent = content
197 , entityUpdateInfo = undefined
200 loadPageRedirect :: FileSystem -> Rev Page
202 = do hist <- getNodeHistory True path
203 content <- getFileContents path
205 let pageRev = fst $ head hist
206 dest = T.pack ∘ chomp $ decodeString content
208 lastMod <- unsafeIOToFS $
209 liftM (fromJust . W3C.parse . chomp . fromJust)
210 (getRevisionProp' fs pageRev "svn:date")
212 isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
217 , redirIsLocked = isLocked
218 , redirRevision = pageRev
219 , redirLastMod = zonedTimeToUTC lastMod
220 , redirUpdateInfo = undefined
224 putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode
225 putPageIntoRepository repos userID page
226 = case pageUpdateInfo page of
228 → do let oldRev = uiOldRevision ui
229 denied ← case uiOldName ui of
230 Nothing → shouldDeny oldRev name
231 Just oldName → shouldDeny oldRev oldName
235 do rev ← if oldRev ≡ 0 then
236 getRepositoryFS repos ≫= getYoungestRev
239 ret ← doReposTxn repos
242 (Just "Automatic commit by Rakka for page update")
243 $ do case uiOldName ui of
245 Just oldName → do exists ← isFile (mkPagePath oldName)
247 ( movePage (uiOldRevision ui) oldName name ≫
248 moveAttachments (uiOldRevision ui) oldName name
250 exists ← isFile (mkPagePath name)
255 Left _ → return Conflict
256 Right _ → return Created
258 → do fs ← getRepositoryFS repos
259 rev ← getYoungestRev fs
260 ret ← doReposTxn repos
263 (Just "Automatic commit by Rakka for page creation")
264 $ (createPage name ≫ updatePage name)
266 Left _ → return Conflict
267 Right _ → return Created
273 author = fromMaybe "[Rakka]" userID
275 shouldDeny ∷ RevNum → PageName → IO Bool
277 = do fs ← getRepositoryFS repos
279 $ do exists ← isFile (mkPagePath name')
281 do prop ← getNodeProp (mkPagePath name') "rakka:isLocked"
283 Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
284 Nothing -> return False
286 return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
288 movePage :: RevNum -> PageName -> PageName -> Txn ()
289 movePage oldRev oldName newName
290 = do let oldPath = mkPagePath oldName
291 newPath = mkPagePath newName
292 createParentDirectories newPath
293 copyEntry oldRev oldPath newPath
295 deleteEmptyParentDirectories oldPath
297 moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
298 moveAttachments oldRev oldName newName
299 = do let oldPath = mkAttachmentDirPath oldName
300 newPath = mkAttachmentDirPath newName
301 createParentDirectories newPath
302 copyEntry oldRev oldPath newPath
304 deleteEmptyParentDirectories oldPath
306 createPage :: PageName -> Txn ()
308 = do let path = mkPagePath name'
309 createParentDirectories path
312 updatePage ∷ PageName → Txn ()
314 | isRedirect page = updatePageRedirect name'
315 | isEntity page = updatePageEntity name'
316 | otherwise = fail "neither redirection nor page"
318 updatePageRedirect :: PageName -> Txn ()
319 updatePageRedirect name'
320 = do let path = mkPagePath name'
321 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
322 setNodeProp path "rakka:lang" Nothing
323 setNodeProp path "rakka:isTheme" Nothing
324 setNodeProp path "rakka:isFeed" Nothing
325 setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
326 setNodeProp path "rakka:isBinary" Nothing
327 setNodeProp path "rakka:summary" Nothing
328 setNodeProp path "rakka:otherLang" Nothing
329 applyText path Nothing (encodeString (T.unpack $ redirDest page) ⊕ "\n")
331 updatePageEntity :: PageName -> Txn ()
332 updatePageEntity name'
333 = do let path = mkPagePath name'
334 setNodeProp path "svn:mime-type" (Just ∘ show $ entityType page)
335 setNodeProp path "rakka:lang" (T.unpack ∘ CI.foldedCase <$> entityLanguage page)
336 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
337 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
338 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
339 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
340 setNodeProp path "rakka:summary" (encodeString <$> entitySummary page)
341 setNodeProp path "rakka:otherLang" ( if M.null (entityOtherLang page) then
344 Just ∘ T.unpack ∘ serializeMap CI.foldedCase id
345 $ entityOtherLang page
347 applyTextLBS path Nothing (entityContent page)
349 encodeFlag :: Bool -> Maybe String
350 encodeFlag True = Just "*"
351 encodeFlag False = Nothing
354 createParentDirectories :: FilePath -> Txn ()
355 createParentDirectories path
356 = do let parentPath = takeDirectory path
357 kind <- checkPath parentPath
359 NoNode -> do createParentDirectories parentPath
360 makeDirectory parentPath
361 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
365 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
366 deletePageFromRepository repos userID name
367 = do let pagePath = mkPagePath name
368 attachmentPath = mkAttachmentDirPath name
369 fs <- getRepositoryFS repos
370 rev <- getYoungestRev fs
371 status <- withRevision fs rev
372 $ do exists <- isFile pagePath
374 do prop <- getNodeProp pagePath "rakka:isLocked"
375 return $ case prop of
377 -> if isNothing userID then
386 when (status == NoContent)
387 $ ( (doReposTxn repos
390 (Just "Automatic commit by Rakka for page deleting")
391 $ do deleteEntry pagePath
392 deleteEmptyParentDirectories pagePath
394 attachmentExists <- isDirectory attachmentPath
395 when attachmentExists
396 $ do deleteEntry attachmentPath
397 deleteEmptyParentDirectories attachmentPath)
402 deleteEmptyParentDirectories :: FilePath -> Txn ()
403 deleteEmptyParentDirectories path
404 = do let parentPath = takeDirectory path
405 contents <- getDirEntries parentPath
407 $ do deleteEntry parentPath
408 deleteEmptyParentDirectories parentPath
411 loadAttachmentInRepository ∷ ∀α. Attachment α
417 loadAttachmentInRepository repos pName aName rev
418 = do fs <- getRepositoryFS repos
420 Nothing -> getYoungestRev fs
423 $ do exists <- isFile path
425 return . Just =<< loadAttachment'
430 path = mkAttachmentPath pName aName
432 loadAttachment' ∷ Rev α
433 loadAttachment' = (deserializeFromString ∘ decodeString)
434 `liftM` getFileContents path
436 putAttachmentIntoRepository :: Attachment a =>
444 putAttachmentIntoRepository repos userID oldRev pName aName attachment
445 = do let author = fromMaybe "[Rakka]" userID
446 path = mkAttachmentPath pName aName
447 fs <- getRepositoryFS repos
448 oldRev' <- case oldRev of
449 Nothing -> getYoungestRev fs
455 (Just "Automatic commit by Rakka for putting attachment")
456 $ do exists <- isFile path
458 $ do createParentDirectories path
460 applyText path Nothing (encodeString $ serializeToString attachment)
462 Left _ -> return Conflict
463 Right _ -> return NoContent