1 module Rakka.Storage.Repos
2 ( findAllPagesInRevision
3 , findChangedPagesAtRevision
5 , putPageIntoRepository
9 import Codec.Binary.UTF8.String
10 import Control.Exception
13 import qualified Data.Map as M
16 import qualified Data.Set as S hiding (Set)
18 import Network.HTTP.Lucu hiding (redirect)
20 import Rakka.SystemConfig
22 import Rakka.W3CDateTime
23 import Subversion.Error
24 import Subversion.FileSystem
25 import Subversion.FileSystem.DirEntry
26 import Subversion.FileSystem.Revision
27 import Subversion.FileSystem.Root
28 import Subversion.FileSystem.Transaction
29 import Subversion.Repository
30 import Subversion.Types
31 import System.FilePath.Posix
34 mkPagePath :: PageName -> FilePath
36 = "/pages" </> encodePageName name <.> "page"
39 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
40 findAllPagesInRevision repos rev
41 = do fs <- getRepositoryFS repos
43 $ do exists <- isDirectory root
52 traverse :: FilePath -> Rev (Set PageName)
54 = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
56 traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
58 = let path = dir </> entName entry
60 do kind <- checkPath path
62 NoNode -> return S.empty
63 FileNode -> return $ S.singleton (decodePath path)
64 DirNode -> traverse path
66 decodePath :: FilePath -> PageName
67 decodePath = decodePageName . makeRelative root . dropExtension
70 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
71 findChangedPagesAtRevision repos rev
72 = do fs <- getRepositoryFS repos
74 $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
76 accumulatePages :: Set PageName -> FilePath -> Set PageName
77 accumulatePages s path
78 | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
79 = let encoded = makeRelative "/pages" $ dropExtension path
80 name = decodePageName encoded
87 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
88 loadPageInRepository repos name rev
89 = do fs <- getRepositoryFS repos
91 Nothing -> getYoungestRev fs
94 $ do exists <- isFile path
97 -> return . Just =<< loadPage'
102 path = mkPagePath name
104 loadPage' :: Rev Page
105 loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
107 Just (MIMEType "application" "x-rakka-redirection" _)
112 loadPageEntity :: Rev Page
114 = do props <- getNodePropList path
115 hist <- getNodeHistory True path
116 content <- getFileContentsLBS path
118 let pageRev = fst $ head hist
120 $ fromMaybe "text/x-rakka"
121 $ fmap chomp (lookup "svn:mime-type" props)
123 lastMod <- getRevisionProp "svn:date"
124 >>= return . fromJust . parseW3CDateTime . chomp . fromJust
128 , entityType = mimeType
129 , entityLanguage = fmap chomp (lookup "rakka:lang" props)
130 , entityFileName = fmap chomp (lookup "rakka:fileName" 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:fileName" Nothing
231 setNodeProp path "rakka:isTheme" Nothing
232 setNodeProp path "rakka:isFeed" Nothing
233 setNodeProp path "rakka:isLocked" Nothing
234 setNodeProp path "rakka:isBoring" Nothing
235 setNodeProp path "rakka:isBinary" Nothing
236 setNodeProp path "rakka:summary" Nothing
237 setNodeProp path "rakka:otherLang" Nothing
238 applyText path Nothing (encodeString (redirDest page) ++ "\n")
240 updatePageEntity :: PageName -> Txn ()
241 updatePageEntity name
242 = do let path = mkPagePath name
243 setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
244 setNodeProp path "rakka:lang" (entityLanguage page)
245 setNodeProp path "rakka:fileName" (entityFileName page)
246 setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
247 setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
248 setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
249 setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page)
250 setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
251 setNodeProp path "rakka:summary" (entitySummary page)
252 setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
254 if M.null otherLang then
257 Just (serializeStringPairs $ M.toList otherLang))
258 applyTextLBS path Nothing (entityContent page)
260 encodeFlag :: Bool -> Maybe String
261 encodeFlag True = Just "*"
262 encodeFlag False = Nothing
265 filterSvnError :: IO a -> IO a
266 filterSvnError f = catchDyn f rethrow
268 rethrow :: SvnError -> IO a
270 = let code = svnErrCode err
273 fail $ "SvnError: " ++ (show code) ++ ": " ++ msg