Created
November 17, 2012 22:34
-
-
Save ArthurClemens/4100838 to your computer and use it in GitHub Desktop.
Yesod Sphinx search example
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{- | |
Sphinx setup: | |
--- | |
Download the latest version from http://sphinxsearch.com/downloads/release/ | |
--- | |
Backup the original conf file at /etc/sphinxsearch/sphinx.conf and create a new one with: | |
source searcher_src { | |
type = xmlpipe2 | |
xmlpipe_command = curl http://localhost:3000/search/xmlpipe | |
} | |
index searcher { | |
source = searcher_src | |
path = /var/lib/sphinxsearch/data/searcher | |
docinfo = extern | |
charset_type = utf-8 | |
} | |
--- | |
Run this file. | |
--- | |
Create the index with: sudo indexer searcher | |
--- | |
Start the search deamon: sudo start sphinxsearch | |
--- | |
-} | |
{-# LANGUAGE OverloadedStrings, TypeFamilies, TemplateHaskell, | |
QuasiQuotes, MultiParamTypeClasses, GADTs, FlexibleContexts | |
#-} | |
import Yesod | |
import Data.Text (Text) | |
import qualified Data.Text as T | |
import Control.Applicative ((<$>), (<*>)) | |
import Database.Persist.Sqlite | |
import Database.Persist.Query.GenericSql (selectSourceConn) | |
import Database.Persist.Store (PersistValue (PersistInt64)) | |
import qualified Text.Search.Sphinx as S | |
import qualified Text.Search.Sphinx.Types as ST | |
import qualified Text.Search.Sphinx.ExcerptConfiguration as E | |
import Data.Maybe (catMaybes) | |
import Control.Monad (forM) | |
import Text.Blaze (preEscapedToMarkup) | |
import qualified Data.Conduit as C | |
import qualified Data.Conduit.List as CL | |
import qualified Data.XML.Types as X | |
import Network.Wai (Response (ResponseSource)) | |
import Network.HTTP.Types (status200) | |
import Text.XML.Stream.Render (renderBuilder, def) | |
import Data.Monoid (mconcat) | |
import Data.Conduit.Pool (takeResource, mrValue, mrReuse) | |
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| | |
Doc | |
title Text | |
content Textarea | |
|] | |
index :: Text | |
index = "searcher" | |
sport :: Int | |
sport = 9312 | |
data App = App ConnectionPool | |
mkYesod "App" [parseRoutes| | |
/ RootR GET | |
/doc/#DocId DocR GET | |
/add-doc AddDocR POST | |
/search SearchR GET | |
/search/xmlpipe XmlpipeR GET | |
|] | |
instance Yesod App | |
instance YesodPersist App where | |
type YesodPersistBackend App = SqlPersist | |
runDB action = do | |
App pool <- getYesod | |
runSqlPool action pool | |
instance RenderMessage App FormMessage where | |
renderMessage _ _ = defaultFormMessage | |
addDocForm :: Html -> MForm App App (FormResult Doc, Widget) | |
addDocForm = renderBootstrap $ Doc | |
<$> areq textField "Title" Nothing | |
<*> areq textareaField "Contents" Nothing | |
searchForm :: Html -> MForm App App (FormResult Text, Widget) | |
searchForm = renderBootstrap $ areq (searchField False) "" Nothing | |
getRootR :: Handler RepHtml | |
getRootR = do | |
docCount <- runDB $ count ([] :: [Filter Doc]) | |
((_, docWidget), _) <- runFormPost addDocForm | |
((_, searchWidget), _) <- runFormGet searchForm | |
bootstrapLayout [whamlet| | |
<h1>Sphinx search example | |
<p>Number of documents: | |
<span .badge> | |
#{show docCount} | |
<h3> | |
Add a new document | |
<form method=post action=@{AddDocR} .form-horizontal> | |
^{docWidget} | |
<div .control-group> | |
<div .controls> | |
<input type=submit .btn value="Add document"> | |
<h3> | |
Search documents | |
<form method=get action=@{SearchR}> | |
^{searchWidget} | |
<input type=submit .btn value=Search> | |
|] | |
postAddDocR :: Handler RepHtml | |
postAddDocR = do | |
((res, docWidget), _) <- runFormPost addDocForm | |
case res of | |
FormSuccess doc -> do | |
docid <- runDB $ insert doc | |
setMessage "Document added" | |
redirect $ DocR docid | |
_ -> bootstrapLayout [whamlet| | |
<h2> | |
Add a new document | |
<form method=post action=@{AddDocR}> | |
<table> | |
^{docWidget} | |
<tr> | |
<td colspan=3> | |
<input type=submit .btn .btn-primary value="Add document"> | |
|] | |
getDocR :: DocId -> Handler RepHtml | |
getDocR docid = do | |
doc <- runDB $ get404 docid | |
bootstrapLayout $ | |
[whamlet| | |
<ul .breadcrumb> | |
<li> | |
<a href="/"> | |
Home | |
<span .divider> | |
/ | |
<li .active> | |
#{docTitle doc} | |
<h1>#{docTitle doc} | |
<div .content>#{docContent doc} | |
|] | |
data Result = Result | |
{ resultId :: DocId | |
, resultTitle :: Text | |
, resultExcerpt :: Html | |
} | |
getResult :: DocId -> Doc -> Text -> IO Result | |
getResult docid doc qstring = do | |
excerpt' <- S.buildExcerpts | |
excerptConfig | |
[escape $ docContent doc] | |
index | |
qstring | |
let excerpt = | |
case excerpt' of | |
ST.Ok bss -> preEscapedToMarkup $ T.concat bss | |
_ -> "" | |
return Result | |
{ resultId = docid | |
, resultTitle = docTitle doc | |
, resultExcerpt = excerpt | |
} | |
where | |
excerptConfig = E.altConfig { E.port = sport } | |
escape :: Textarea -> Text | |
escape = | |
T.concatMap escapeChar . unTextarea | |
where | |
escapeChar '<' = "<" | |
escapeChar '>' = ">" | |
escapeChar '&' = "&" | |
escapeChar c = T.singleton c | |
executeSearch :: Text -> Handler [Result] | |
executeSearch qstring = do | |
res <- liftIO $ S.query config index qstring | |
case res of | |
ST.Ok result -> do | |
let docids = map (Key . PersistInt64 . ST.documentId) $ ST.matches result | |
fmap catMaybes $ runDB $ forM docids $ \docid -> do | |
mdoc <- get docid | |
case mdoc of | |
Nothing -> return Nothing | |
Just doc -> liftIO $ Just <$> getResult docid doc qstring | |
_ -> error $ show res | |
where | |
config = S.defaultConfig | |
{ S.port = sport | |
, S.mode = ST.Any | |
} | |
getSearchR :: Handler RepHtml | |
getSearchR = do | |
((formRes, searchWidget), _) <- runFormGet searchForm | |
searchResults <- | |
case formRes of | |
FormSuccess qstring -> executeSearch qstring | |
_ -> return [] | |
bootstrapLayout $ do | |
toWidget [lucius| | |
.result .excerpt { | |
color: #444; | |
} | |
.result .resultTitle { | |
font-size: 1.1em; | |
} | |
.result .match { | |
font-weight: bold; | |
color: #000; | |
} | |
|] | |
[whamlet| | |
<ul .breadcrumb> | |
<li> | |
<a href="/"> | |
Home | |
<span .divider> | |
/ | |
<li .active> | |
Search | |
<form method=get action=@{SearchR}> | |
^{searchWidget} | |
<input type=submit .btn value=Search> | |
$if not $ null searchResults | |
<h1>Results | |
$forall result <- searchResults | |
<div .result> | |
<a .resultTitle href=@{DocR $ resultId result}>#{resultTitle result} | |
<div .excerpt>#{resultExcerpt result} | |
|] | |
bootstrapLayout :: GWidget s App () -> GHandler s App RepHtml | |
bootstrapLayout widget = do | |
pc <- widgetToPageContent $ do | |
addStylesheetRemote "http://netdna.bootstrapcdn.com/twitter-bootstrap/2.1.0/css/bootstrap-combined.min.css" | |
toWidget [lucius| | |
body { | |
padding: 20px 0; | |
} | |
|] | |
w <- widgetToPageContent widget | |
hamletToRepHtml [hamlet| | |
$doctype 5 | |
<html> | |
<head> | |
<title>#{pageTitle pc} | |
<meta charset=utf-8> | |
^{pageHead w} | |
^{pageHead pc} | |
<body> | |
<div .container> | |
<div .row> | |
^{pageBody w} | |
^{pageBody pc} | |
|] | |
getXmlpipeR :: Handler RepXml | |
getXmlpipeR = do | |
App pool <- getYesod | |
let headers = [("Content-Type", "text/xml")] | |
managedConn <- lift $ takeResource pool | |
let conn = mrValue managedConn | |
lift $ mrReuse managedConn True | |
let source = fullDocSource conn C.$= renderBuilder def | |
flushSource = C.mapOutput C.Chunk source | |
sendWaiResponse $ ResponseSource status200 headers flushSource | |
entityToEvents :: (Entity Doc) -> [X.Event] | |
entityToEvents (Entity docid doc) = | |
[ X.EventBeginElement document [("id", [X.ContentText $ toPathPiece docid])] | |
, X.EventBeginElement title [] | |
, X.EventContent $ X.ContentText $ docTitle doc | |
, X.EventEndElement title | |
, X.EventBeginElement content [] | |
, X.EventContent $ X.ContentText $ unTextarea $ docContent doc | |
, X.EventEndElement content | |
, X.EventEndElement document | |
] | |
fullDocSource :: Connection -> C.Source (C.ResourceT IO) X.Event | |
fullDocSource conn = mconcat | |
[ CL.sourceList startEvents | |
, docSource conn | |
, CL.sourceList endEvents | |
] | |
docSource :: Connection -> C.Source (C.ResourceT IO) X.Event | |
docSource conn = selectSourceConn conn [] [] C.$= CL.concatMap entityToEvents | |
toName :: Text -> X.Name | |
toName x = X.Name x (Just "http://sphinxsearch.com/") (Just "sphinx") | |
docset, schema, field, document, content :: X.Name | |
docset = toName "docset" | |
schema = toName "schema" | |
field = toName "field" | |
document = toName "document" | |
content = "content" -- no prefix | |
title = "title" -- no prefix | |
startEvents, endEvents :: [X.Event] | |
startEvents = | |
[ X.EventBeginDocument | |
, X.EventBeginElement docset [] | |
, X.EventBeginElement schema [] | |
, X.EventBeginElement field [("name", [X.ContentText "title"])] | |
, X.EventEndElement field | |
, X.EventBeginElement field [("name", [X.ContentText "content"])] | |
, X.EventEndElement field | |
, X.EventEndElement schema | |
] | |
endEvents = | |
[ X.EventEndElement docset | |
] | |
main :: IO () | |
main = withSqlitePool "searcher.db3" 10 $ \pool -> do | |
runSqlPool (runMigration migrateAll) pool | |
warpDebug 3000 $ App pool |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment