Rakka/Storage/Impl.hs

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