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