Merge branch 'elasticsearch'

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

Foundation.hs

@@ -94,6 +94,17 @@ renderLayout widget = do
     copyrightWidget <- widgetToPageContent $
         $(widgetFile "copyrightFooter")
 
+    searchWidget <- widgetToPageContent $ [whamlet|
+      <form action=@{SearchR} method=GET>
+        <input type="hidden" name="_hasdata">
+        <div .required>
+          <label for="hident2">
+          <input #hident2 type="search" autofocus="" required="" name="f1">
+          <script>
+            if (!('autofocus' in document.createElement('input'))) {document.getElementById('hident2').focus();}
+        <input value="Search" type="submit">
+      |]
+
     wc <- widgetToPageContent widget
 
     pc <- widgetToPageContent $ do

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
@@ -73,6 +74,8 @@ postActivateR token = do
                   -- create user directory
                   liftIO $ createDirectoryIfMissing True $
                     "static" </> "data" </> unpack (extractKey uId)
+                  -- input user to elasticsearch
+                  putIndexES (ESUser uId $ activatorUser activ)
                   -- cleanup
                   runDB $ delete aId
                   runDB $ delete uTokenId

Handler/AdminAlbumSettings.hs

@@ -97,6 +97,7 @@ postAdminAlbumSettingsR albumId = do
                 , AlbumSamplePic =. albumSamplePic temp
                 , AlbumSampleWidth =. width
                 ]
+              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
+                deleteIndexES (ESComment (entityKey child) (entityVal child))
+                runDB $ delete $ entityKey child
+                ) children
+              deleteIndexES (ESComment (entityKey c) (entityVal c))
+              runDB $ delete $ entityKey c) commEnts
+            -- delete album from elasticsearch
+            deleteIndexES (ESAlbum albumId album)
             -- delete album database entry
             runDB $ delete a
             ) (albumContent album)
+          -- delete from elasticsearch
+          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
+            deleteIndexES (ESComment (entityKey child) (entityVal child))
+            runDB $ delete $ entityKey child) children
           -- delete comment itself
+          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
                 ]
+              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
+              deleteIndexES $ ESComment (entityKey child) (entityVal child)
+              runDB $ delete $ entityKey child
+              ) children
+            deleteIndexES $ ESComment (entityKey ent) (entityVal ent)
+            runDB $ delete $ entityKey ent) commEnts
           -- delete medium
+          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
                 ]
+              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
+                  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
+              deleteIndexES $ ESMedium med ium
               runDB $ delete med
               ) mediaList
+            deleteIndexES $ ESAlbum albumId album
             runDB $ delete albumId
             ) albumList
+          deleteIndexES $ ESUser ownerId owner
           runDB $ delete ownerId
           liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey ownerId)
           setMessage "User successfully deleted"

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,6 +111,7 @@ postAlbumSettingsR albumId = do
                     , AlbumSamplePic =. albumSamplePic temp
                     , AlbumSampleWidth =. width
                     ]
+                  putIndexES (ESAlbum albumId temp)
                   setMessage "Album settings changed succesfully"
                   redirect $ AlbumR albumId
                 _ -> do
@@ -194,15 +196,28 @@ 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
+                    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
+                        deleteIndexES (ESComment (entityKey child) (entityVal child))
+                        runDB $ delete $ entityKey child
+                        ) children
+                      -- delete comment from elasticsearch
+                      deleteIndexES (ESComment (entityKey c) (entityVal c))
+                      runDB $ delete $ entityKey c) commEnts
                     runDB $ delete a
                     ) (albumContent album)
                   -- delete album
                   runDB $ delete albumId
                   -- delete files
                   liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId) </> T.unpack (extractKey albumId)
+                  -- delete from elasticsearch
+                  deleteIndexES (ESAlbum albumId album)
                   -- outro
                   setMessage "Album deleted succesfully"
                   redirect HomeR

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,71 @@ 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 ()
+    code -> error $ (show code) ++ ": " ++ (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 server = Server s
+  manager <- liftIO $ newManager defaultManagerSettings
+  runBH (BHEnv server manager) action

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
@@ -85,7 +86,8 @@ postMediumR mediumId = do
           ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing
           case res of
             FormSuccess temp -> do
-              _ <- runDB $ insert temp
+              cId <- runDB $ insert temp
+              putIndexES (ESComment cId temp)
               --send mail to medium owner
               owner <- runDB $ getJust $ mediumOwner medium
               link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
@@ -158,7 +160,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
+              putIndexES (ESComment cId temp)
               --send mail to parent author
               parent <- runDB $ getJust $ fromJust $ commentParent temp
               parAuth <- runDB $ getJust $ commentAuthor parent
@@ -240,9 +243,14 @@ 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
+                    deleteIndexES (ESComment (entityKey ent) (entityVal ent))
+                    runDB $ delete $ entityKey ent) childEnts
                   -- delete comment itself
                   runDB $ delete commentId
+                  -- delete from elasticsearch
+                  deleteIndexES (ESComment commentId comment)
                   -- outro
                   setMessage "Your comment has been deleted"
                   redirect $ MediumR $ commentOrigin comment

Handler/MediumSettings.hs

@@ -49,6 +49,7 @@ postMediumSettingsR mediumId = do
             , MediumDescription =. mediumDescription temp
             , MediumTags =. mediumTags temp
             ]
+          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
+          deleteIndexES (ESMedium mediumId medium)
           setMessage "Medium succesfully deleted"
           redirect HomeR
         _ -> do

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
@@ -53,6 +54,8 @@ postNewAlbumR = do
           runDB $ update userId [UserAlbums =. newAlbumList]
           -- create folder
           liftIO $ createDirectory $ "static" </> "data" </> unpack (extractKey userId) </> unpack (extractKey albumId)
+          -- update elasticsearch
+          putIndexES (ESAlbum albumId album)
           -- outro
           setMessage "Album successfully created"
           redirect $ ProfileR userId

Handler/ProfileDelete.hs

@@ -51,14 +51,26 @@ 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
+                    deleteIndexES $ ESComment (entityKey child) (entityVal child)
+                    runDB $ delete $ entityKey child
+                    ) children
+                  -- delete comment
+                  deleteIndexES $ ESComment (entityKey ent) (entityVal ent)
+                  runDB $ delete $ entityKey ent) commEnts
                 medium <- runDB $ getJust med
                 liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
                 liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
+                deleteIndexES (ESMedium med medium)
                 runDB $ delete med
                 ) mediaList
+              deleteIndexES $ ESAlbum albumId album
               runDB $ delete albumId
             ) albumList
+          deleteIndexES $ ESUser userId user
           runDB $ delete userId
           liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId)
           deleteSession "userId"

Handler/ProfileSettings.hs

@@ -45,6 +45,7 @@ postProfileSettingsR userId = do
            , UserSlug =. userSlug temp
            , UserEmail =. userEmail temp
            ]
+         putIndexES (ESUser userId temp)
          setMessage "Profile settings changed successfully"
          redirect $ UserR $ userName user
         _ -> do

Handler/Search.hs

@@ -0,0 +1,149 @@
+module Handler.Search where
+
+import Import
+import Handler.Commons
+import Data.Time.Clock
+import Data.Aeson
+import Data.Maybe
+import qualified Data.Text as T
+import Database.Bloodhound
+import Network.HTTP.Client (responseBody)
+import System.FilePath.Posix
+
+getSearchR :: Handler Html
+getSearchR = do
+  ((res, widget), _) <- runFormGet searchForm
+  case res of
+    FormSuccess query -> do
+      (ru, ra, rm, rc) <- getResults query
+      a <- return $ (decode (responseBody ru) :: Maybe (SearchResult SearchUser))
+      b <- return $ (decode (responseBody ra) :: Maybe (SearchResult SearchAlbum))
+      c <- return $ (decode (responseBody rm) :: Maybe (SearchResult SearchMedium))
+      d <- return $ (decode (responseBody rc) :: Maybe (SearchResult SearchComment))
+      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 (\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 $ do
+        setTitle $ toHtml $ "Eidolon :: Search results for " ++ (T.unpack query)
+        $(widgetFile "result")
+    _ ->
+      defaultLayout $ do
+        setTitle "Eidolon :: Search"
+        $(widgetFile "search")
+
+searchForm :: Form T.Text
+searchForm = renderDivs $ areq (searchField True) "Search" Nothing
+
+getResults :: Text -> Handler (Reply, Reply, Reply, Reply)
+getResults query = do
+  esQuery <- return $ QueryFuzzyLikeThisQuery $ FuzzyLikeThisQuery
+    { fuzzyLikeFields              = [FieldName "_all"]
+    , fuzzyLikeText                = query
+    , fuzzyLikeMaxQueryTerms       = MaxQueryTerms 25
+    , fuzzyLikeIgnoreTermFrequency = IgnoreTermFrequency False
+    , fuzzyLikeFuzziness           = Fuzziness 0.6
+    , fuzzyLikePrefixLength        = PrefixLength 0
+    , fuzzyLikeBoost               = Boost 1.0
+    , fuzzyLikeAnalyzer            = 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
+  { 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

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,6 +91,7 @@ postDirectUploadR albumId = do
                           inALbum <- runDB $ getJust albumId
                           let newMediaList = mId : albumContent inALbum
                           runDB $ update albumId [AlbumContent =. newMediaList]
+                          putIndexES (ESMedium mId medium)
                           return Nothing
                         else
                           return $ Just $ fileName file
@@ -251,6 +253,7 @@ postUploadR = do
                   inALbum <- runDB $ getJust inAlbumId
                   let newMediaList = mId : albumContent inALbum
                   runDB $ update inAlbumId [AlbumContent =. newMediaList]
+                  putIndexES (ESMedium mId medium)
                   return Nothing
                 else
                   return $ Just $ fileName file

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 =
@@ -53,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) =

Migrations/0.0.4-0.0.5/Migration.hs

@@ -0,0 +1,174 @@
+module Migrate2 where
+
+import Prelude
+import Database.HDBC
+import Database.HDBC.PostgreSQL
+import System.IO
+import Control.Exception
+import qualified Data.Text as T
+import qualified Data.ByteString.Char8 as B
+import Data.Aeson as A
+import Data.Time.Clock
+import Data.Yaml as Y
+import Data.Time.LocalTime
+import Database.Bloodhound
+import Network.HTTP.Client
+
+data ESSettings = ESSettings
+  { esHost :: T.Text
+  , esShards :: Int
+  , esReplicas :: Int
+  }
+
+instance A.FromJSON ESSettings where
+  parseJSON = withObject "AppSettings" $ \o -> do
+    esHost <- o .: "searchhost"
+    esShards <- o .: "shards"
+    esReplicas <- o .: "replicas"
+    return ESSettings {..}
+
+main :: IO ()
+main = do
+  putStrLn "Enter database host"
+  dbHost <- getLine
+  putStrLn "Enter database port"
+  dbPort <- getLine
+  putStrLn "Enter database user"
+  dbUser <- getLine
+  putStrLn "Enter database name"
+  dbName <- getLine
+  putStrLn "Enter database password"
+  dbPasswd <- getPasswd
+  putStrLn "Enter location of eidolon settings.yml file"
+  settingsFP <- getLine
+  let dbString = "host=" ++ dbHost ++ " port=" ++ dbPort ++ " user=" ++ dbUser ++ " dbname=" ++ dbName ++ " password=" ++ dbPasswd
+  conn <- connectPostgreSQL dbString
+  settingsY <- decodeFile settingsFP :: IO (Maybe ESSettings)
+  elastic <- case settingsY of
+    Just el -> return el
+    Nothing -> error $ "Could not read settings from " ++ settingsFP
+  let server = Server $ esHost elastic
+  let indexSettings = IndexSettings (ShardCount $ esShards elastic) (ReplicaCount $ esReplicas elastic)
+  userStmt <- prepare conn "select * from \"user\""
+  _ <- execute userStmt []
+  userRows <- fetchAllRowsAL userStmt
+  albumStmt <- prepare conn "select * from \"album\""
+  _ <- execute albumStmt []
+  albumRows <- fetchAllRowsAL albumStmt
+  mediumStmt <- prepare conn "select * from \"medium\""
+  _ <- execute mediumStmt []
+  mediumRows <- fetchAllRowsAL mediumStmt
+  commentStmt <- prepare conn "select * from \"comment\""
+  _ <- execute commentStmt []
+  commentRows <- fetchAllRowsAL commentStmt
+  _ <- withBH defaultManagerSettings server $ do
+    _ <- createIndex indexSettings (IndexName "user")
+    _ <- createIndex indexSettings (IndexName "album")
+    _ <- createIndex indexSettings (IndexName "medium")
+    _ <- createIndex indexSettings (IndexName "comment")
+    _ <- sequence $ map (\entry ->
+      case entry of
+        [("id", SqlInteger theId), ("name", SqlByteString name), ("slug", SqlByteString slug), _, _, _, _, _] -> do
+           let u = SUser (bToT name) (bToT slug)
+           let dId = DocId $ T.pack $ show theId
+           indexDocument (IndexName "user") (MappingName "user") defaultIndexDocumentSettings u dId
+        bla ->
+          error $ "malformed entry" ++ show bla
+      ) userRows
+    _ <- sequence $ map (\entry ->
+      case entry of
+        [("id", SqlInteger theId), ("title", SqlByteString title), _, _, _, _, _] -> do
+           let a = SAlbum (bToT title)
+           let dId = DocId $ T.pack $ show theId
+           indexDocument (IndexName "album") (MappingName "album") defaultIndexDocumentSettings a dId
+        bla ->
+          error $ "malformed entry: " ++ show bla
+      ) albumRows
+    _ <- sequence $ map (\entry ->
+      case entry of
+        [("id", SqlInteger theId), ("title", SqlByteString title), _, _, _, ("time", SqlZonedTime time), _, ("description", SqlByteString desc), ("tags", SqlByteString tags), _, _, _, _, _] -> do
+           let m = SMedium (bToT title) (zonedTimeToUTC time) (bToT desc) (parseTags tags)
+           let dId = DocId $ T.pack $ show theId
+           indexDocument (IndexName "medium") (MappingName "medium") defaultIndexDocumentSettings m dId
+        bla ->
+          error $ "malformed entry" ++ show bla
+      ) mediumRows
+    _ <- sequence $ map (\entry ->
+      case entry of
+        [("id", SqlInteger theId), _, ("author_slug", SqlByteString author), _, _, ("time", SqlZonedTime time), ("content", SqlByteString content)] -> do
+           let c = SComment (bToT author) (zonedTimeToUTC time) (bToT content)
+           let dId = DocId $ T.pack $ show theId
+           indexDocument (IndexName "medium") (MappingName "medium") defaultIndexDocumentSettings c dId
+        bla ->
+          error $ "malformed entry" ++ show bla
+      ) commentRows
+    return ()
+  putStrLn "Migration successful!!"
+
+data SUser = SUser
+  { suName :: T.Text
+  , suSlug :: T.Text
+  }
+
+instance A.ToJSON SUser where
+  toJSON (SUser n s) = object
+    [ "name" .= n
+    , "slug" .= s
+    ]
+
+data SAlbum = SAlbum
+  { saName :: T.Text }
+
+instance A.ToJSON SAlbum where
+  toJSON (SAlbum n) = object
+    [ "name" .= n ]
+
+data SMedium = SMedium
+  { smName :: T.Text
+  , smTime :: UTCTime
+  , smDesc :: T.Text
+  , smTags :: [T.Text]
+  }
+
+instance A.ToJSON SMedium where
+  toJSON (SMedium n t d g) = object
+    [ "name"        .= n
+    , "time"        .= t
+    , "description" .= d
+    , "tags"        .= g
+    ]
+
+data SComment = SComment
+  { scAuthor :: T.Text
+  , scTime :: UTCTime
+  , scContent :: T.Text
+  }
+
+instance A.ToJSON SComment where
+  toJSON (SComment a t c) = object
+    [ "author"  .= a
+    , "time"    .= t
+    , "content" .= c
+    ]
+
+parseTags :: B.ByteString -> [T.Text]
+parseTags bs = map handle' inner
+  where
+    inner = T.splitOn "," $ T.pack $ B.unpack $ B.init $ B.tail bs
+    handle' = T.dropEnd 2 . T.drop 3
+
+bToT :: B.ByteString -> T.Text
+bToT = T.pack . B.unpack
+
+getPasswd :: IO String
+getPasswd = do
+  putStr "Password: "
+  hFlush stdout
+  pass <- withEcho False getLine
+  putChar '\n'
+  return pass
+
+withEcho :: Bool -> IO a -> IO a
+withEcho echo action = do
+  old <- hGetEcho stdin
+  bracket_ (hSetEcho stdin echo) (hSetEcho stdin old) action

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)
+      ]

README.md

@@ -10,6 +10,8 @@ Visit the test instance at [eidolon.nek0.eu][eidolon]
 
 ###Dependencies
 
+####Build dependencies
+
 A working Haskell capable environment. For that you will need `haskell-stack` and `cabal-install`, which you can install with:
 
 ```bash
@@ -47,6 +49,15 @@ cabal install alex happy
 sudo apt-get install libmagick++-dev
 ```
 
+####Elasticsearch dependencies
+
+Since version 0.0.5 there is an Elasticsearch integration for Eidolon. To Be able to run eidolon , you need to install `elasticsearch` additionally with:
+
+```bash
+sudo apt-get install elasticsearch
+```
+On how to configure your elasticsearch server, look into the [elasticsearch documentation][elasticdocu].
+
 ###Building
 
 get the source with
@@ -80,7 +91,7 @@ cabal build
 
 After compiling you will find an executable called `eidolon` in `dist/build/eidolon/`. Copy or link it anywhere you want. The executable needs to be accompanied by the folders `config` and `static` and their contents. It's best to copy them to your desired destination.
 
-Also check `config/settings.yml` and set the values there accrding to your configuration.
+Also check `config/settings.yml` and set the values there accrding to your configuration. Especially the settings for elasticsearch are vital.
 
 It may also be necessery to create a reverse proxy to your gallery. I would recommend using [nginx](http://nginx.org/).
 
@@ -105,6 +116,14 @@ Since eidolon will block your console, I recommend wrapping a init-script around
 	* without sandbox: `runghc /path/to/eidolon/Migrations/0.0.3-0.0.4/Migration.hs`
 * start or restart your eidolon service
 
+###0.0.4-0.0.5
+
+* run migration script from your run location (where your `static` folder with all the images is located)
+	* if you are building in a sandbox run `runghc -package-db/full/path/to/sandbox/XXX-ghc-version-packages.conf.d /path/to/eidolon/Migrations/0.0.4-0.0.5/Migration.hs`
+		* Note: No space between the option `-package-db` and its argument
+	* without sandbox: `runghc /path/to/eidolon/Migrations/0.0.4-0.0.5/Migration.hs`
+* start or restart your eidolon service
+
 ##Acknowledgements:
 
 * This software uses the web Framework "Yesod" by Michael Snoyman. See more at: <http://www.yesodweb.com/>
@@ -113,3 +132,4 @@ Since eidolon will block your console, I recommend wrapping a init-script around
 
 [eidolon]: http://eidolon.nek0.eu
 [stack]: https://github.com/commercialhaskell/stack/releases
+[elasticdocu]: https://www.elastic.co/guide/en/elasticsearch/reference/current/setup-configuration.html

Settings.hs

@@ -75,6 +75,10 @@ data AppSettings = AppSettings
     , appTos1                   :: Text
     , appTos2                   :: Text
     -- ^ Terms of Service
+    , appSearchHost             :: Text
+    , appShards                 :: Int
+    , appReplicas               :: Int
+    -- ^ Settings for Elasticsearch
     }
 
 instance FromJSON AppSettings where
@@ -106,6 +110,10 @@ instance FromJSON AppSettings where
         appTos1                   <- o .: "tos1"
         appTos2                   <- o .: "tos2"
 
+        appSearchHost             <- o .: "searchhost"
+        appShards                 <- o .: "shards"
+        appReplicas               <- o .: "replicas"
+
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and

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

config/settings.yml

@@ -47,5 +47,12 @@ copyrightLink: https://github.com/nek0/eidolon
 
 # block signup process
 signupBlocked:  "_env:SIGNUP_BLOCK:false"
+
+# Terms of Service
 tos1: "Terms of Service 1"
 tos2: "Terms of Service 2"
+
+# Elasticsearcha settings
+searchhost: "http://localhost:9200"
+shards: 1
+replicas: 2

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)

static/css/style-global.css

@@ -198,6 +198,16 @@
 
 /*custom*/
 
+	#search > form 
+	{
+		display: flex;
+	}
+
+	#search > form .required > *
+	{
+		margin: 0;
+	}
+
 	a:hover
 	{
 		color: black;
@@ -219,11 +229,22 @@
 		padding: 1em 2em;
 	}
 
+	#user-nav
+	{
+		display: inline-block;
+	}
+
 	nav li
 	{
 		display: inline-block;
 	}
 
+	#search
+	{
+		display: inline-block;
+		float: right;
+	}
+
 	.comment
 	{
 		border: 5px solid rgb(255, 255, 255);

templates/default-layout.hamlet

@@ -17,6 +17,8 @@
       $if block == False
         <li>
           <a href=@{SignupR}>Signup
+  <div #search .right>
+    ^{pageBody searchWidget}
 
 $maybe msg <- mmsg
   <div #message>#{msg}

templates/profile.hamlet

@@ -18,7 +18,7 @@ $forall (Entity albumId album) <- userAlbs
     <a href=@{AlbumR albumId}>
       <figure class="thumbnail">
         $if (albumSamplePic album) == Nothing
-          <img src=@{StaticR img_album_jpg}>
+          <img src=@{StaticR img_album_jpg} title=#{albumTitle album}>
         $else
           <img src=@{StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ fromJust $ albumSamplePic album) []} title=#{albumTitle album}>
         <figcaption>#{albumTitle album}

templates/result.hamlet

@@ -0,0 +1,56 @@
+<div #header .item data-width="400">
+  <div .inner>
+    <h1>
+      Results for: #{query}
+
+$if allEmpty
+  <div #header .item data-width="400">
+    <div .inner>
+      <h2>
+        Sorry, no results
+$else
+  $if not $ null userList
+    <div #header .item data-width="400">
+      <div .inner>
+        <h2>
+          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>
+        <h2>
+          Results in Albums:
+    $forall (Entity aId album) <- albumList
+      <article .item data-width="#{albumSampleWidth album}">
+        <a href=@{AlbumR aId}>
+          <figure .thumbnail>
+            $if (albumSamplePic album) == Nothing
+              <img src=@{StaticR img_album_jpg} title=#{albumTitle album}>
+            $else
+              <img src=@{StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ fromJust $ albumSamplePic album) []} title=#{albumTitle album}>
+            <figcaption>#{albumTitle album}
+  $if not $ null mediumList
+    <article #header .item data-width="400">
+      <div .inner>
+        <h2>
+          Results in Media:
+    $forall (Entity mId medium) <- mediumList
+      <article .item data-width="#{mediumThumbWidth medium}">
+        <a href=@{MediumR mId}>
+          <figure .thumbnail>
+            <img src=@{StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) []} title=#{mediumTitle medium}>
+            <figcaption>#{mediumTitle medium}
+  $if not $ null commentList
+    <div #header .item data-width="400">
+      <div .inner>
+        <h2>
+          Results in Comments:
+    $forall (Entity _ comment) <- commentList
+      <div #header .item data-width="400">
+        <div .inner>
+          <a href=@{MediumR $ commentOrigin comment}>
+            #{commentContent comment}

templates/search.hamlet

@@ -0,0 +1,5 @@
+<div #header .item data-width="400">
+  <div .inner>
+    <form method=GET action=@{SearchR}>
+      ^{widget}
+      <input type="submit" value="Search">