Yesod Sphinx search example

sphinx.hs

{-
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:&nbsp;
    <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 '<' = "&lt;"
    escapeChar '>' = "&gt;"
    escapeChar '&' = "&amp;"
    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