+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
module Rakka.Storage.Impl
( getPage'
, putPage'
, putAttachment'
)
where
-
+import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
+import Control.Exception
import Control.Monad
import Data.Maybe
+import Data.Monoid.Unicode
import Data.Set (Set)
import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Network.URI
import Prelude hiding (words)
+import Prelude.Unicode
import Rakka.Attachment
import Rakka.Page
import Rakka.Storage.DefaultPage
import Rakka.Storage.Repos
import Rakka.Storage.Types
-import Rakka.W3CDateTime
import Subversion.Types
import Subversion.FileSystem
import Subversion.Repository
startIndexManager lsdir repos mkDraft
= do chan <- newTChanIO
index <- openIndex indexDir revFile
- forkIO (loop chan index)
+ _ <- forkIO (loop chan index `finally` closeDatabase index)
return chan
where
indexDir = lsdir </> "index"
mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
-searchIndex :: Database -> Condition -> IO SearchResult
+searchIndex ∷ Database → Condition → IO SearchResult
searchIndex index cond
- = do (ids, hint) <- searchDatabase' index cond
+ = do (ids, hint) ← searchDatabase' index cond
let (total, words) = parseHint hint
- pages <- mapM (fromId words) ids
+ pages ← mapM (fromId words) ids
return SearchResult {
srTotal = total
, srPages = pages
}
where
- parseHint :: [(String, Int)] -> (Int, [String])
+ parseHint ∷ [(Text, Int)] → (Int, [Text])
parseHint xs
= let total = fromJust $ lookup "" xs
- words = filter (/= "") $ map fst xs
+ words = filter ((¬) ∘ T.null) $ map fst xs
in
(total, words)
- fromId :: [String] -> DocumentID -> IO HitPage
+ fromId ∷ [Text] → DocumentID → IO HitPage
fromId words docId
- = do uri <- getDocURI index docId
- rev <- unsafeInterleaveIO $
- liftM (read . fromJust)
- (getDocAttr index docId "rakka:revision")
- lastMod <- unsafeInterleaveIO $
- liftM (zonedTimeToUTC . fromJust . parseW3CDateTime . fromJust)
- (getDocAttr index docId "@mdate")
- summary <- unsafeInterleaveIO $
- getDocAttr index docId "rakka:summary"
- snippet <- unsafeInterleaveIO $
- do doc <- getDocument index docId [NoAttributes, NoKeywords]
- sn <- makeSnippet doc words 300 80 80
- return (trim (== Boundary) $ map toFragment sn)
- return HitPage {
- hpPageName = decodePageName $ uriPath uri
- , hpPageRev = rev
- , hpLastMod = lastMod
- , hpSummary = summary
- , hpSnippet = snippet
- }
-
- toFragment :: Either String (String, String) -> SnippetFragment
- toFragment (Left "") = Boundary
- toFragment (Left t) = NormalText t
+ = do uri ← getDocURI index docId
+ rev ← unsafeInterleaveIO $
+ -- FIXME: use Data.Text.Read
+ read ∘ T.unpack ∘ fromJust
+ <$> getDocAttr index docId "rakka:revision"
+ lastMod ← unsafeInterleaveIO $
+ zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ T.unpack ∘ fromJust
+ <$> getDocAttr index docId "@mdate"
+ summary ← unsafeInterleaveIO $
+ getDocAttr index docId "rakka:summary"
+ snippet ← unsafeInterleaveIO $
+ do doc ← getDocument index docId [NoAttributes, NoKeywords]
+ sn ← makeSnippet doc words 300 80 80
+ pure (trim (≡ Boundary) $ map toFragment sn)
+ pure HitPage {
+ hpPageName = decodePageName $ uriPath uri
+ , hpPageRev = rev
+ , hpLastMod = lastMod
+ , hpSummary = summary
+ , hpSnippet = snippet
+ }
+ toFragment ∷ Either Text (Text, Text) -> SnippetFragment
+ toFragment (Left "" ) = Boundary
+ toFragment (Left t ) = NormalText t
toFragment (Right (w, _)) = HighlightedWord w
-
updateIndex :: Database
-> Repository
-> (Page -> IO Document)
case docIdM of
Nothing -> return ()
Just docId -> do removeDocument index docId [CleaningRemove]
- infoM logger ("Removed page " ++ name ++ " from the index")
+ infoM logger ("Removed page " ⊕ T.unpack name ⊕ " from the index")
Just page
-> do draft <- mkDraft page
putDocument index draft [CleaningPut]
- infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
+ infoM logger ("Indexed page " ⊕ T.unpack name ⊕ " of revision " ⊕ show (pageRevision page))
updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()