diff --git a/Handler/AdminAlbumSettings.hs b/Handler/AdminAlbumSettings.hs index c1fb5d7..fa32e82 100755 --- a/Handler/AdminAlbumSettings.hs +++ b/Handler/AdminAlbumSettings.hs @@ -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 diff --git a/Handler/AdminComments.hs b/Handler/AdminComments.hs index af32475..d81f4c9 100755 --- a/Handler/AdminComments.hs +++ b/Handler/AdminComments.hs @@ -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 diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index 42ce781..956898a 100755 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -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) diff --git a/Handler/AdminProfileSettings.hs b/Handler/AdminProfileSettings.hs index 49dc39d..d566ec0 100755 --- a/Handler/AdminProfileSettings.hs +++ b/Handler/AdminProfileSettings.hs @@ -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" diff --git a/Handler/AlbumSettings.hs b/Handler/AlbumSettings.hs index 39d0232..386ee95 100755 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -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 diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 2b77b88..20cb988 100755 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -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 diff --git a/Handler/ProfileDelete.hs b/Handler/ProfileDelete.hs index d9351f0..76fc77d 100755 --- a/Handler/ProfileDelete.hs +++ b/Handler/ProfileDelete.hs @@ -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) diff --git a/Handler/Search.hs b/Handler/Search.hs index 39b25e4..1ae0aed 100755 --- a/Handler/Search.hs +++ b/Handler/Search.hs @@ -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 diff --git a/Helper.hs b/Helper.hs index d9f055c..05d142a 100755 --- a/Helper.hs +++ b/Helper.hs @@ -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 () diff --git a/templates/search.hamlet b/templates/search.hamlet index 7eff1b5..69f861e 100755 --- a/templates/search.hamlet +++ b/templates/search.hamlet @@ -4,10 +4,50 @@ ^{widget} -$if not $ C.null searchResults -
-
-

- Results: -

- #{C.unpack searchResults} +$if not (isNothing results) + $if allEmpty +

+
+

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