From 6c40597ae819ffeb5ebb7bf53ee0323ce618f3d9 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 16 Oct 2015 15:32:47 +0200 Subject: [PATCH 01/13] starting out with elasticsearch. not working for now --- Application.hs | 1 + Handler/Activate.hs | 2 + Handler/AlbumSettings.hs | 3 ++ Handler/Medium.hs | 8 +++- Handler/MediumSettings.hs | 3 ++ Handler/NewAlbum.hs | 2 + Handler/ProfileDelete.hs | 2 + Handler/ProfileSettings.hs | 1 + Handler/Search.hs | 30 +++++++++++++ Handler/Upload.hs | 8 ++-- Helper.hs | 50 ++++++++++++++++++++++ Model.hs | 87 +++++++++++++++++++++++++++++++++++++- config/routes | 2 + eidolon.cabal | 6 ++- templates/search.hamlet | 13 ++++++ 15 files changed, 211 insertions(+), 7 deletions(-) create mode 100755 Handler/Search.hs create mode 100755 templates/search.hamlet diff --git a/Application.hs b/Application.hs index 1b9d815..fc43a51 100755 --- a/Application.hs +++ b/Application.hs @@ -68,6 +68,7 @@ import Handler.AdminMediumSettings import Handler.AdminComments import Handler.Tag import Handler.RootFeed +import Handler.Search -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Handler/Activate.hs b/Handler/Activate.hs index 13ac7ee..ed7d1fe 100755 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -73,6 +73,8 @@ postActivateR token = do -- create user directory liftIO $ createDirectoryIfMissing True $ "static" "data" unpack (extractKey uId) + -- input user to elasticsearch + liftIO $ putIndexES (ESUser uId $ activatorUser activ) -- cleanup runDB $ delete aId runDB $ delete uTokenId diff --git a/Handler/AlbumSettings.hs b/Handler/AlbumSettings.hs index e72d838..39d0232 100755 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -110,6 +110,7 @@ postAlbumSettingsR albumId = do , AlbumSamplePic =. albumSamplePic temp , AlbumSampleWidth =. width ] + liftIO $ putIndexES (ESAlbum albumId temp) setMessage "Album settings changed succesfully" redirect $ AlbumR albumId _ -> do @@ -203,6 +204,8 @@ postAlbumDeleteR albumId = do runDB $ delete albumId -- delete files liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) T.unpack (extractKey albumId) + -- delete from elasticsearch + liftIO $ deleteIndexES (ESAlbum albumId album) -- outro setMessage "Album deleted succesfully" redirect HomeR diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 65deee1..2b77b88 100755 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -85,7 +85,8 @@ postMediumR mediumId = do ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing case res of FormSuccess temp -> do - _ <- runDB $ insert temp + cId <- runDB $ insert temp + liftIO $ putIndexES (ESComment cId temp) --send mail to medium owner owner <- runDB $ getJust $ mediumOwner medium link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender @@ -158,7 +159,8 @@ postCommentReplyR commentId = do ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId (Just commentId) case res of FormSuccess temp -> do - _ <- runDB $ insert temp + cId <- runDB $ insert temp + liftIO $ putIndexES (ESComment cId temp) --send mail to parent author parent <- runDB $ getJust $ fromJust $ commentParent temp parAuth <- runDB $ getJust $ commentAuthor parent @@ -243,6 +245,8 @@ postCommentDeleteR commentId = do _ <- mapM (\ent -> runDB $ delete $ entityKey ent) childEnts -- delete comment itself runDB $ delete commentId + -- delete from elasticsearch + liftIO $ deleteIndexES (ESComment commentId comment) -- outro setMessage "Your comment has been deleted" redirect $ MediumR $ commentOrigin comment diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index f5991ff..9a71d91 100755 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -49,6 +49,7 @@ postMediumSettingsR mediumId = do , MediumDescription =. mediumDescription temp , MediumTags =. mediumTags temp ] + liftIO $ putIndexES (ESMedium mediumId temp) setMessage "Medium settings changed succesfully" redirect $ MediumR mediumId _ -> do @@ -107,6 +108,8 @@ postMediumDeleteR mediumId = do liftIO $ removeFile (normalise $ tail $ mediumPath medium) liftIO $ removeFile (normalise $ tail $ mediumThumb medium) runDB $ delete mediumId + -- delete form elasticsearch + liftIO $ deleteIndexES (ESMedium mediumId medium) setMessage "Medium succesfully deleted" redirect HomeR _ -> do diff --git a/Handler/NewAlbum.hs b/Handler/NewAlbum.hs index 8959e47..5ea5a78 100755 --- a/Handler/NewAlbum.hs +++ b/Handler/NewAlbum.hs @@ -53,6 +53,8 @@ postNewAlbumR = do runDB $ update userId [UserAlbums =. newAlbumList] -- create folder liftIO $ createDirectory $ "static" "data" unpack (extractKey userId) unpack (extractKey albumId) + -- update elasticsearch + liftIO $ putIndexES (ESAlbum albumId album) -- outro setMessage "Album successfully created" redirect $ ProfileR userId diff --git a/Handler/ProfileDelete.hs b/Handler/ProfileDelete.hs index 339d71e..d9351f0 100755 --- a/Handler/ProfileDelete.hs +++ b/Handler/ProfileDelete.hs @@ -53,6 +53,7 @@ postProfileDeleteR userId = do commEnts <- runDB $ selectList [CommentOrigin ==. med] [] _ <- mapM (runDB . delete . entityKey) commEnts medium <- runDB $ getJust med + liftIO $ deleteIndexES (ESMedium med medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) runDB $ delete med @@ -61,6 +62,7 @@ postProfileDeleteR userId = do ) albumList runDB $ delete userId liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) + liftIO $ deleteIndexES (ESUser userId user) deleteSession "userId" setMessage "User deleted successfully" redirect HomeR diff --git a/Handler/ProfileSettings.hs b/Handler/ProfileSettings.hs index 027285d..19f438f 100755 --- a/Handler/ProfileSettings.hs +++ b/Handler/ProfileSettings.hs @@ -45,6 +45,7 @@ postProfileSettingsR userId = do , UserSlug =. userSlug temp , UserEmail =. userEmail temp ] + liftIO $ putIndexES (ESUser userId temp) setMessage "Profile settings changed successfully" redirect $ UserR $ userName user _ -> do diff --git a/Handler/Search.hs b/Handler/Search.hs new file mode 100755 index 0000000..39b25e4 --- /dev/null +++ b/Handler/Search.hs @@ -0,0 +1,30 @@ +module Handler.Search where + +import Import +import Helper +import Data.Aeson +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy.Char8 as L +import Database.Bloodhound +import Database.Bloodhound.Client +import Network.HTTP.Client (defaultManagerSettings, responseBody) + +getSearchR :: Handler Html +getSearchR = do + ((res, widget), _) <- runFormGet searchForm + searchResults <- + case res of + FormSuccess query -> do + res <- getResults query + return $ L.toStrict $ responseBody res + _ -> return $ C.empty + -- error $ C.unpack searchResults + defaultLayout $ + $(widgetFile "search") + +searchForm :: Form 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 diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 8a5257d..63ccdbe 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -90,6 +90,7 @@ postDirectUploadR albumId = do inALbum <- runDB $ getJust albumId let newMediaList = mId : albumContent inALbum runDB $ update albumId [AlbumContent =. newMediaList] + liftIO $ putIndexES (ESMedium mId medium) return Nothing else return $ Just $ fileName file @@ -189,13 +190,13 @@ getUploadR = do if I.null albums then do + setMessage "Please create an album first" + redirect NewAlbumR + else do (uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId) formLayout $ do setTitle "Eidolon :: Upload Medium" $(widgetFile "bulkUpload") - else do - setMessage "Please create an album first" - redirect NewAlbumR Nothing -> do setMessage "You need to be logged in" redirect LoginR @@ -251,6 +252,7 @@ postUploadR = do inALbum <- runDB $ getJust inAlbumId let newMediaList = mId : albumContent inALbum runDB $ update inAlbumId [AlbumContent =. newMediaList] + liftIO $ putIndexES (ESMedium mId medium) return Nothing else return $ Just $ fileName file diff --git a/Helper.hs b/Helper.hs index ea718cd..d9f055c 100755 --- a/Helper.hs +++ b/Helper.hs @@ -22,6 +22,7 @@ import Model import Data.Maybe import Data.List as L import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import Data.Time @@ -35,6 +36,10 @@ import Network.Mail.Mime import Text.Blaze.Html.Renderer.Utf8 import Graphics.ImageMagick.MagickWand import Filesystem.Path.CurrentOS +import Database.Bloodhound +import Network.HTTP.Client +import Network.HTTP.Types.Status as S +import Control.Monad (when) getUserIdFromText :: T.Text -> UserId getUserIdFromText tempUserId = @@ -195,3 +200,48 @@ multiFileField = Field |] , fieldEnctype = Multipart } + +-- Handler () +putIndexES input = do + resp <- case input of + ESUser uId user -> do + _ <- runBH' $ createIndex defaultIndexSettings (IndexName "user") + _ <- runBH' $ openIndex (IndexName "user") + runBH' $ indexDocument (IndexName "user") (MappingName "object") defaultIndexDocumentSettings user (DocId $ extractKey uId) + ESAlbum aId album -> do + _ <- runBH' $ createIndex defaultIndexSettings (IndexName "album") + _ <- runBH' $ openIndex (IndexName "album") + runBH' $ indexDocument (IndexName "album") (MappingName "object") defaultIndexDocumentSettings album (DocId $ extractKey aId) + ESMedium mId medium -> do + _ <- runBH' $ createIndex defaultIndexSettings (IndexName "medium") + _ <- runBH' $ openIndex (IndexName "medium") + runBH' $ indexDocument (IndexName "medium") (MappingName "object") defaultIndexDocumentSettings medium (DocId $ extractKey mId) + ESComment cId comment -> do + _ <- runBH' $ createIndex defaultIndexSettings (IndexName "comment") + _ <- runBH' $ openIndex (IndexName "comment") + runBH' $ indexDocument (IndexName "comment") (MappingName "object") defaultIndexDocumentSettings comment (DocId $ extractKey cId) + case statusCode (responseStatus resp) of + 201 -> return () + -- 200 -> return () + _ -> error $ C.unpack $ BL.toStrict $ responseBody resp + +-- deleteIndexES :: ESInput -> Handler () +deleteIndexES input = do + resp <- case input of + ESUser uId user -> + runBH' $ deleteDocument (IndexName "user") (MappingName "") (DocId $ extractKey uId) + ESAlbum aId album -> + runBH' $ deleteDocument (IndexName "album") (MappingName "") (DocId $ extractKey aId) + ESMedium mId medium -> + runBH' $ deleteDocument (IndexName "medium") (MappingName "") (DocId $ extractKey mId) + ESComment cId comment -> + runBH' $ deleteDocument (IndexName "comment") (MappingName "") (DocId $ extractKey cId) + case statusCode (responseStatus resp) of + 201 -> return () + -- 200 -> return () + _ -> error $ C.unpack $ BL.toStrict $ responseBody resp + +runBH' action = do + let server = Server "http://localhost:9200" + manager <- newManager defaultManagerSettings + runBH (BHEnv server manager) action diff --git a/Model.hs b/Model.hs index 515796b..2b292ac 100755 --- a/Model.hs +++ b/Model.hs @@ -17,7 +17,7 @@ module Model where import ClassyPrelude.Yesod -import Yesod.Markdown (Markdown) +import Yesod.Markdown (Markdown, unMarkdown) import Database.Persist.Quasi import qualified System.FilePath as FP @@ -27,3 +27,88 @@ import qualified System.FilePath as FP -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "config/models") + +data ESInput = ESUser UserId User + | ESAlbum AlbumId Album + | ESMedium MediumId Medium + | ESComment CommentId Comment + +data FullUser = FullUser + {userRep :: User} + +instance ToJSON User where + toJSON (User name slug _ _ _ _ _) = + object + [ "name" .= name + , "slug" .= slug + ] + +instance ToJSON FullUser where + toJSON (FullUser user) = + object + [ "name" .= (userName user) + , "slug" .= (userSlug user) + , "albums" .= (userAlbums user) + ] + +data FullAlbum = FullAlbum + {albumRep :: Album} + +instance ToJSON Album where + toJSON (Album title _ _ _ _ _) = + object + [ "name" .= title ] + +instance ToJSON FullAlbum where + toJSON (FullAlbum album) = + object + [ "name" .= (albumTitle album) + , "owner" .= (albumOwner album) + , "shares" .= (albumShares album) + , "content" .= (albumContent album) + ] + +data FullMedium = FullMedium + {mediumRep :: Medium} + +instance ToJSON Medium where + toJSON (Medium title _ _ _ time _ desc tags _ _ _ _ _) = + object + [ "name" .= title + , "time" .= time + , "description" .= desc + , "tags" .= tags + ] + +instance ToJSON FullMedium where + toJSON (FullMedium medium) = + object + [ "name" .= (mediumTitle medium) + , "time" .= (mediumTime medium) + , "owner" .= (mediumOwner medium) + , "description" .= (mediumDescription medium) + , "tage" .= (mediumTags medium) + , "album" .= (mediumAlbum medium) + ] + +data FullComment = FullComment + {commentRep :: Comment} + +instance ToJSON Comment where + toJSON (Comment _ slug _ _ time cont) = + object + [ "author" .= slug + , "time" .= time + , "content" .= (unMarkdown cont) + ] + +instance ToJSON FullComment where + toJSON (FullComment comment) = + object + [ "author_id" .= (commentAuthor comment) + , "author" .= (commentAuthorSlug comment) + , "origin" .= (commentOrigin comment) + , "parent" .= (commentParent comment) + , "time" .= (commentTime comment) + , "content" .= (unMarkdown $ commentContent comment) + ] diff --git a/config/routes b/config/routes index 4a15a38..5c1e0e8 100755 --- a/config/routes +++ b/config/routes @@ -70,3 +70,5 @@ /feed/user/#UserId/rss.xml UserFeedRssR GET !/feed/user/#Text/atom.xml NameFeedAtomR GET !/feed/user/#Text/rss.xml NameFeedRssR GET + +/search SearchR GET diff --git a/eidolon.cabal b/eidolon.cabal index 2275b8b..63db7ea 100755 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -1,5 +1,5 @@ name: eidolon -version: 0.0.4 +version: 0.0.5 synopsis: Image gallery in Yesod homepage: https://eidolon.nek0.eu license: AGPL-3 @@ -50,6 +50,7 @@ library Handler.Tag Handler.RootFeed Handler.Commons + Handler.Search if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -114,6 +115,8 @@ library , wai >= 3.0 , yesod-newsfeed >= 1.5 , unix >= 2.7 + , bloodhound >= 0.8 + , http-types -- for Migrations , HDBC , HDBC-postgresql @@ -122,6 +125,7 @@ library , filepath , system-filepath , bytestring + , http-client executable eidolon if flag(library-only) diff --git a/templates/search.hamlet b/templates/search.hamlet new file mode 100755 index 0000000..7eff1b5 --- /dev/null +++ b/templates/search.hamlet @@ -0,0 +1,13 @@ +
+
+
+ ^{widget} + + +$if not $ C.null searchResults +
+
+

+ Results: +

+ #{C.unpack searchResults} From 1ce1ae4da87fee982738386022fc28a031215544 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 16 Oct 2015 21:57:18 +0200 Subject: [PATCH 02/13] propagated search, fucking thing still does't work. --- Handler/AdminAlbumSettings.hs | 16 +++- Handler/AdminComments.hs | 7 +- Handler/AdminMediumSettings.hs | 12 ++- Handler/AdminProfileSettings.hs | 16 +++- Handler/AlbumSettings.hs | 13 +++- Handler/Medium.hs | 5 +- Handler/ProfileDelete.hs | 14 +++- Handler/Search.hs | 129 ++++++++++++++++++++++++++++++-- Helper.hs | 40 ++++++++-- templates/search.hamlet | 54 +++++++++++-- 10 files changed, 275 insertions(+), 31 deletions(-) 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 +
+
+

+ 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 cId comment) <- commentList +
+
+ + #{commentContent comment} From ee0ca0bf94596ab63979a4ffdc9226e3e0f1a9c6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 17 Oct 2015 03:09:04 +0200 Subject: [PATCH 03/13] 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 +
+
+ + #{commentContent comment} diff --git a/templates/search.hamlet b/templates/search.hamlet index 69f861e..b2be05f 100755 --- a/templates/search.hamlet +++ b/templates/search.hamlet @@ -3,51 +3,3 @@ ^{widget} - -$if not (isNothing results) - $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 cId comment) <- commentList -
-
- - #{commentContent comment} From 77d6089588909851167bd1ac555e54f17e31342e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 17 Oct 2015 20:03:29 +0200 Subject: [PATCH 04/13] refined search and made it globally accessible --- Foundation.hs | 11 +++++++++++ Handler/Search.hs | 18 ++++++++++++------ Helper.hs | 2 +- static/css/style-global.css | 11 +++++++++++ templates/default-layout.hamlet | 2 ++ templates/profile.hamlet | 2 +- templates/result.hamlet | 23 ++++++++++++++--------- 7 files changed, 52 insertions(+), 17 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index a8fd9bb..f592a8d 100755 --- a/Foundation.hs +++ b/Foundation.hs @@ -94,6 +94,17 @@ renderLayout widget = do copyrightWidget <- widgetToPageContent $ $(widgetFile "copyrightFooter") + searchWidget <- widgetToPageContent $ [whamlet| + + +
+