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