starting out with elasticsearch. not working for now

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

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

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

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

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

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

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

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

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

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

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
     }
+
+-- <putIndexES :: ESInput -> 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

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

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

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)

templates/search.hamlet

@@ -0,0 +1,13 @@
+<div #header .item data-width="400">
+  <div .inner>
+    <form method=GET action=@{SearchR}>
+      ^{widget}
+      <input type="submit" value="Search">
+
+$if not $ C.null searchResults
+  <div #header .item data-width="400">
+    <div .inner>
+      <h1>
+        Results:
+      <p>
+        #{C.unpack searchResults}