eidolon/Handler/Search.hs

145 lines
4.5 KiB
Haskell
Executable file

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)
getSearchR :: Handler Html
getSearchR = do
((res, widget), _) <- runFormGet searchForm
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))
return $ Just (a, b, c, d)
_ -> return $ Nothing
case results of
Just (a, b, c, d) -> do
hitListA <- case a of
Just as -> return $ hits $ searchHits as
Nothing -> return []
hitListB <- case b of
Just bs -> return $ hits $ searchHits bs
Nothing -> return []
hitListC <- case c of
Just cs -> return $ hits $ searchHits cs
Nothing -> return []
hitListD <- case d of
Just ds -> return $ hits $ searchHits ds
Nothing -> return []
userIdList <- return $ catMaybes $ map (\h -> do
if
hitIndex h == IndexName "user"
then do
DocId theId <- return $ hitDocId h
Just $ (packKey theId :: UserId)
else
Nothing
) hitListA
albumIdList <- return $ catMaybes $ map (\h -> do
if
hitIndex h == IndexName "album"
then do
DocId theId <- return $ hitDocId h
Just $ (packKey theId :: AlbumId)
else
Nothing
) hitListB
mediumIdList <- return $ catMaybes $ map (\h -> do
if
hitIndex h == IndexName "medium"
then do
DocId theId <- return $ hitDocId h
Just $ (packKey theId :: MediumId)
else
Nothing
) hitListC
commentIdList <- return $ catMaybes $ map (\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 (\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)
defaultLayout $
$(widgetFile "search")
Nothing -> do
let userList = []
let albumList = []
let mediumList = []
let commentList = []
let allEmpty = True
defaultLayout $
$(widgetFile "search")
searchForm :: Form T.Text
searchForm = renderDivs $ areq (searchField True) "Search" Nothing
getResults query = do
let esQuery = QuerySimpleQueryStringQuery (SimpleQueryStringQuery (QueryString query) Nothing Nothing Nothing Nothing Nothing Nothing)
liftIO $ runBH' $ searchAll $ mkSearch (Just esQuery) Nothing
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