propagated search, fucking thing still does't work.

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

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

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)

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"

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

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

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)

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
+        a <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchUser))
-      _ -> return $ C.empty
+        b <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchAlbum))
-  -- error $ C.unpack searchResults
+        c <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchMedium))
-  defaultLayout $
+        d <- return $ (decode (responseBody res) :: Maybe (SearchResult SearchComment))
-    $(widgetFile "search")
+        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

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 ()

templates/search.hamlet

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