1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , findChangedPagesAtRevision
5 , putPageIntoRepository
6 , deletePageFromRepository
10 import Codec.Binary.UTF8.String
11 import Control.Exception
14 import qualified Data.Map as M
17 import qualified Data.Set as S hiding (Set)
19 import Network.HTTP.Lucu hiding (redirect)
21 import Rakka.SystemConfig
23 import Rakka.W3CDateTime
24 import Subversion.Error
25 import Subversion.FileSystem
26 import Subversion.FileSystem.DirEntry
27 import Subversion.FileSystem.Revision
28 import Subversion.FileSystem.Root
29 import Subversion.FileSystem.Transaction
30 import Subversion.Repository
31 import Subversion.Types
32 import System.FilePath.Posix
35 mkPagePath :: PageName -> FilePath
37 = "/pages" </> encodePageName name <.> "page"
40 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
41 findAllPagesInRevision repos rev
42 = do fs <- getRepositoryFS repos
44 $ do exists <- isDirectory root
53 traverse :: FilePath -> Rev (Set PageName)
55 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
57 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
59 = let path = dir </> entName entry
61 do kind <- checkPath path
63 NoNode -> return S.empty
64 FileNode -> return $ S.singleton (decodePath path)
65 DirNode -> traverse path
67 decodePath :: FilePath -> PageName
68 decodePath = decodePageName . makeRelative root . dropExtension
71 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
72 findChangedPagesAtRevision repos rev
73 = do fs <- getRepositoryFS repos
75 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
77 accumulatePages :: Set PageName -> FilePath -> Set PageName
78 accumulatePages s path
79 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
80 = let encoded = makeRelative "/pages" $ dropExtension path
81 name = decodePageName encoded
88 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
89 loadPageInRepository repos name rev
90 = do fs <- getRepositoryFS repos
92 Nothing -> getYoungestRev fs
95 $ do exists <- isFile path
98 -> return . Just =<< loadPage'
103 path = mkPagePath name
105 loadPage' :: Rev Page
106 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
108 Just (MIMEType "application" "x-rakka-redirection" _)
113 loadPageEntity :: Rev Page
115 = do props <- getNodePropList path
116 hist <- getNodeHistory True path
117 content <- getFileContentsLBS path
119 let pageRev = fst $ head hist
121 $ fromMaybe "text/x-rakka"
122 $ fmap chomp (lookup "svn:mime-type" props)
124 lastMod <- getRevisionProp "svn:date"
125 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
129 , entityType = mimeType
130 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
131 , entityIsTheme = any ((== "rakka:isTheme") . fst) props
132 , entityIsFeed = any ((== "rakka:isFeed") . fst) props
133 , entityIsLocked = any ((== "rakka:isLocked") . fst) props
134 , entityIsBinary = case mimeType of
136 -> any ((== "rakka:isBinary") . fst) props
139 , entityRevision = pageRev
140 , entityLastMod = zonedTimeToUTC lastMod
141 , entitySummary = lookup "rakka:summary" props
142 , entityOtherLang = fromMaybe M.empty
144 (M.fromList . fromJust . deserializeStringPairs)
145 (lookup "rakka:otherLang" props)
146 , entityContent = content
147 , entityUpdateInfo = undefined
150 loadPageRedirect :: Rev Page
152 = do hist <- getNodeHistory True path
153 content <- getFileContents path
155 let pageRev = fst $ head hist
156 dest = chomp $ decodeString content
158 lastMod <- getRevisionProp "svn:date"
159 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
164 , redirRevision = pageRev
165 , redirLastMod = zonedTimeToUTC lastMod
166 , redirUpdateInfo = undefined
170 putPageIntoRepository :: Repository -> Page -> IO StatusCode
171 putPageIntoRepository repos page
173 do let name = pageName page
174 ret <- case pageUpdateInfo page of
180 (Just "Automatic commit by Rakka for page update")
181 $ do case uiOldName ui of
183 Just oldName -> renamePage (uiOldRevision ui) oldName name
186 -> do fs <- getRepositoryFS repos
187 rev <- getYoungestRev fs
191 (Just "Automatic commit by Rakka for page creation")
195 Left _ -> return Conflict
196 Right _ -> return Created
198 renamePage :: RevNum -> PageName -> PageName -> Txn ()
199 renamePage oldRev oldName newName
200 = do let oldPath = mkPagePath oldName
201 newPath = mkPagePath newName
202 createParentDirectories newPath
203 copyEntry oldRev oldPath newPath
205 deleteEmptyParentDirectories oldPath
207 createPage :: PageName -> Txn ()
209 = do let path = mkPagePath name
210 createParentDirectories path
213 updatePage :: PageName -> Txn ()
215 | isRedirect page = updatePageRedirect name
216 | isEntity page = updatePageEntity name
217 | otherwise = fail "neither redirection nor page"
219 updatePageRedirect :: PageName -> Txn ()
220 updatePageRedirect name
221 = do let path = mkPagePath name
222 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
223 setNodeProp path "rakka:lang" Nothing
224 setNodeProp path "rakka:isTheme" Nothing
225 setNodeProp path "rakka:isFeed" Nothing
226 setNodeProp path "rakka:isLocked" Nothing
227 setNodeProp path "rakka:isBinary" Nothing
228 setNodeProp path "rakka:summary" Nothing
229 setNodeProp path "rakka:otherLang" Nothing
230 applyText path Nothing (encodeString (redirDest page) ++ "\n")
232 updatePageEntity :: PageName -> Txn ()
233 updatePageEntity name
234 = do let path = mkPagePath name
235 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
236 setNodeProp path "rakka:lang" (entityLanguage page)
237 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
238 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
239 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
240 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
241 setNodeProp path "rakka:summary" (entitySummary page)
242 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
244 if M.null otherLang then
247 Just (serializeStringPairs $ M.toList otherLang))
248 applyTextLBS path Nothing (entityContent page)
250 encodeFlag :: Bool -> Maybe String
251 encodeFlag True = Just "*"
252 encodeFlag False = Nothing
255 createParentDirectories :: FilePath -> Txn ()
256 createParentDirectories path
257 = do let parentPath = takeDirectory path
258 kind <- checkPath parentPath
260 NoNode -> do createParentDirectories parentPath
261 makeDirectory parentPath
262 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
266 deletePageFromRepository :: Repository -> PageName -> IO StatusCode
267 deletePageFromRepository repos name
269 do let path = mkPagePath name
270 fs <- getRepositoryFS repos
271 rev <- getYoungestRev fs
272 exists <- withRevision fs rev $ isFile path
277 (Just "Automatic commit by Rakka for page deleting")
278 $ do deleteEntry path
279 deleteEmptyParentDirectories path
285 deleteEmptyParentDirectories :: FilePath -> Txn ()
286 deleteEmptyParentDirectories path
287 = do let parentPath = takeDirectory path
288 contents <- getDirEntries parentPath
290 $ do deleteEntry parentPath
291 deleteEmptyParentDirectories parentPath
294 filterSvnError :: IO a -> IO a
295 filterSvnError f = catchDyn f rethrow
297 rethrow :: SvnError -> IO a
299 = let code = svnErrCode err
302 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg