module Search where import Prelude hiding (div,span) import Data.List (intersperse) import Control.Monad (liftM, liftM2) import Text.ParserCombinators.Parsec (parse) import Database.HDBC (SqlValue, toSql) import Text.CxML hiding (title) import Text.YuiGrid import RESTng.RqHandlers import RESTng.System import Resource import InLineCSS import Common (authorsShow, withTitleBox) import Tags (booksShow) searchForm :: CxML RequestContext searchForm = form!("method","post")!("action","/search.html") /- [ textfield "search", button!("name","action")!("value","submit") /- [t "Search"] ] searchHandler :: RqHandlerT RESTng RESTngResp searchHandler = --withDocName "search" $ withQueryField "search" $ \q -> withDocName "search" $ withPostField "search" $ \q -> okBoxesM [ return $ bigText $ smallMarginBottomCSS $ nearTop $ boxInMain $ t ("Found it in: "), liftM (nearLeft . setColumnsVote 2 . commonLayoutHints) $ tagsMatchingBox q, liftM (nearRight . setColumnsVote 2 . commonLayoutHints) $ booksMatchingBox q, liftM (nearBottom . commonLayoutHints) $ authorsMatchingBox q ] where commonLayoutHints = smallMarginBottomCSS . giveBorderCSS . inMain ------------------------------- ---------- Tags matching ----- ------------------------------- tagsMatchingBox :: String -> RESTng (GridElement RequestContext) tagsMatchingBox s = do tagListCxML <- listingResource exampleAppTagProxy [("tag",s)] [] return $ withTitleBox "Tags matching:" tagListCxML ------------------------------- ------ Books matching ----- ------------------------------- booksMatchingBox :: String -> RESTng (GridElement RequestContext) booksMatchingBox s = do books <- booksMatchingData s return $ withTitleBox "Books matching:" $ toBox (booksShow books) booksMatchingData :: String -> RESTng [Book] booksMatchingData s = liftHDBC_0 $ runQueryN sqlRecordParser (booksMatchingQuery s) booksMatchingQuery :: String -> SqlCommand booksMatchingQuery s = addCriterium (inBookExpr `or_` inAuthorExpr) $ sqlSelect [] [] bookProxy where inBookExpr = caseInsensitiveSearchExpr ["title"] s inAuthorExpr = (tableName authorProxy ++ "_id") `in_` (projectJustAttrs ["DISTINCT id"] $ authorsMatchingQuery s) ------------------------------- ------ Authors matching ----- ------------------------------- authorsMatchingBox :: String -> RESTng (GridElement RequestContext) authorsMatchingBox s = do authors <- authorsMatchingData s return $ withTitleBox "Authors:" $ toBox (authorsShow authors) authorsMatchingData :: String -> RESTng [Author] authorsMatchingData s = liftHDBC_0 $ runQueryN sqlRecordParser (authorsMatchingQuery s) -- FIXME: in order to be more DRY, do some runQueryN' such that -- authorsMatchingData s = runQueryN' (authorsMatchingQuery s) -- so the function has type -- runQueryN' :: SqlRecord a => SqlCommand -> RESTng [a] authorsMatchingQuery :: String -> SqlCommand authorsMatchingQuery s = addCriterium (caseInsensitiveSearchExpr ["name"] s) $ sqlSelect [] [] authorProxy --FIXME: can search authors related to authorships containing s here also.