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 , entityIsBoring = any ((== "rakka:isBoring") . fst) props
135 , entityIsBinary = case mimeType of
137 -> any ((== "rakka:isBinary") . fst) props
140 , entityRevision = pageRev
141 , entityLastMod = zonedTimeToUTC lastMod
142 , entitySummary = lookup "rakka:summary" props
143 , entityOtherLang = fromMaybe M.empty
145 (M.fromList . fromJust . deserializeStringPairs)
146 (lookup "rakka:otherLang" props)
147 , entityContent = content
148 , entityUpdateInfo = undefined
151 loadPageRedirect :: Rev Page
153 = do hist <- getNodeHistory True path
154 content <- getFileContents path
156 let pageRev = fst $ head hist
157 dest = chomp $ decodeString content
159 lastMod <- getRevisionProp "svn:date"
160 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
165 , redirRevision = pageRev
166 , redirLastMod = zonedTimeToUTC lastMod
167 , redirUpdateInfo = undefined
171 putPageIntoRepository :: Repository -> Page -> IO StatusCode
172 putPageIntoRepository repos page
174 do let name = pageName page
175 ret <- case pageUpdateInfo page of
181 (Just "Automatic commit by Rakka for page update")
182 $ do case uiOldName ui of
184 Just oldName -> renamePage oldName name
187 -> do fs <- getRepositoryFS repos
188 rev <- getYoungestRev fs
192 (Just "Automatic commit by Rakka for page creation")
196 Left _ -> return Conflict
197 Right _ -> return Created
199 renamePage :: PageName -> PageName -> Txn ()
200 renamePage oldName newName
201 = fail "FIXME: renamePage: not implemented yet"
203 createPage :: PageName -> Txn ()
205 = do let path = mkPagePath name
206 createParentDirectories path
209 createParentDirectories :: FilePath -> Txn ()
210 createParentDirectories path
211 = do let parentPath = takeDirectory path
212 kind <- checkPath parentPath
214 NoNode -> do createParentDirectories parentPath
215 makeDirectory parentPath
216 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
219 updatePage :: PageName -> Txn ()
221 | isRedirect page = updatePageRedirect name
222 | isEntity page = updatePageEntity name
223 | otherwise = fail "neither redirection nor page"
225 updatePageRedirect :: PageName -> Txn ()
226 updatePageRedirect name
227 = do let path = mkPagePath name
228 setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
229 setNodeProp path "rakka:lang" Nothing
230 setNodeProp path "rakka:isTheme" Nothing
231 setNodeProp path "rakka:isFeed" Nothing
232 setNodeProp path "rakka:isLocked" Nothing
233 setNodeProp path "rakka:isBoring" Nothing
234 setNodeProp path "rakka:isBinary" Nothing
235 setNodeProp path "rakka:summary" Nothing
236 setNodeProp path "rakka:otherLang" Nothing
237 applyText path Nothing (encodeString (redirDest page) ++ "\n")
239 updatePageEntity :: PageName -> Txn ()
240 updatePageEntity name
241 = do let path = mkPagePath name
242 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
243 setNodeProp path "rakka:lang" (entityLanguage page)
244 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
245 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
246 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
247 setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page)
248 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
249 setNodeProp path "rakka:summary" (entitySummary page)
250 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
252 if M.null otherLang then
255 Just (serializeStringPairs $ M.toList otherLang))
256 applyTextLBS path Nothing (entityContent page)
258 encodeFlag :: Bool -> Maybe String
259 encodeFlag True = Just "*"
260 encodeFlag False = Nothing
263 deletePageFromRepository :: Repository -> PageName -> IO StatusCode
264 deletePageFromRepository repos name
266 do let path = mkPagePath name
267 fs <- getRepositoryFS repos
268 rev <- getYoungestRev fs
269 exists <- withRevision fs rev $ isFile path
274 (Just "Automatic commit by Rakka for page deleting")
275 $ do deleteEntry path
276 deleteEmptyParentDirectories path
281 deleteEmptyParentDirectories :: FilePath -> Txn ()
282 deleteEmptyParentDirectories path
283 = do let parentPath = takeDirectory path
284 contents <- getDirEntries parentPath
286 $ do deleteEntry parentPath
287 deleteEmptyParentDirectories parentPath
290 filterSvnError :: IO a -> IO a
291 filterSvnError f = catchDyn f rethrow
293 rethrow :: SvnError -> IO a
295 = let code = svnErrCode err
298 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg