From ee0ca0bf94596ab63979a4ffdc9226e3e0f1a9c6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 17 Oct 2015 03:09:04 +0200 Subject: [PATCH] slowly emerging to functionality --- Handler/Search.hs | 35 +++++++++++---------------- Helper.hs | 27 +++++++++++---------- templates/result.hamlet | 52 +++++++++++++++++++++++++++++++++++++++++ templates/search.hamlet | 48 ------------------------------------- 4 files changed, 80 insertions(+), 82 deletions(-) create mode 100755 templates/result.hamlet diff --git a/Handler/Search.hs b/Handler/Search.hs index 1ae0aed..7f3571d 100755 --- a/Handler/Search.hs +++ b/Handler/Search.hs @@ -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") diff --git a/Helper.hs b/Helper.hs index 05d142a..28fe350 100755 --- a/Helper.hs +++ b/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) diff --git a/templates/result.hamlet b/templates/result.hamlet new file mode 100755 index 0000000..4b157f3 --- /dev/null +++ b/templates/result.hamlet @@ -0,0 +1,52 @@ +
+
+
+ ^{widget} + + +$if allEmpty +
+
+

+ Sorry, no results +$else + $if not $ null userList +
+
+

+ Results in Users: + $forall (Entity uId user) <- userList +
+
+ + #{userSlug user} + $if not $ null albumList +
+
+

+ Results in Albums: + $forall (Entity aId album) <- albumList +
+
+ + #{albumTitle album} + $if not $ null mediumList +
+
+

+ Results in Media: + $forall (Entity mId medium) <- mediumList +
+
+ + #{mediumTitle medium} + $if not $ null commentList +
+
+

+ Results in Comments: + $forall (Entity _ comment) <- commentList +