-- eidolon -- A simple gallery in Haskell and Yesod -- Copyright (C) 2015 Amedeo Molnár -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published -- by the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Handler.Search where import Import import Handler.Commons import Data.Time.Clock import Data.Aeson import Data.Maybe import qualified Data.Text as T import Database.Bloodhound import Network.HTTP.Client (responseBody) import System.FilePath.Posix getSearchR :: Handler Html getSearchR = do ((res, widget), _) <- runFormGet searchForm case res of FormSuccess query -> do (ru, ra, rm, rc) <- getResults query let a = decode (responseBody ru) :: Maybe (SearchResult SearchUser) let b = decode (responseBody ra) :: Maybe (SearchResult SearchAlbum) let c = decode (responseBody rm) :: Maybe (SearchResult SearchMedium) let d = decode (responseBody rc) :: Maybe (SearchResult SearchComment) let hitListA = case a of { Just as -> hits $ searchHits as; Nothing -> []} let hitListB = case b of { Just bs -> hits $ searchHits bs; Nothing -> []} let hitListC = case c of { Just cs -> hits $ searchHits cs; Nothing -> []} let hitListD = case d of { Just ds -> hits $ searchHits ds; Nothing -> []} userIdList <- return $ mapMaybe (\h -> do if hitIndex h == IndexName "user" then do DocId theId <- return $ hitDocId h Just $ (packKey theId :: UserId) else Nothing ) hitListA albumIdList <- return $ mapMaybe (\h -> do if hitIndex h == IndexName "album" then do DocId theId <- return $ hitDocId h Just $ (packKey theId :: AlbumId) else Nothing ) hitListB mediumIdList <- return $ mapMaybe (\h -> do if hitIndex h == IndexName "medium" then do DocId theId <- return $ hitDocId h Just $ (packKey theId :: MediumId) else Nothing ) hitListC commentIdList <- return $ mapMaybe (\h -> do if hitIndex h == IndexName "comment" then do DocId theId <- return $ hitDocId h Just $ (packKey theId :: CommentId) else Nothing ) hitListD 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 $ do setTitle $ toHtml $ "Eidolon :: Search results for " ++ (T.unpack query) $(widgetFile "result") _ -> defaultLayout $ do setTitle "Eidolon :: Search" $(widgetFile "search") searchForm :: Form T.Text searchForm = renderDivs $ areq (searchField True) "Search" Nothing getResults :: Text -> Handler (Reply, Reply, Reply, Reply) getResults query = do esQuery <- return $ QueryFuzzyLikeThisQuery $ FuzzyLikeThisQuery { fuzzyLikeFields = [FieldName "_all"] , fuzzyLikeText = query , fuzzyLikeMaxQueryTerms = MaxQueryTerms 25 , fuzzyLikeIgnoreTermFrequency = IgnoreTermFrequency False , fuzzyLikeFuzziness = Fuzziness 0.6 , fuzzyLikePrefixLength = PrefixLength 0 , fuzzyLikeBoost = Boost 1.0 , fuzzyLikeAnalyzer = Nothing } su <- runBH' $ searchByIndex (IndexName "user") $ mkSearch (Just esQuery) Nothing sa <- runBH' $ searchByIndex (IndexName "album") $ mkSearch (Just esQuery) Nothing sm <- runBH' $ searchByIndex (IndexName "medium") $ mkSearch (Just esQuery) Nothing sc <- runBH' $ searchByIndex (IndexName "comment") $ mkSearch (Just esQuery) Nothing return (su, sa, sm, sc) data SearchUser = SearchUser { suName :: T.Text , suSlug :: T.Text } instance FromJSON SearchUser where parseJSON (Object o) = SearchUser <$> o .: "name" <*> o .: "slug" parseJSON _ = mempty data SearchAlbum = SearchAlbum { saName :: T.Text } instance FromJSON SearchAlbum where parseJSON (Object o) = SearchAlbum <$> o .: "name" parseJSON _ = mempty data SearchMedium = SearchMedium { smName :: Text , smTime :: UTCTime , smDescription :: Textarea , smTags :: [T.Text] } instance FromJSON SearchMedium where parseJSON (Object o) = SearchMedium <$> o .: "name" <*> o .: "time" <*> o .: "description" <*> o .: "tags" parseJSON _ = mempty data SearchComment = SearchComment { scAuthor :: Text , scTime :: UTCTime , scContent :: Text } instance FromJSON SearchComment where parseJSON (Object o) = SearchComment <$> o .: "author" <*> o .: "time" <*> o .: "content" parseJSON _ = mempty