nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

slowly emerging to functionality

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

35
Handler/Search.hs
View file

@ -1,16 +1,12 @@
module Handler.Search where module Handler.Search where
import Import import Import
import Helper
import Data.Time.Clock import Data.Time.Clock
import Data.Aeson import Data.Aeson
import Data.Maybe 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 qualified Data.Text as T
import Database.Bloodhound import Database.Bloodhound
import Database.Bloodhound.Client import Network.HTTP.Client (responseBody)
import Network.HTTP.Client (defaultManagerSettings, responseBody)
getSearchR :: Handler Html getSearchR :: Handler Html
getSearchR = do getSearchR = do
@ -18,11 +14,11 @@ getSearchR = do
results <- results <-
case res of case res of
FormSuccess query -> do FormSuccess query -> do
res <- getResults query r <- getResults query
a <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchUser)) a <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchUser))
b <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchAlbum)) b <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchAlbum))
c <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchMedium)) c <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchMedium))
d <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchComment)) d <- return $ (decode (responseBody r) :: Maybe (SearchResult SearchComment))
return $ Just (a, b, c, d) return $ Just (a, b, c, d)
_ -> return $ Nothing _ -> return $ Nothing
case results of case results of
@ -75,19 +71,14 @@ getSearchR = do
else else
Nothing Nothing
) hitListD ) hitListD
userList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [UserId ==. a] []) userIdList userList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [UserId ==. i] []) userIdList
albumList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [AlbumId ==. a] []) albumIdList albumList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [AlbumId ==. i] []) albumIdList
mediumList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [MediumId ==. a] []) mediumIdList mediumList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [MediumId ==. i] []) mediumIdList
commentList <- return . catMaybes =<< mapM (\a -> runDB $ selectFirst [CommentId ==. a] []) commentIdList commentList <- return . catMaybes =<< mapM (\i -> runDB $ selectFirst [CommentId ==. i] []) commentIdList
let allEmpty = (null userList && null albumList && null mediumList && null commentList) let allEmpty = (null userList) && (null albumList) && (null mediumList) && (null commentList)
defaultLayout $ defaultLayout $
$(widgetFile "search") $(widgetFile "result")
Nothing -> do Nothing ->
let userList = []
let albumList = []
let mediumList = []
let commentList = []
let allEmpty = True
defaultLayout $ defaultLayout $
$(widgetFile "search") $(widgetFile "search")

27
Helper.hs
View file

@ -215,35 +215,35 @@ putIndexES input = do
ESUser uId user -> do ESUser uId user -> do
ex <- runBH' $ indexExists (IndexName "user") ex <- runBH' $ indexExists (IndexName "user")
when (not ex) ((\ _ -> do when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "user") runBH' $ createIndex singleIndexSettings (IndexName "user")
return () return ()
) ex) ) ex)
_ <- runBH' $ openIndex (IndexName "user") _ <- 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 ESAlbum aId album -> do
ex <- runBH' $ indexExists (IndexName "album") ex <- runBH' $ indexExists (IndexName "album")
when (not ex) ((\ _ -> do when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "album") runBH' $ createIndex singleIndexSettings (IndexName "album")
return () return ()
) ex) ) ex)
_ <- runBH' $ openIndex (IndexName "album") _ <- 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 ESMedium mId medium -> do
ex <- runBH' $ indexExists (IndexName "medium") ex <- runBH' $ indexExists (IndexName "medium")
when (not ex) ((\ _ -> do when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "medium") runBH' $ createIndex singleIndexSettings (IndexName "medium")
return () return ()
) ex) ) ex)
_ <- runBH' $ openIndex (IndexName "medium") _ <- 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 ESComment cId comment -> do
ex <- runBH' $ indexExists (IndexName "comment") ex <- runBH' $ indexExists (IndexName "comment")
when (not ex) ((\ _ -> do when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "comment") runBH' $ createIndex singleIndexSettings (IndexName "comment")
return () return ()
) ex) ) ex)
_ <- runBH' $ openIndex (IndexName "comment") _ <- 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 case statusCode (responseStatus resp) of
201 -> return () 201 -> return ()
-- 200 -> return () -- 200 -> return ()
@ -253,13 +253,13 @@ putIndexES input = do
deleteIndexES input = do deleteIndexES input = do
resp <- case input of resp <- case input of
ESUser uId user -> ESUser uId user ->
runBH' $ deleteDocument (IndexName "user") (MappingName "object") (DocId $ extractKey uId) runBH' $ deleteDocument (IndexName "user") (MappingName "user") (DocId $ extractKey uId)
ESAlbum aId album -> ESAlbum aId album ->
runBH' $ deleteDocument (IndexName "album") (MappingName "object") (DocId $ extractKey aId) runBH' $ deleteDocument (IndexName "album") (MappingName "album") (DocId $ extractKey aId)
ESMedium mId medium -> ESMedium mId medium ->
runBH' $ deleteDocument (IndexName "medium") (MappingName "object") (DocId $ extractKey mId) runBH' $ deleteDocument (IndexName "medium") (MappingName "medium") (DocId $ extractKey mId)
ESComment cId comment -> 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 case statusCode (responseStatus resp) of
201 -> return () 201 -> return ()
-- 200 -> return () -- 200 -> return ()
@ -269,3 +269,6 @@ runBH' action = do
let server = Server "http://localhost:9200" let server = Server "http://localhost:9200"
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
runBH (BHEnv server manager) action 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}

48
templates/search.hamlet
View file

@ -3,51 +3,3 @@
<form method=GET action=@{SearchR}> <form method=GET action=@{SearchR}>
^{widget} ^{widget}
<input type="submit" value="Search"> <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}