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