]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Storage/Repos.hs
b74f48cb36bb862c92399bb595fd38557996813b
[Rakka.git] / Rakka / Storage / Repos.hs
1 module Rakka.Storage.Repos
2     ( findAllPagesInRevision
3     , getDirContentsInRevision
4     , findChangedPagesAtRevision
5     , loadPageInRepository
6     , putPageIntoRepository
7     , deletePageFromRepository
8     , loadAttachmentInRepository
9     , putAttachmentIntoRepository
10     )
11     where
12
13 import           Codec.Binary.UTF8.String
14 import           Control.Exception
15 import           Control.Monad
16 import           Data.List
17 import qualified Data.Map as M
18 import           Data.Maybe
19 import           Data.Set (Set)
20 import qualified Data.Set as S hiding (Set)
21 import           Data.Time
22 import           Network.HTTP.Lucu hiding (redirect)
23 import           Rakka.Attachment
24 import           Rakka.Page
25 import           Rakka.SystemConfig
26 import           Rakka.Utils
27 import           Rakka.W3CDateTime
28 import           Subversion.Error
29 import           Subversion.FileSystem
30 import           Subversion.FileSystem.DirEntry
31 import           Subversion.FileSystem.Revision
32 import           Subversion.FileSystem.Root
33 import           Subversion.FileSystem.Transaction
34 import           Subversion.Repository
35 import           Subversion.Types
36 import           System.FilePath.Posix
37
38
39 mkPagePath :: PageName -> FilePath
40 mkPagePath name
41     = "/pages" </> encodePageName name <.> "page"
42
43
44 mkDirPath :: PageName -> FilePath
45 mkDirPath dir
46     = "/pages" </> encodePageName dir
47
48
49 mkAttachmentPath :: PageName -> String -> FilePath
50 mkAttachmentPath pName aName
51     = "/attachments" </> encodePageName pName <.> "page" </> aName
52
53
54 mkAttachmentDirPath :: PageName -> FilePath
55 mkAttachmentDirPath pName
56     = "/attachments" </> encodePageName pName <.> "page"
57
58
59 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
60 findAllPagesInRevision repos rev
61     = do fs <- getRepositoryFS repos
62          withRevision fs rev
63              $ do exists <- isDirectory root
64                   if exists then
65                       traverse root
66                     else
67                       return S.empty
68     where
69       root :: FilePath
70       root = "/pages"
71
72       traverse :: FilePath -> Rev (Set PageName)
73       traverse dir
74           = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
75
76       traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
77       traverse' dir entry
78           = let path = dir </> entName entry
79             in
80               do kind <- checkPath path
81                  case kind of
82                    NoNode   -> return S.empty
83                    FileNode -> return $ S.singleton (decodePath path)
84                    DirNode  -> traverse path
85
86       decodePath :: FilePath -> PageName
87       decodePath = decodePageName . makeRelative root . dropExtension
88
89
90 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
91 getDirContentsInRevision repos dir rev
92     = do fs   <- getRepositoryFS repos
93          rev' <- case rev of
94                    Nothing -> getYoungestRev fs
95                    Just r  -> return r
96          withRevision fs rev'
97              $ do exists <- isDirectory path
98                   if exists then
99                       return . S.fromList =<< getDir'
100                     else
101                       return S.empty
102     where
103       path :: FilePath
104       path = mkDirPath dir
105
106       getDir' :: Rev [PageName]
107       getDir' = getDirEntries path >>= return . map entToName
108
109       entToName :: DirEntry -> PageName
110       entToName = (dir </>) . decodePageName . dropExtension . entName
111
112
113 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
114 findChangedPagesAtRevision repos rev
115     = do fs <- getRepositoryFS repos
116          withRevision fs rev
117              $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
118     where
119       accumulatePages :: Set PageName -> FilePath -> Set PageName
120       accumulatePages s path
121           | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
122               = let encoded = makeRelative "/pages" $ dropExtension path
123                     name    = decodePageName encoded
124                 in
125                   S.insert name s
126           | otherwise
127               = s
128
129
130 loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
131 loadPageInRepository repos name rev
132     = do fs   <- getRepositoryFS repos
133          rev' <- case rev of
134                    Nothing -> getYoungestRev fs
135                    Just r  -> return r
136          withRevision fs rev'
137              $ do exists <- isFile path
138                   if exists then
139                       return . Just =<< loadPage'
140                     else
141                       return Nothing
142     where
143       path :: FilePath
144       path = mkPagePath name
145
146       loadPage' :: Rev Page
147       loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
148                      case mType of
149                        Just (MIMEType "application" "x-rakka-redirection" _)
150                            -> loadPageRedirect
151                        _
152                            -> loadPageEntity
153
154       loadPageEntity :: Rev Page
155       loadPageEntity
156           = do props   <- getNodePropList path
157                hist    <- getNodeHistory True path
158                content <- getFileContentsLBS path
159                
160                let pageRev  = fst $ head hist
161                    mimeType = read
162                               $ fromMaybe "text/x-rakka"
163                               $ fmap chomp (lookup "svn:mime-type" props)
164
165                lastMod <- getRevisionProp "svn:date"
166                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
167
168                return Entity {
169                             entityName       = name
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
176                                                  MIMEType "text" _ _
177                                                      -> any ((== "rakka:isBinary") . fst) props
178                                                  _
179                                                      -> True
180                           , entityRevision   = pageRev
181                           , entityLastMod    = zonedTimeToUTC lastMod
182                           , entitySummary    = fmap decodeString (lookup "rakka:summary" props)
183                           , entityOtherLang  = fromMaybe M.empty
184                                              $ fmap
185                                                    (M.fromList . fromJust . deserializeStringPairs . decodeString)
186                                                    (lookup "rakka:otherLang" props)
187                           , entityContent    = content                                             
188                           , entityUpdateInfo = undefined
189                           }
190       
191       loadPageRedirect :: Rev Page
192       loadPageRedirect
193           = do hist    <- getNodeHistory True path
194                content <- getFileContents path
195
196                let pageRev = fst $ head hist
197                    dest    = chomp $ decodeString content
198
199                lastMod <- getRevisionProp "svn:date"
200                           >>= return . fromJust . parseW3CDateTime . chomp . fromJust
201
202                isLocked <- getRevisionProp "rakka:isLocked"
203                            >>= return . isJust
204
205                return Redirection {
206                             redirName       = name
207                           , redirDest       = dest
208                           , redirIsLocked   = isLocked
209                           , redirRevision   = pageRev
210                           , redirLastMod    = zonedTimeToUTC lastMod
211                           , redirUpdateInfo = undefined
212                           }
213
214
215 putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
216 putPageIntoRepository repos userID page
217     = filterSvnError $
218       do let name   = pageName page
219              author = fromMaybe "[Rakka]" userID
220          case pageUpdateInfo page of
221            Just ui
222                -> do let oldRev = uiOldRevision ui
223                      denied <- case uiOldName ui of
224                                  Nothing      -> checkDenial oldRev name
225                                  Just oldName -> checkDenial oldRev oldName
226                      if denied then
227                          return Forbidden
228                        else
229                          do ret <- doReposTxn
230                                    repos
231                                    (uiOldRevision ui)
232                                    author
233                                    (Just "Automatic commit by Rakka for page update")
234                                    $ do case uiOldName ui of
235                                           Nothing      -> return ()
236                                           Just oldName -> movePage (uiOldRevision ui) oldName name
237                                                           >>
238                                                           moveAttachments (uiOldRevision ui) oldName name
239                                         updatePage name
240                             case ret of
241                               Left  _ -> return Conflict
242                               Right _ -> return Created
243            Nothing
244                -> do fs  <- getRepositoryFS repos
245                      rev <- getYoungestRev fs
246                      ret <- doReposTxn
247                             repos
248                             rev
249                             author
250                             (Just "Automatic commit by Rakka for page creation")
251                             $ do createPage name
252                                  updatePage name
253                      case ret of
254                        Left  _ -> return Conflict
255                        Right _ -> return Created
256     where
257       checkDenial :: RevNum -> PageName -> IO Bool
258       checkDenial rev name
259           = do fs <- getRepositoryFS repos
260                withRevision fs rev
261                    $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
262                         case prop of
263                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
264                           Nothing -> return False
265
266       movePage :: RevNum -> PageName -> PageName -> Txn ()
267       movePage oldRev oldName newName
268           = do let oldPath = mkPagePath oldName
269                    newPath = mkPagePath newName
270                createParentDirectories newPath
271                copyEntry oldRev oldPath newPath
272                deleteEntry oldPath
273                deleteEmptyParentDirectories oldPath
274
275       moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
276       moveAttachments oldRev oldName newName
277           = do let oldPath = mkAttachmentDirPath oldName
278                    newPath = mkAttachmentDirPath newName
279                createParentDirectories newPath
280                copyEntry oldRev oldPath newPath
281                deleteEntry oldPath
282                deleteEmptyParentDirectories oldPath
283
284       createPage :: PageName -> Txn ()
285       createPage name
286           = do let path = mkPagePath name
287                createParentDirectories path
288                makeFile path
289
290       updatePage :: PageName -> Txn ()
291       updatePage name
292           | isRedirect page = updatePageRedirect name
293           | isEntity   page = updatePageEntity name
294           | otherwise       = fail "neither redirection nor page"
295
296       updatePageRedirect :: PageName -> Txn ()
297       updatePageRedirect name
298           = do let path = mkPagePath name
299                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
300                setNodeProp path "rakka:lang"      Nothing
301                setNodeProp path "rakka:isTheme"   Nothing
302                setNodeProp path "rakka:isFeed"    Nothing
303                setNodeProp path "rakka:isLocked"  (encodeFlag $ redirIsLocked page)
304                setNodeProp path "rakka:isBinary"  Nothing
305                setNodeProp path "rakka:summary"   Nothing
306                setNodeProp path "rakka:otherLang" Nothing
307                applyText path Nothing (encodeString (redirDest page) ++ "\n")
308
309       updatePageEntity :: PageName -> Txn ()
310       updatePageEntity name
311           = do let path = mkPagePath name
312                setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
313                setNodeProp path "rakka:lang"      (entityLanguage page)
314                setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
315                setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
316                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
317                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
318                setNodeProp path "rakka:summary"   (fmap encodeString $ entitySummary page)
319                setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
320                                                    in
321                                                      if M.null otherLang then
322                                                          Nothing
323                                                      else
324                                                          Just (encodeString $ serializeStringPairs $ M.toList otherLang))
325                applyTextLBS path Nothing (entityContent page)
326
327       encodeFlag :: Bool -> Maybe String
328       encodeFlag True  = Just "*"
329       encodeFlag False = Nothing
330
331
332 createParentDirectories :: FilePath -> Txn ()
333 createParentDirectories path
334     = do let parentPath = takeDirectory path
335          kind <- checkPath parentPath
336          case kind of
337            NoNode   -> do createParentDirectories parentPath
338                           makeDirectory parentPath
339            FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
340            DirNode  -> return ()
341
342
343 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
344 deletePageFromRepository repos userID name
345     = filterSvnError $
346       do let pagePath       = mkPagePath name
347              attachmentPath = mkAttachmentDirPath name
348          fs     <- getRepositoryFS repos
349          rev    <- getYoungestRev fs
350          status <- withRevision fs rev
351                    $ do exists <- isFile pagePath
352                         if exists then
353                             do prop <- getNodeProp pagePath "rakka:isLocked"
354                                return $ case prop of
355                                           Just _
356                                               -> if isNothing userID then
357                                                      -- 施錠されてゐるので匿名では駄目
358                                                      Forbidden
359                                                  else
360                                                      NoContent
361                                           Nothing
362                                               -> NoContent
363                           else
364                             return NotFound
365          when (status == NoContent)
366              $ do doReposTxn repos
367                              rev
368                              "[Rakka]"
369                              (Just "Automatic commit by Rakka for page deleting")
370                              $ do deleteEntry pagePath
371                                   deleteEmptyParentDirectories pagePath
372
373                                   attachmentExists <- isDirectory attachmentPath
374                                   when attachmentExists
375                                       $ do deleteEntry attachmentPath
376                                            deleteEmptyParentDirectories attachmentPath
377                   return ()
378          return status
379
380
381 deleteEmptyParentDirectories :: FilePath -> Txn ()
382 deleteEmptyParentDirectories path
383     = do let parentPath = takeDirectory path
384          contents <- getDirEntries parentPath
385          when (null contents)
386                   $ do deleteEntry parentPath
387                        deleteEmptyParentDirectories parentPath
388
389
390 loadAttachmentInRepository :: forall a. Attachment a =>
391                               Repository
392                            -> PageName
393                            -> String
394                            -> Maybe RevNum
395                            -> IO (Maybe a)
396 loadAttachmentInRepository repos pName aName rev
397     = do fs   <- getRepositoryFS repos
398          rev' <- case rev of
399                    Nothing -> getYoungestRev fs
400                    Just r  -> return r
401          withRevision fs rev'
402              $ do exists <- isFile path
403                   if exists then
404                       return . Just =<< loadAttachment'
405                     else
406                       return Nothing
407     where
408       path :: FilePath
409       path = mkAttachmentPath pName aName
410
411       loadAttachment' :: Rev a
412       loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
413
414
415 putAttachmentIntoRepository :: Attachment a =>
416                                Repository
417                             -> Maybe String
418                             -> Maybe RevNum
419                             -> PageName
420                             -> String
421                             -> a
422                             -> IO StatusCode
423 putAttachmentIntoRepository repos userID oldRev pName aName attachment
424     = filterSvnError $
425       do let author = fromMaybe "[Rakka]" userID
426              path   = mkAttachmentPath pName aName
427          fs      <- getRepositoryFS repos
428          oldRev' <- case oldRev of
429                       Nothing -> getYoungestRev fs
430                       Just r  -> return r
431          ret <- doReposTxn
432                 repos
433                 oldRev'
434                 author
435                 (Just "Automatic commit by Rakka for putting attachment")
436                 $ do exists <- isFile path
437                      unless exists
438                          $ do createParentDirectories path
439                               makeFile path
440                      applyText path Nothing (serializeToString attachment)
441          case ret of
442            Left  _ -> return Conflict
443            Right _ -> return NoContent
444
445
446 filterSvnError :: IO a -> IO a
447 filterSvnError f = catchDyn f rethrow
448     where
449       rethrow :: SvnError -> IO a
450       rethrow err
451           = let code = svnErrCode err
452                 msg  = svnErrMsg  err
453             in
454               fail $ "SvnError: " ++ (show code) ++ ": " ++ msg