Rakka/Storage/Impl.hs

   1 module Rakka.Storage.Impl
   2     ( getPage'
   3     , putPage'
   4     , deletePage'
   5     , getDirContents'
   6     , startIndexManager
   7
   8     , getAttachment'
   9     , putAttachment'
  10     )
  11     where
  12
  13 import           Control.Concurrent
  14 import           Control.Concurrent.STM
  15 import           Control.Monad
  16 import           Data.Maybe
  17 import           Data.Set (Set)
  18 import qualified Data.Set as S
  19 import           Network.HTTP.Lucu
  20 import           Network.URI
  21 import           Rakka.Attachment
  22 import           Rakka.Page
  23 import           Rakka.Storage.DefaultPage
  24 import           Rakka.Storage.Repos
  25 import           Rakka.Storage.Types
  26 import           Subversion.Types
  27 import           Subversion.FileSystem
  28 import           Subversion.Repository
  29 import           System.Directory
  30 import           System.FilePath
  31 import           System.IO
  32 import           System.Log.Logger
  33 import           Text.HyperEstraier hiding (WriteLock)
  34
  35
  36 logger :: String
  37 logger = "Rakka.Storage"
  38
  39
  40 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
  41 getPage' repos name rev
  42     = do page <- loadPageInRepository repos name rev
  43          case page of
  44            Nothing -> loadDefaultPage name
  45            p       -> return p
  46
  47
  48 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
  49 putPage' = putPageIntoRepository
  50
  51
  52 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
  53 deletePage' = deletePageFromRepository
  54
  55
  56 findAllPages :: Repository -> RevNum -> IO (Set PageName)
  57 findAllPages _     0   = findAllDefaultPages
  58 findAllPages repos rev = do reposPages   <- findAllPagesInRevision repos rev
  59                             defaultPages <- findAllDefaultPages
  60                             return (reposPages `S.union` defaultPages)
  61
  62
  63 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
  64 findChangedPages repos 0      newRev = findAllPages repos newRev
  65 findChangedPages repos oldRev newRev
  66     = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
  67       >>=
  68       return . S.unions
  69
  70
  71 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
  72 getDirContents' repos name rev
  73     = do reposPages   <- getDirContentsInRevision repos name rev
  74          defaultPages <- getDefaultDirContents name
  75          return $ S.toList (reposPages `S.union` defaultPages)
  76
  77
  78 getCurrentRevNum :: Repository -> IO RevNum
  79 getCurrentRevNum repos
  80     = getRepositoryFS repos >>= getYoungestRev
  81
  82
  83 getAttachment' :: Attachment a =>
  84                   Repository
  85                -> PageName
  86                -> String
  87                -> Maybe RevNum
  88                -> IO (Maybe a)
  89 getAttachment' = loadAttachmentInRepository
  90
  91
  92 putAttachment' :: Attachment a =>
  93                   Repository
  94                -> Maybe String
  95                -> Maybe RevNum
  96                -> PageName
  97                -> String
  98                -> a
  99                -> IO StatusCode
 100 putAttachment' = putAttachmentIntoRepository
 101
 102
 103 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
 104 startIndexManager lsdir repos mkDraft
 105     = do chan  <- newTChanIO
 106          index <- openIndex indexDir revFile
 107          forkIO (loop chan index)
 108          return chan
 109     where
 110       indexDir = lsdir </> "index"
 111       revFile  = lsdir </> "indexRev"
 112
 113       loop :: TChan IndexReq -> Database -> IO ()
 114       loop chan index
 115           = do req <- atomically $ readTChan chan
 116                case req of
 117                  RebuildIndex
 118                      -> do noticeM logger "Rebuilding the H.E. index..."
 119                            closeDatabase index
 120                            removeDirectoryRecursive indexDir
 121                            index' <- openIndex indexDir revFile
 122                            syncIndex' index' revFile repos mkDraft
 123                            loop chan index'
 124
 125                  SyncIndex
 126                      -> do syncIndex' index revFile repos mkDraft
 127                            loop chan index
 128
 129                  SearchIndex cond var
 130                      -> do result <- searchIndex index cond
 131                            atomically $ putTMVar var result
 132                            loop chan index
 133
 134
 135 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
 136 -- indexDir と revFile を削除してから casket を R/W モードで開く。
 137 openIndex :: FilePath -> FilePath -> IO Database
 138 openIndex indexDir revFile
 139     = do ret <- openDatabase indexDir (Writer [])
 140          case ret of
 141            Right index
 142                -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
 143                      return index
 144
 145            Left err
 146                -> do noticeM logger ("Failed to open an H.E. index on "
 147                                      ++ indexDir ++ ": " ++ show err)
 148
 149                      indexExists <- doesDirectoryExist indexDir
 150                      when indexExists
 151                               $ removeDirectoryRecursive indexDir
 152
 153                      revFileExists <- doesFileExist revFile
 154                      when revFileExists
 155                               $ removeFile revFile
 156
 157                      Right index <- openDatabase indexDir (Writer [Create []])
 158                      addAttrIndex index "@type"          StrIndex
 159                      addAttrIndex index "@uri"           SeqIndex
 160                      addAttrIndex index "rakka:revision" SeqIndex
 161                      addAttrIndex index "rakka:isTheme"  StrIndex
 162                      addAttrIndex index "rakka:isFeed"   StrIndex
 163                      noticeM logger ("Created an H.E. index on " ++ indexDir)
 164
 165                      return index
 166
 167
 168 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
 169 syncIndex' index revFile repos mkDraft
 170     = updateIndexRev revFile $ \ oldRev ->
 171       do debugM logger ("The index revision is currently " ++ show oldRev)
 172
 173          newRev <- getCurrentRevNum repos
 174          debugM logger ("The repository revision is currently " ++ show newRev)
 175
 176          when (oldRev == 0 || newRev /= oldRev)
 177               $ syncIndex'' oldRev newRev
 178          return newRev
 179     where
 180       syncIndex'' :: RevNum -> RevNum -> IO ()
 181       syncIndex'' oldRev newRev
 182           = do pages <- findChangedPages repos oldRev newRev
 183                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 184
 185
 186 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
 187 searchIndex index cond
 188     = searchDatabase index cond >>= mapM fromId
 189     where
 190       fromId :: DocumentID -> IO (PageName, RevNum)
 191       fromId docId
 192           = do uri <- getDocURI index docId
 193                rev <- getDocAttr index docId "rakka:revision"
 194                       >>= return . read . fromJust
 195                return (decodePageName $ uriPath uri, rev)
 196
 197
 198 updateIndex :: Database
 199             -> Repository
 200             -> (Page -> IO Document)
 201             -> RevNum
 202             -> PageName
 203             -> IO ()
 204 updateIndex index repos mkDraft rev name
 205     = do pageM <- getPage' repos name (Just rev)
 206          case pageM of
 207            -- ページが削除された
 208            Nothing
 209                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 210                      case docIdM of
 211                        Nothing    -> return ()
 212                        Just docId -> do removeDocument index docId [CleaningRemove]
 213                                         infoM logger ("Removed page " ++ name ++ " from the index")
 214            Just page
 215                -> do draft <- mkDraft page
 216                      putDocument index draft [CleaningPut]
 217                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 218
 219
 220 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 221 updateIndexRev revFile f = withFile revFile ReadWriteMode update
 222     where
 223       update :: Handle -> IO ()
 224       update h = do eof  <- hIsEOF h
 225                     rev  <- if eof then
 226                                 return 0
 227                             else
 228                                 hGetLine h >>= return . read
 229                     rev' <- f rev
 230                     hSeek h AbsoluteSeek 0
 231                     hSetFileSize h 0
 232                     hPutStrLn h (show rev')