diff --git a/Handler/Activate.hs b/Handler/Activate.hs index ed7d1fe..08155df 100755 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -16,6 +16,7 @@ module Handler.Activate where import Import as I hiding (returnJson) +import Handler.Commons import Data.Text import Data.Text.Encoding import Data.Maybe @@ -74,7 +75,7 @@ postActivateR token = do liftIO $ createDirectoryIfMissing True $ "static" "data" unpack (extractKey uId) -- input user to elasticsearch - liftIO $ putIndexES (ESUser uId $ activatorUser activ) + putIndexES (ESUser uId $ activatorUser activ) -- cleanup runDB $ delete aId runDB $ delete uTokenId diff --git a/Handler/AdminAlbumSettings.hs b/Handler/AdminAlbumSettings.hs index fa32e82..03d96c5 100755 --- a/Handler/AdminAlbumSettings.hs +++ b/Handler/AdminAlbumSettings.hs @@ -97,7 +97,7 @@ postAdminAlbumSettingsR albumId = do , AlbumSamplePic =. albumSamplePic temp , AlbumSampleWidth =. width ] - liftIO $ putIndexES (ESAlbum albumId temp) + putIndexES (ESAlbum albumId temp) setMessage "Album settings changed successfully" redirect AdminR _ -> do @@ -150,18 +150,18 @@ getAdminAlbumDeleteR albumId = 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)) + deleteIndexES (ESComment (entityKey child) (entityVal child)) runDB $ delete $ entityKey child ) children - liftIO $ deleteIndexES (ESComment (entityKey c) (entityVal c)) + deleteIndexES (ESComment (entityKey c) (entityVal c)) runDB $ delete $ entityKey c) commEnts -- delete album from elasticsearch - liftIO $ deleteIndexES (ESAlbum albumId album) + deleteIndexES (ESAlbum albumId album) -- delete album database entry runDB $ delete a ) (albumContent album) -- delete from elasticsearch - liftIO $ deleteIndexES (ESAlbum albumId album) + deleteIndexES (ESAlbum albumId album) -- delete album runDB $ delete albumId -- delete files diff --git a/Handler/AdminComments.hs b/Handler/AdminComments.hs index d81f4c9..53151cc 100755 --- a/Handler/AdminComments.hs +++ b/Handler/AdminComments.hs @@ -47,10 +47,10 @@ getAdminCommentDeleteR commentId = do -- delete comment children children <- runDB $ selectList [CommentParent ==. Just commentId] [] _ <- mapM (\child -> do - liftIO $ deleteIndexES (ESComment (entityKey child) (entityVal child)) + deleteIndexES (ESComment (entityKey child) (entityVal child)) runDB $ delete $ entityKey child) children -- delete comment itself - liftIO $ deleteIndexES (ESComment commentId comment) + deleteIndexES (ESComment commentId comment) runDB $ delete commentId setMessage "Comment deleted succesfully" redirect AdminR diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index 956898a..68eb294 100755 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -71,7 +71,7 @@ postAdminMediumSettingsR mediumId = do , MediumDescription =. mediumDescription temp , MediumTags =. mediumTags temp ] - liftIO $ putIndexES $ ESMedium mediumId temp + putIndexES $ ESMedium mediumId temp setMessage "Medium settings changed successfully" redirect AdminR _ -> do @@ -120,13 +120,13 @@ getAdminMediumDeleteR mediumId = do children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] [] _ <- mapM (\child -> do -- delete comment children - liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child) + deleteIndexES $ ESComment (entityKey child) (entityVal child) runDB $ delete $ entityKey child ) children - liftIO $ deleteIndexES $ ESComment (entityKey ent) (entityVal ent) + deleteIndexES $ ESComment (entityKey ent) (entityVal ent) runDB $ delete $ entityKey ent) commEnts -- delete medium - liftIO $ deleteIndexES $ ESMedium mediumId medium + 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 d566ec0..7a47925 100755 --- a/Handler/AdminProfileSettings.hs +++ b/Handler/AdminProfileSettings.hs @@ -113,7 +113,7 @@ postAdminProfileSettingsR ownerId = do , UserEmail =. userEmail temp , UserAdmin =. userAdmin temp ] - liftIO $ putIndexES $ ESUser ownerId temp + putIndexES $ ESUser ownerId temp setMessage "User data updated successfully" redirect AdminR _ -> do @@ -156,7 +156,7 @@ getAdminProfileDeleteR ownerId = do children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] [] _ <- mapM (\child -> do -- delete comment children - liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child) + deleteIndexES $ ESComment (entityKey child) (entityVal child) runDB $ delete $ entityKey child ) children runDB $ delete $ entityKey ent) commEnts @@ -166,13 +166,13 @@ getAdminProfileDeleteR ownerId = do liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) -- delete medium database entry and search ium <- runDB $ getJust med - liftIO $ deleteIndexES $ ESMedium med ium + deleteIndexES $ ESMedium med ium runDB $ delete med ) mediaList - liftIO $ deleteIndexES $ ESAlbum albumId album + deleteIndexES $ ESAlbum albumId album runDB $ delete albumId ) albumList - liftIO $ deleteIndexES $ ESUser ownerId owner + 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 386ee95..469f61a 100755 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -17,6 +17,7 @@ module Handler.AlbumSettings where import Import +import Handler.Commons import qualified Data.Text as T import Data.Maybe import System.Directory @@ -110,7 +111,7 @@ postAlbumSettingsR albumId = do , AlbumSamplePic =. albumSamplePic temp , AlbumSampleWidth =. width ] - liftIO $ putIndexES (ESAlbum albumId temp) + putIndexES (ESAlbum albumId temp) setMessage "Album settings changed succesfully" redirect $ AlbumR albumId _ -> do @@ -196,18 +197,18 @@ postAlbumDeleteR albumId = do liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) -- delete medium from elasticsearch - liftIO $ deleteIndexES (ESMedium a medium) + deleteIndexES (ESMedium a medium) -- delete comments commEnts <- runDB $ selectList [CommentOrigin ==. a] [] _ <- 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)) + deleteIndexES (ESComment (entityKey child) (entityVal child)) runDB $ delete $ entityKey child ) children -- delete comment from elasticsearch - liftIO $ deleteIndexES (ESComment (entityKey c) (entityVal c)) + deleteIndexES (ESComment (entityKey c) (entityVal c)) runDB $ delete $ entityKey c) commEnts runDB $ delete a ) (albumContent album) @@ -216,7 +217,7 @@ postAlbumDeleteR albumId = do -- delete files liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) T.unpack (extractKey albumId) -- delete from elasticsearch - liftIO $ deleteIndexES (ESAlbum albumId album) + deleteIndexES (ESAlbum albumId album) -- outro setMessage "Album deleted succesfully" redirect HomeR diff --git a/Handler/Commons.hs b/Handler/Commons.hs index 30f218f..c56ba3c 100755 --- a/Handler/Commons.hs +++ b/Handler/Commons.hs @@ -18,6 +18,14 @@ module Handler.Commons where import Import import Data.String +import Database.Bloodhound +import Control.Monad (when) +import Network.HTTP.Client +import Network.HTTP.Types.Status as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + loginIsAdmin :: IsString t => Handler (Either (t, Route App) ()) loginIsAdmin = do @@ -78,3 +86,72 @@ mediumCheck mediumId = do return $ Left ("You must be logged in to change settings", LoginR) Nothing -> return $ Left ("This medium does not exist", HomeR) + +putIndexES :: ESInput -> Handler () +putIndexES input = do + master <- getYesod + let shards = appShards $ appSettings master + let replicas = appReplicas $ appSettings master + let is = IndexSettings (ShardCount shards) (ReplicaCount replicas) + resp <- case input of + ESUser uId user -> do + ex <- runBH' $ indexExists (IndexName "user") + when (not ex) ((\ _ -> do + runBH' $ createIndex is (IndexName "user") + return () + ) ex) + _ <- runBH' $ openIndex (IndexName "user") + 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 is (IndexName "album") + return () + ) ex) + _ <- runBH' $ openIndex (IndexName "album") + 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 is (IndexName "medium") + return () + ) ex) + _ <- runBH' $ openIndex (IndexName "medium") + 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 is (IndexName "comment") + return () + ) ex) + _ <- runBH' $ openIndex (IndexName "comment") + runBH' $ indexDocument (IndexName "comment") (MappingName "comment") 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 "user") (DocId $ extractKey uId) + ESAlbum aId album -> + runBH' $ deleteDocument (IndexName "album") (MappingName "album") (DocId $ extractKey aId) + ESMedium mId medium -> + runBH' $ deleteDocument (IndexName "medium") (MappingName "medium") (DocId $ extractKey mId) + ESComment cId comment -> + runBH' $ deleteDocument (IndexName "comment") (MappingName "comment") (DocId $ extractKey cId) + case statusCode (responseStatus resp) of + 201 -> return () + 200 -> return () + _ -> error $ C.unpack $ BL.toStrict $ responseBody resp + +-- runBH' :: BH m a -> Handler resp +runBH' action = do + master <- getYesod + let s = appSearchHost $ appSettings master + let p = show $ appSearchPort $ appSettings master + let server = Server $ T.pack $ (T.unpack s) ++ ":" ++ show p + manager <- liftIO $ newManager defaultManagerSettings + runBH (BHEnv server manager) action diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 20cb988..5e427fa 100755 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -17,6 +17,7 @@ module Handler.Medium where import Import +import Handler.Commons import Data.Time import Data.Maybe import qualified Data.Text as T @@ -86,7 +87,7 @@ postMediumR mediumId = do case res of FormSuccess temp -> do cId <- runDB $ insert temp - liftIO $ putIndexES (ESComment cId temp) + putIndexES (ESComment cId temp) --send mail to medium owner owner <- runDB $ getJust $ mediumOwner medium link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender @@ -160,7 +161,7 @@ postCommentReplyR commentId = do case res of FormSuccess temp -> do cId <- runDB $ insert temp - liftIO $ putIndexES (ESComment cId temp) + putIndexES (ESComment cId temp) --send mail to parent author parent <- runDB $ getJust $ fromJust $ commentParent temp parAuth <- runDB $ getJust $ commentAuthor parent @@ -244,12 +245,12 @@ postCommentDeleteR commentId = do childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] [] _ <- mapM (\ent -> do -- delete comment children from elasticsearch - liftIO $ deleteIndexES (ESComment (entityKey ent) (entityVal ent)) + deleteIndexES (ESComment (entityKey ent) (entityVal ent)) runDB $ delete $ entityKey ent) childEnts -- delete comment itself runDB $ delete commentId -- delete from elasticsearch - liftIO $ deleteIndexES (ESComment commentId comment) + 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 9a71d91..4c924b5 100755 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -49,7 +49,7 @@ postMediumSettingsR mediumId = do , MediumDescription =. mediumDescription temp , MediumTags =. mediumTags temp ] - liftIO $ putIndexES (ESMedium mediumId temp) + putIndexES (ESMedium mediumId temp) setMessage "Medium settings changed succesfully" redirect $ MediumR mediumId _ -> do @@ -109,7 +109,7 @@ postMediumDeleteR mediumId = do liftIO $ removeFile (normalise $ tail $ mediumThumb medium) runDB $ delete mediumId -- delete form elasticsearch - liftIO $ deleteIndexES (ESMedium mediumId medium) + deleteIndexES (ESMedium mediumId medium) setMessage "Medium succesfully deleted" redirect HomeR _ -> do diff --git a/Handler/NewAlbum.hs b/Handler/NewAlbum.hs index 5ea5a78..6551637 100755 --- a/Handler/NewAlbum.hs +++ b/Handler/NewAlbum.hs @@ -17,6 +17,7 @@ module Handler.NewAlbum where import Import +import Handler.Commons import Data.Text import System.Directory import System.FilePath @@ -54,7 +55,7 @@ postNewAlbumR = do -- create folder liftIO $ createDirectory $ "static" "data" unpack (extractKey userId) unpack (extractKey albumId) -- update elasticsearch - liftIO $ putIndexES (ESAlbum albumId album) + putIndexES (ESAlbum albumId album) -- outro setMessage "Album successfully created" redirect $ ProfileR userId diff --git a/Handler/ProfileDelete.hs b/Handler/ProfileDelete.hs index 76fc77d..61aa688 100755 --- a/Handler/ProfileDelete.hs +++ b/Handler/ProfileDelete.hs @@ -55,26 +55,24 @@ postProfileDeleteR userId = do children <- runDB $ selectList [CommentParent ==. (Just $ entityKey ent)] [] _ <- mapM (\child -> do -- delete comment children - liftIO $ deleteIndexES $ ESComment (entityKey child) (entityVal child) + deleteIndexES $ ESComment (entityKey child) (entityVal child) runDB $ delete $ entityKey child ) children -- delete comment - liftIO $ deleteIndexES $ ESComment (entityKey ent) (entityVal ent) + 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 + deleteIndexES (ESMedium med medium) runDB $ delete med ) mediaList - liftIO $ deleteIndexES $ ESAlbum albumId album + deleteIndexES $ ESAlbum albumId album runDB $ delete albumId ) albumList - liftIO $ deleteIndexES $ ESUser userId user + deleteIndexES $ ESUser userId user 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 19f438f..e253c96 100755 --- a/Handler/ProfileSettings.hs +++ b/Handler/ProfileSettings.hs @@ -45,7 +45,7 @@ postProfileSettingsR userId = do , UserSlug =. userSlug temp , UserEmail =. userEmail temp ] - liftIO $ putIndexES (ESUser userId temp) + putIndexES (ESUser userId temp) setMessage "Profile settings changed successfully" redirect $ UserR $ userName user _ -> do diff --git a/Handler/Search.hs b/Handler/Search.hs index ce74d21..5777335 100755 --- a/Handler/Search.hs +++ b/Handler/Search.hs @@ -1,6 +1,7 @@ module Handler.Search where import Import +import Handler.Commons import Data.Time.Clock import Data.Aeson import Data.Maybe @@ -86,10 +87,10 @@ searchForm = renderDivs $ areq (searchField True) "Search" Nothing getResults :: Text -> Handler (Reply, Reply, Reply, Reply) getResults query = do let esQuery = QuerySimpleQueryStringQuery (SimpleQueryStringQuery (QueryString query) Nothing Nothing Nothing Nothing Nothing Nothing) - su <- liftIO $ runBH' $ searchByIndex (IndexName "user") $ mkSearch (Just esQuery) Nothing - sa <- liftIO $ runBH' $ searchByIndex (IndexName "album") $ mkSearch (Just esQuery) Nothing - sm <- liftIO $ runBH' $ searchByIndex (IndexName "medium") $ mkSearch (Just esQuery) Nothing - sc <- liftIO $ runBH' $ searchByIndex (IndexName "comment") $ mkSearch (Just esQuery) 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 diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 63ccdbe..07f5d3a 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -17,6 +17,7 @@ module Handler.Upload where import Import as I +import Handler.Commons import Data.Time import Data.Maybe import qualified Data.Text as T @@ -90,7 +91,7 @@ postDirectUploadR albumId = do inALbum <- runDB $ getJust albumId let newMediaList = mId : albumContent inALbum runDB $ update albumId [AlbumContent =. newMediaList] - liftIO $ putIndexES (ESMedium mId medium) + putIndexES (ESMedium mId medium) return Nothing else return $ Just $ fileName file @@ -252,7 +253,7 @@ postUploadR = do inALbum <- runDB $ getJust inAlbumId let newMediaList = mId : albumContent inALbum runDB $ update inAlbumId [AlbumContent =. newMediaList] - liftIO $ putIndexES (ESMedium mId medium) + putIndexES (ESMedium mId medium) return Nothing else return $ Just $ fileName file diff --git a/Helper.hs b/Helper.hs index afc18d0..364343c 100755 --- a/Helper.hs +++ b/Helper.hs @@ -208,71 +208,3 @@ multiFileField = Field |] , fieldEnctype = Multipart } - -putIndexES :: ESInput -> Handler () -putIndexES input = do - master <- getYesod - shards <- appShards $ appSettings master - replicas <- appReplicas $ appSettings master - let is = return $ IndexSettings (ShardCount shards) (ReplicaCount replicas) - resp <- case input of - ESUser uId user -> do - ex <- runBH' $ indexExists (IndexName "user") - when (not ex) ((\ _ -> do - runBH' $ createIndex is (IndexName "user") - return () - ) ex) - _ <- runBH' $ openIndex (IndexName "user") - 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 is (IndexName "album") - return () - ) ex) - _ <- runBH' $ openIndex (IndexName "album") - 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 is (IndexName "medium") - return () - ) ex) - _ <- runBH' $ openIndex (IndexName "medium") - 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 is (IndexName "comment") - return () - ) ex) - _ <- runBH' $ openIndex (IndexName "comment") - runBH' $ indexDocument (IndexName "comment") (MappingName "comment") 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 "user") (DocId $ extractKey uId) - ESAlbum aId album -> - runBH' $ deleteDocument (IndexName "album") (MappingName "album") (DocId $ extractKey aId) - ESMedium mId medium -> - runBH' $ deleteDocument (IndexName "medium") (MappingName "medium") (DocId $ extractKey mId) - ESComment cId comment -> - runBH' $ deleteDocument (IndexName "comment") (MappingName "comment") (DocId $ extractKey cId) - case statusCode (responseStatus resp) of - 201 -> return () - 200 -> return () - _ -> error $ C.unpack $ BL.toStrict $ responseBody resp - -runBH' action = do - master <- getYesod - server <- appSearchHost $ appSettings master - port <- return . show =<< (appSearchPort $ appSettings master) - let server = Server $ server ++ ":" ++ port - manager <- newManager defaultManagerSettings - runBH (BHEnv server manager) action