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 "@type"          StrIndex
 135                      addAttrIndex index "@uri"           SeqIndex
 136                      addAttrIndex index "rakka:revision" SeqIndex
 137                      noticeM logger ("Created an H.E. index on " ++ indexDir)
 138
 139                      return index
 140
 141
 142 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
 143 syncIndex' index revFile repos mkDraft
 144     = updateIndexRev revFile $ \ oldRev ->
 145       do debugM logger ("The index revision is currently " ++ show oldRev)
 146
 147          newRev <- getCurrentRevNum repos
 148          debugM logger ("The repository revision is currently " ++ show newRev)
 149
 150          when (oldRev == 0 || newRev /= oldRev)
 151               $ syncIndex'' oldRev newRev
 152          return newRev
 153     where
 154       syncIndex'' :: RevNum -> RevNum -> IO ()
 155       syncIndex'' oldRev newRev
 156           = do pages <- findChangedPages repos oldRev newRev
 157                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 158
 159
 160 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
 161 searchIndex index cond
 162     = searchDatabase index cond >>= mapM fromId
 163     where
 164       fromId :: DocumentID -> IO (PageName, RevNum)
 165       fromId docId
 166           = do uri <- getDocURI index docId
 167                rev <- getDocAttr index docId "rakka:revision"
 168                       >>= return . read . fromJust
 169                return (decodePageName $ uriPath uri, rev)
 170
 171
 172 updateIndex :: Database
 173             -> Repository
 174             -> (Page -> IO Document)
 175             -> RevNum
 176             -> PageName
 177             -> IO ()
 178 updateIndex index repos mkDraft rev name
 179     = do pageM <- getPage' repos name (Just rev)
 180          case pageM of
 181            -- ページが削除された
 182            Nothing
 183                -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
 184                      case docIdM of
 185                        Nothing    -> return ()
 186                        Just docId -> do removeDocument index docId [CleaningRemove]
 187                                         infoM logger ("Removed page " ++ name ++ " from the index")
 188            Just page
 189                -> do draft <- mkDraft page
 190                      putDocument index draft [CleaningPut]
 191                      infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
 192
 193
 194 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 195 updateIndexRev revFile f = withFile revFile ReadWriteMode update
 196     where
 197       update :: Handle -> IO ()
 198       update h = do eof  <- hIsEOF h
 199                     rev  <- if eof then
 200                                 return 0
 201                             else
 202                                 hGetLine h >>= return . read
 203                     rev' <- f rev
 204                     hSeek h AbsoluteSeek 0
 205                     hSetFileSize h 0
 206                     hPutStrLn h (show rev')