slowly emerging to functionality

This commit is contained in:
nek0 2015-10-17 03:09:04 +02:00
parent 1ce1ae4da8
commit ee0ca0bf94
4 changed files with 80 additions and 82 deletions

View file

@ -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")

View file

@ -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
View 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}

View file

@ -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}