slowly emerging to functionality
This commit is contained in:
nek0
parent
1ce1ae4da8
commit
ee0ca0bf94
4 changed files with 80 additions and 82 deletions
|
|
@ -1,16 +1,12 @@
|
|||
module Handler.Search where
|
||||
|
||||
import Import
|
||||
import Helper
|
||||
import Data.Time.Clock
|
||||
import Data.Aeson
|
||||
import Data.Maybe
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import qualified Data.Text as T
|
||||
import Database.Bloodhound
|
||||
import Database.Bloodhound.Client
|
||||
import Network.HTTP.Client (defaultManagerSettings, responseBody)
|
||||
import Network.HTTP.Client (responseBody)
|
||||
|
||||
getSearchR :: Handler Html
|
||||
getSearchR = do
|
||||
|
|
@ -18,11 +14,11 @@ getSearchR = do
|
|||
results <-
|
||||
case res of
|
||||
FormSuccess query -> do
|
||||
res <- getResults query
|
||||
a <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchUser))
|
||||
b <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchAlbum))
|
||||
c <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchMedium))
|
||||
d <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchComment))
|
||||
r <- getResults query
|
||||
a <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchUser))
|
||||
b <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchAlbum))
|
||||
c <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchMedium))
|
||||
d <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchComment))
|
||||
return $ Just (a, b, c, d)
|
||||
_ -> return $ Nothing
|
||||
case results of
|
||||
|
|
@ -75,19 +71,14 @@ getSearchR = do
|
|||
else
|
||||
Nothing
|
||||
) hitListD
|
||||
userList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [UserId ==. a] []) userIdList
|
||||
albumList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [AlbumId ==. a] []) albumIdList
|
||||
mediumList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [MediumId ==. a] []) mediumIdList
|
||||
commentList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [CommentId ==. a] []) commentIdList
|
||||
let allEmpty = (null userList && null albumList && null mediumList && null commentList)
|
||||
userList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [UserId ==. i] []) userIdList
|
||||
albumList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [AlbumId ==. i] []) albumIdList
|
||||
mediumList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [MediumId ==. i] []) mediumIdList
|
||||
commentList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [CommentId ==. i] []) commentIdList
|
||||
let allEmpty = (null userList) && (null albumList) && (null mediumList) && (null commentList)
|
||||
defaultLayout $
|
||||
$(widgetFile "search")
|
||||
Nothing -> do
|
||||
let userList = []
|
||||
let albumList = []
|
||||
let mediumList = []
|
||||
let commentList = []
|
||||
let allEmpty = True
|
||||
$(widgetFile "result")
|
||||
Nothing ->
|
||||
defaultLayout $
|
||||
$(widgetFile "search")
|
||||
|
||||
|
|
|
|||
27
Helper.hs
27
Helper.hs
|
|
@ -215,35 +215,35 @@ putIndexES input = do
|
|||
ESUser uId user -> do
|
||||
ex <- runBH' $ indexExists (IndexName "user")
|
||||
when (not ex) ((\ _ -> do
|
||||
runBH' $ createIndex defaultIndexSettings (IndexName "user")
|
||||
runBH' $ createIndex singleIndexSettings (IndexName "user")
|
||||
return ()
|
||||
) ex)
|
||||
_ <- runBH' $ openIndex (IndexName "user")
|
||||
runBH' $ indexDocument (IndexName "user") (MappingName "object") defaultIndexDocumentSettings user (DocId $ extractKey uId)
|
||||
runBH' $ indexDocument (IndexName "user") (MappingName "user") defaultIndexDocumentSettings user (DocId $ extractKey uId)
|
||||
ESAlbum aId album -> do
|
||||
ex <- runBH' $ indexExists (IndexName "album")
|
||||
when (not ex) ((\ _ -> do
|
||||
runBH' $ createIndex defaultIndexSettings (IndexName "album")
|
||||
runBH' $ createIndex singleIndexSettings (IndexName "album")
|
||||
return ()
|
||||
) ex)
|
||||
_ <- runBH' $ openIndex (IndexName "album")
|
||||
runBH' $ indexDocument (IndexName "album") (MappingName "object") defaultIndexDocumentSettings album (DocId $ extractKey aId)
|
||||
runBH' $ indexDocument (IndexName "album") (MappingName "album") defaultIndexDocumentSettings album (DocId $ extractKey aId)
|
||||
ESMedium mId medium -> do
|
||||
ex <- runBH' $ indexExists (IndexName "medium")
|
||||
when (not ex) ((\ _ -> do
|
||||
runBH' $ createIndex defaultIndexSettings (IndexName "medium")
|
||||
runBH' $ createIndex singleIndexSettings (IndexName "medium")
|
||||
return ()
|
||||
) ex)
|
||||
_ <- runBH' $ openIndex (IndexName "medium")
|
||||
runBH' $ indexDocument (IndexName "medium") (MappingName "object") defaultIndexDocumentSettings medium (DocId $ extractKey mId)
|
||||
runBH' $ indexDocument (IndexName "medium") (MappingName "medium") defaultIndexDocumentSettings medium (DocId $ extractKey mId)
|
||||
ESComment cId comment -> do
|
||||
ex <- runBH' $ indexExists (IndexName "comment")
|
||||
when (not ex) ((\ _ -> do
|
||||
runBH' $ createIndex defaultIndexSettings (IndexName "comment")
|
||||
runBH' $ createIndex singleIndexSettings (IndexName "comment")
|
||||
return ()
|
||||
) ex)
|
||||
_ <- runBH' $ openIndex (IndexName "comment")
|
||||
runBH' $ indexDocument (IndexName "comment") (MappingName "object") defaultIndexDocumentSettings comment (DocId $ extractKey cId)
|
||||
runBH' $ indexDocument (IndexName "comment") (MappingName "comment") defaultIndexDocumentSettings comment (DocId $ extractKey cId)
|
||||
case statusCode (responseStatus resp) of
|
||||
201 -> return ()
|
||||
-- 200 -> return ()
|
||||
|
|
@ -253,13 +253,13 @@ putIndexES input = do
|
|||
deleteIndexES input = do
|
||||
resp <- case input of
|
||||
ESUser uId user ->
|
||||
runBH' $ deleteDocument (IndexName "user") (MappingName "object") (DocId $ extractKey uId)
|
||||
runBH' $ deleteDocument (IndexName "user") (MappingName "user") (DocId $ extractKey uId)
|
||||
ESAlbum aId album ->
|
||||
runBH' $ deleteDocument (IndexName "album") (MappingName "object") (DocId $ extractKey aId)
|
||||
runBH' $ deleteDocument (IndexName "album") (MappingName "album") (DocId $ extractKey aId)
|
||||
ESMedium mId medium ->
|
||||
runBH' $ deleteDocument (IndexName "medium") (MappingName "object") (DocId $ extractKey mId)
|
||||
runBH' $ deleteDocument (IndexName "medium") (MappingName "medium") (DocId $ extractKey mId)
|
||||
ESComment cId comment ->
|
||||
runBH' $ deleteDocument (IndexName "comment") (MappingName "object") (DocId $ extractKey cId)
|
||||
runBH' $ deleteDocument (IndexName "comment") (MappingName "comment") (DocId $ extractKey cId)
|
||||
case statusCode (responseStatus resp) of
|
||||
201 -> return ()
|
||||
-- 200 -> return ()
|
||||
|
|
@ -269,3 +269,6 @@ runBH' action = do
|
|||
let server = Server "http://localhost:9200"
|
||||
manager <- newManager defaultManagerSettings
|
||||
runBH (BHEnv server manager) action
|
||||
|
||||
singleIndexSettings :: IndexSettings
|
||||
singleIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 1)
|
||||
|
|
|
|||
52
templates/result.hamlet
Executable file
52
templates/result.hamlet
Executable file
|
|
@ -0,0 +1,52 @@
|
|||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<form method=GET action=@{SearchR}>
|
||||
^{widget}
|
||||
<input type="submit" value="Search">
|
||||
|
||||
$if allEmpty
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Sorry, no results
|
||||
$else
|
||||
$if not $ null userList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Users:
|
||||
$forall (Entity uId user) <- userList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{ProfileR uId}>
|
||||
#{userSlug user}
|
||||
$if not $ null albumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Albums:
|
||||
$forall (Entity aId album) <- albumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{AlbumR aId}>
|
||||
#{albumTitle album}
|
||||
$if not $ null mediumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Media:
|
||||
$forall (Entity mId medium) <- mediumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{MediumR mId}>
|
||||
#{mediumTitle medium}
|
||||
$if not $ null commentList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Comments:
|
||||
$forall (Entity _ comment) <- commentList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{MediumR $ commentOrigin comment}>
|
||||
#{commentContent comment}
|
||||
|
|
@ -3,51 +3,3 @@
|
|||
<form method=GET action=@{SearchR}>
|
||||
^{widget}
|
||||
<input type="submit" value="Search">
|
||||
|
||||
$if not (isNothing results)
|
||||
$if allEmpty
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Sorry, no results
|
||||
$else
|
||||
$if not $ null userList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Users:
|
||||
$forall (Entity uId user) <- userList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{ProfileR uId}>
|
||||
#{userSlug user}
|
||||
$if not $ null albumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Albums:
|
||||
$forall (Entity aId album) <- albumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{AlbumR aId}>
|
||||
#{albumTitle album}
|
||||
$if not $ null mediumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Media:
|
||||
$forall (Entity mId medium) <- mediumList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{MediumR mId}>
|
||||
#{mediumTitle medium}
|
||||
$if not $ null commentList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<h1>
|
||||
Results in Comments:
|
||||
$forall (Entity cId comment) <- commentList
|
||||
<div #header .item data-width="400">
|
||||
<div .inner>
|
||||
<a href=@{MediumR $ commentOrigin comment}>
|
||||
#{commentContent comment}
|
||||
|
|
|
|||
Loading…
Reference in a new issue