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

propagated search, fucking thing still does't work.

Browse source
This commit is contained in:
nek0 2015-10-16 21:57:18 +02:00
parent 6c40597ae8
commit 1ce1ae4da8
10 changed files with 275 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
Handler/AdminAlbumSettings.hs
View file

@ -97,6 +97,7 @@ postAdminAlbumSettingsR albumId = do
, AlbumSamplePic =. albumSamplePic temp
, AlbumSampleWidth =. width
]
liftIO $ putIndexES (ESAlbum albumId temp)
setMessage "Album settings changed successfully"
redirect AdminR
_ -> do
@ -144,10 +145,23 @@ getAdminAlbumDeleteR albumId = do
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] []
_ <- mapM (runDB . delete . entityKey) commEnts
_ <- mapM (\c -> do
-- delete comment from elasticsearch
children <- runDB $ selectList [CommentParent ==. (Just $ entityKey c)] []
_ <- mapM (\child -> do
-- delete comment children from elasticsearch and db
liftIO $ deleteIndexES (ESComment (entityKey child) (entityVal child))
runDB $ delete $ entityKey child
) children
liftIO $ deleteIndexES (ESComment (entityKey c) (entityVal c))
runDB $ delete $ entityKey c) commEnts
-- delete album from elasticsearch
liftIO $ deleteIndexES (ESAlbum albumId album)
-- delete album database entry
runDB $ delete a
) (albumContent album)
-- delete from elasticsearch
liftIO $ deleteIndexES (ESAlbum albumId album)
-- delete album
runDB $ delete albumId
-- delete files

7
Handler/AdminComments.hs
View file

@ -43,11 +43,14 @@ getAdminCommentDeleteR commentId = do
Right _ -> do
tempComment <- runDB $ get commentId
case tempComment of
Just _ -> do
Just comment -> do
-- delete comment children
children <- runDB $ selectList [CommentParent ==. Just commentId] []
_ <- mapM (runDB . delete . entityKey) children
_ <- mapM (\child -> do
liftIO $ deleteIndexES (ESComment (entityKey child) (entityVal child))
runDB $ delete $ entityKey child) children
-- delete comment itself
liftIO $ deleteIndexES (ESComment commentId comment)
runDB $ delete commentId
setMessage "Comment deleted succesfully"
redirect AdminR

12
Handler/AdminMediumSettings.hs
View file

@ -71,6 +71,7 @@ postAdminMediumSettingsR mediumId = do
, MediumDescription =. mediumDescription temp
, MediumTags =. mediumTags temp
]
liftIO $ putIndexES $ ESMedium mediumId temp
setMessage "Medium settings changed successfully"
redirect AdminR
_ -> do
@ -115,8 +116,17 @@ getAdminMediumDeleteR mediumId = do
runDB $ update albumId [AlbumContent =. newMediaList]
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
_ <- mapM (runDB . delete . entityKey) commEnts
_ <- mapM (\ent -> do
children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] []
_ <- mapM (\child -> do
-- delete comment children
liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child)
runDB $ delete $ entityKey child
) children
liftIO $ deleteIndexES $ ESComment (entityKey ent) (entityVal ent)
runDB $ delete $ entityKey ent) commEnts
-- delete medium
liftIO $ deleteIndexES $ ESMedium mediumId medium
runDB $ delete mediumId
-- delete files
liftIO $ removeFile (normalise $ tail $ mediumPath medium)

16
Handler/AdminProfileSettings.hs
View file

@ -113,6 +113,7 @@ postAdminProfileSettingsR ownerId = do
, UserEmail =. userEmail temp
, UserAdmin =. userAdmin temp
]
liftIO $ putIndexES $ ESUser ownerId temp
setMessage "User data updated successfully"
redirect AdminR
_ -> do
@ -151,16 +152,27 @@ getAdminProfileDeleteR ownerId = do
_ <- mapM (\med -> do
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
_ <- mapM (runDB . delete . entityKey) commEnts
_ <- mapM (\ent -> do
children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] []
_ <- mapM (\child -> do
-- delete comment children
liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child)
runDB $ delete $ entityKey child
) children
runDB $ delete $ entityKey ent) commEnts
-- delete media files
medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete medium database entry
-- delete medium database entry and search
ium <- runDB $ getJust med
liftIO $ deleteIndexES $ ESMedium med ium
runDB $ delete med
) mediaList
liftIO $ deleteIndexES $ ESAlbum albumId album
runDB $ delete albumId
) albumList
liftIO $ deleteIndexES $ ESUser ownerId owner
runDB $ delete ownerId
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey ownerId)
setMessage "User successfully deleted"

13
Handler/AlbumSettings.hs
View file

@ -195,9 +195,20 @@ postAlbumDeleteR albumId = do
medium <- runDB $ getJust a
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete medium from elasticsearch
liftIO $ deleteIndexES (ESMedium a medium)
-- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] []
_ <- mapM (runDB . delete . entityKey) commEnts
_ <- mapM (\c -> do
children <- runDB $ selectList [CommentParent ==. (Just $ entityKey c)] []
_ <- mapM (\child -> do
-- delete comment children from elasticsearch and db
liftIO $ deleteIndexES (ESComment (entityKey child) (entityVal child))
runDB $ delete $ entityKey child
) children
-- delete comment from elasticsearch
liftIO $ deleteIndexES (ESComment (entityKey c) (entityVal c))
runDB $ delete $ entityKey c) commEnts
runDB $ delete a
) (albumContent album)
-- delete album

5
Handler/Medium.hs
View file

@ -242,7 +242,10 @@ postCommentDeleteR commentId = do
Just "confirm" -> do
-- delete comment children
childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] []
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) childEnts
_ <- mapM (\ent -> do
-- delete comment children from elasticsearch
liftIO $ deleteIndexES (ESComment (entityKey ent) (entityVal ent))
runDB $ delete $ entityKey ent) childEnts
-- delete comment itself
runDB $ delete commentId
-- delete from elasticsearch

14
Handler/ProfileDelete.hs
View file

@ -51,15 +51,27 @@ postProfileDeleteR userId = do
let mediaList = albumContent album
_ <- mapM (\med -> do
commEnts <- runDB $ selectList [CommentOrigin ==. med] []
_ <- mapM (runDB . delete . entityKey) commEnts
_ <- mapM (\ent -> do
children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] []
_ <- mapM (\child -> do
-- delete comment children
liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child)
runDB $ delete $ entityKey child
) children
-- delete comment
liftIO $ deleteIndexES $ ESComment (entityKey ent) (entityVal ent)
runDB $ delete $ entityKey ent) commEnts
medium <- runDB $ getJust med
liftIO $ deleteIndexES (ESMedium med medium)
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
liftIO $ deleteIndexES $ ESMedium med medium
runDB $ delete med
) mediaList
liftIO $ deleteIndexES $ ESAlbum albumId album
runDB $ delete albumId
) albumList
liftIO $ deleteIndexES $ ESUser userId user
runDB $ delete userId
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId)
liftIO $ deleteIndexES (ESUser userId user)

129
Handler/Search.hs
View file

@ -2,9 +2,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)
@ -12,19 +15,131 @@ import Network.HTTP.Client (defaultManagerSettings, responseBody)
getSearchR :: Handler Html
getSearchR = do
((res, widget), _) <- runFormGet searchForm
searchResults <-
results <-
case res of
FormSuccess query -> do
res <- getResults query
return $ L.toStrict $ responseBody res
_ -> return $ C.empty
-- error $ C.unpack searchResults
defaultLayout $
$(widgetFile "search")
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 Text
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

40
Helper.hs
View file

@ -58,6 +58,14 @@ extractKey = extractKey' . keyToValues
extractKey' [PersistInt64 k] = T.pack $ show k
extractKey' _ = ""
packKey :: PersistEntity record => T.Text -> Key record
packKey = keyFromValues' . readText
where
readText t = PersistInt64 $ (fromIntegral $ read $ T.unpack t)
keyFromValues' v = case keyFromValues [v] of
Left err -> error $ T.unpack err
Right k -> k
fromHex :: String -> BL.ByteString
fromHex = BL.pack . hexToWords
where hexToWords (c:c':text) =
@ -205,19 +213,35 @@ multiFileField = Field
putIndexES input = do
resp <- case input of
ESUser uId user -> do
_ <- runBH' $ createIndex defaultIndexSettings (IndexName "user")
ex <- runBH' $ indexExists (IndexName "user")
when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "user")
return ()
) ex)
_ <- runBH' $ openIndex (IndexName "user")
runBH' $ indexDocument (IndexName "user") (MappingName "object") defaultIndexDocumentSettings user (DocId $ extractKey uId)
ESAlbum aId album -> do
_ <- runBH' $ createIndex defaultIndexSettings (IndexName "album")
ex <- runBH' $ indexExists (IndexName "album")
when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "album")
return ()
) ex)
_ <- runBH' $ openIndex (IndexName "album")
runBH' $ indexDocument (IndexName "album") (MappingName "object") defaultIndexDocumentSettings album (DocId $ extractKey aId)
ESMedium mId medium -> do
_ <- runBH' $ createIndex defaultIndexSettings (IndexName "medium")
ex <- runBH' $ indexExists (IndexName "medium")
when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "medium")
return ()
) ex)
_ <- runBH' $ openIndex (IndexName "medium")
runBH' $ indexDocument (IndexName "medium") (MappingName "object") defaultIndexDocumentSettings medium (DocId $ extractKey mId)
ESComment cId comment -> do
_ <- runBH' $ createIndex defaultIndexSettings (IndexName "comment")
ex <- runBH' $ indexExists (IndexName "comment")
when (not ex) ((\ _ -> do
runBH' $ createIndex defaultIndexSettings (IndexName "comment")
return ()
) ex)
_ <- runBH' $ openIndex (IndexName "comment")
runBH' $ indexDocument (IndexName "comment") (MappingName "object") defaultIndexDocumentSettings comment (DocId $ extractKey cId)
case statusCode (responseStatus resp) of
@ -229,13 +253,13 @@ putIndexES input = do
deleteIndexES input = do
resp <- case input of
ESUser uId user ->
runBH' $ deleteDocument (IndexName "user") (MappingName "") (DocId $ extractKey uId)
runBH' $ deleteDocument (IndexName "user") (MappingName "object") (DocId $ extractKey uId)
ESAlbum aId album ->
runBH' $ deleteDocument (IndexName "album") (MappingName "") (DocId $ extractKey aId)
runBH' $ deleteDocument (IndexName "album") (MappingName "object") (DocId $ extractKey aId)
ESMedium mId medium ->
runBH' $ deleteDocument (IndexName "medium") (MappingName "") (DocId $ extractKey mId)
runBH' $ deleteDocument (IndexName "medium") (MappingName "object") (DocId $ extractKey mId)
ESComment cId comment ->
runBH' $ deleteDocument (IndexName "comment") (MappingName "") (DocId $ extractKey cId)
runBH' $ deleteDocument (IndexName "comment") (MappingName "object") (DocId $ extractKey cId)
case statusCode (responseStatus resp) of
201 -> return ()
-- 200 -> return ()

54
templates/search.hamlet
View file

@ -4,10 +4,50 @@
^{widget}
<input type="submit" value="Search">
$if not $ C.null searchResults
<div #header .item data-width="400">
<div .inner>
<h1>
Results:
<p>
#{C.unpack searchResults}
$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}