Rakka/Storage/Impl.hs

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