now creating feeds

Application.hs

@@ -46,6 +46,7 @@ import Handler.AdminProfileSettings
 import Handler.AdminAlbumSettings
 import Handler.AdminMediumSettings
 import Handler.Tag
+import Handler.RootFeed
 
 -- 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/AdminMediumSettings.hs

@@ -91,6 +91,7 @@ adminMediumSetForm medium = renderDivs $ Medium
   <$> areq textField "Title" (Just $ mediumTitle medium)
   <*> pure (mediumPath medium)
   <*> pure (mediumThumb medium)
+  <*> pure (mediumMime medium)
   <*> pure (mediumTime medium)
   <*> pure (mediumOwner medium)
   <*> areq textareaField "Description" (Just $ mediumDescription medium)

Handler/MediumSettings.hs

@@ -79,6 +79,7 @@ mediumSettingsForm medium = renderDivs $ Medium
   <$> areq textField "Title" (Just $ mediumTitle medium)
   <*> pure (mediumPath medium)
   <*> pure (mediumThumb medium)
+  <*> pure (mediumMime medium)
   <*> pure (mediumTime medium)
   <*> pure (mediumOwner medium)
   <*> areq textareaField "Description" (Just $ mediumDescription medium)

Handler/RootFeed.hs

@@ -0,0 +1,194 @@
+module Handler.RootFeed where
+
+import Import
+import Yesod
+import Helper
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text as T
+import Data.Maybe
+import Data.Time
+import Data.Either.Combinators
+import Blaze.ByteString.Builder
+
+data FeedParameters = Parameters
+  { pTitle :: T.Text
+  , pImage :: T.Text
+  , pLink :: Route App
+  }
+
+nsAtom :: T.Text
+nsAtom = "http://www.w3.org/2005/Atom"
+
+class RepFeed c where
+  renderFeed :: FeedParameters -> Either [Entity Comment] [Entity Medium] -> Handler c
+
+newtype RepAtom = RepAtom Content
+  deriving (ToContent)
+
+instance ToTypedContent RepAtom where
+  toTypedContent =
+    TypedContent typeAtom . withXmlDecl . toContent
+
+withXmlDecl :: Content -> Content
+withXmlDecl (ContentBuilder b _) =
+  flip ContentBuilder Nothing $
+  fromByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\r\n" `mappend`
+  b
+withXmlDecl c = c
+
+instance RepFeed RepAtom where
+  renderFeed params items = do
+    image <- return $ pImage params
+    url <- getUrlRender
+    tz <- liftIO getCurrentTimeZone
+    links <- case items of
+      Left commEnts ->
+        return $ Left $ map (\ent -> (entityKey ent, url $ MediumR $ commentOrigin $ entityVal ent)) commEnts
+      Right mediaEnts ->
+        return $ Right $ map (\ent -> (entityKey ent, url $ MediumR $ entityKey ent)) mediaEnts
+--    media <- case items of
+--      [Entity _ (Medium _ _ _ _ _ _ _ _ _)] -> return $ True
+--      [Entity _ (Comment _ _ _ _ _ _)] -> return $ False
+    return $ RepAtom $ toContent $ 
+               [xhamlet|$newline always
+                 <feed version="1.0"
+                       xmlns=#{nsAtom}>
+                     <title>#{pTitle params}
+                     <link rel="alternate"
+                           type="text/html"
+                           href=#{url $ pLink params}
+                           >
+                     <id>#{url $ pLink params}
+                     $if not (T.null image)
+                         <link rel="icon"
+                               href=#{image}
+                               >
+                     $case items
+                       $of Right media
+                         $forall (Entity mediumId medium) <- media
+                           <entry xml:lang="en">
+                             <title>#{mediumTitle medium}
+                             <link rel="alternate"
+                               type="text/html"
+                               href=#{fromJust $ lookup mediumId $ fromRight [] links}
+                               >
+                             <id>#{fromJust $ lookup mediumId $ fromRight [] links}
+                             <published>#{iso8601 $ utcToZonedTime tz $ mediumTime medium}
+                             <summary>#{mediumDescription medium}
+                             <link rel="icon"
+                               href=#{mediumThumb medium}
+                               >
+                             <link rel="enclosure"
+                               type=#{mediumMime medium}
+                               href=#{fromJust $ lookup mediumId $ fromRight [] links}
+                               >
+                       $of Left comments
+                         $forall (Entity commentId comment) <- comments
+                           <entry xml:lang="en">
+                             <title>#{fromJust $ commentAuthorSlug comment} commented
+                             <link rel="alternate"
+                               type="text/html"
+                               href=#{fromJust $ lookup commentId $ fromLeft [] links}
+                               >
+                             <id>#{fromJust $ lookup commentId $ fromLeft [] links}
+                             <published>#{iso8601 $ utcToZonedTime tz $ commentTime comment}
+                             <summary>#{commentContent comment}
+                     |] url
+
+newtype RepRss = RepRss Content
+    deriving (ToContent)
+
+instance ToTypedContent RepRss where
+    toTypedContent =
+        TypedContent typeRss .
+        withXmlDecl . toContent
+      
+instance RepFeed RepRss where
+  renderFeed params items = do
+    url <- getUrlRender
+    let image = pImage params
+    links <- case items of
+      Left commEnts ->
+        return $ Left $ map (\ent -> (entityKey ent, url $ MediumR $ commentOrigin $ entityVal ent)) commEnts
+      Right mediaEnts ->
+        return $ Right $ map (\ent -> (entityKey ent, url $ MediumR $ entityKey ent)) mediaEnts
+    return $ RepRss $ toContent $ 
+               [xhamlet|$newline always
+                 <rss version="2.0"
+                      xmlns:atom=#{nsAtom}>
+                   <channel>
+                     <title>#{pTitle params}
+                     <link>#{url $ pLink params}
+                     $if not (T.null image)
+                       <image>
+                         <url>#{image}
+                     $case items
+                       $of Right media
+                         $forall (Entity mediumId medium) <- media
+                           <item>
+                             <title>#{mediumTitle medium}
+                             <link>#{fromJust $ lookup mediumId $ fromRight [] links}
+                             <language>en
+                             <description>#{mediumDescription medium}
+                             <guid isPermaLink="true">#{fromJust $ lookup mediumId $ fromRight [] links}
+                             <pubDate>#{rfc822 $ mediumTime medium}
+                             <image>
+                               <url>#{fromJust $ lookup mediumId $ fromRight [] links}
+                             <enclosure type="#{mediumMime medium}"
+                                        url="#{fromJust $ lookup mediumId $ fromRight [] links}">
+                       $of Left comments
+                         $forall (Entity commentId comment) <- comments
+                           <item>
+                             <title>#{fromJust $ commentAuthorSlug comment} commented
+                             <link>#{fromJust $ lookup commentId $ fromLeft [] links}
+                             <language>en
+                             <description>#{commentContent comment}
+                             <pubdate>#{rfc822 $ commentTime comment}
+                     |] url
+
+getRootFeedAtomR :: Handler RepAtom
+getRootFeedAtomR = getRootFeedR
+
+getRootFeedRssR :: Handler RepRss
+getRootFeedRssR = getRootFeedR
+
+getRootFeedR :: RepFeed a => Handler a
+getRootFeedR = do
+  recentMedia <- runDB $ selectList [] [Desc MediumTime, LimitTo 10]
+  renderFeed Parameters
+    { pTitle = "Eidolon :: Latest media"
+    , pLink  = HomeR
+    , pImage = ""
+    } (Right recentMedia)
+
+getAlbumFeedAtomR :: AlbumId -> Handler RepAtom
+getAlbumFeedAtomR = getAlbumFeedR
+
+getAlbumFeedRssR :: AlbumId -> Handler RepRss
+getAlbumFeedRssR = getAlbumFeedR
+
+getAlbumFeedR :: RepFeed a => AlbumId -> Handler a
+getAlbumFeedR albumId = do
+  album <- runDB $ get404 albumId
+  recentMedia <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime, LimitTo 10]
+  renderFeed Parameters
+    { pTitle = "Eidolon :: Latest media in album " `T.append` (albumTitle album)
+    , pLink  = AlbumR albumId
+    , pImage = T.pack $ fromMaybe "" (albumSamplePic album)
+    } (Right recentMedia)
+
+getCommentFeedAtomR :: MediumId -> Handler RepAtom
+getCommentFeedAtomR = getCommentFeedR
+
+getCommentFeedRssR :: MediumId -> Handler RepRss
+getCommentFeedRssR = getCommentFeedR
+
+getCommentFeedR :: RepFeed a => MediumId -> Handler a
+getCommentFeedR mediumId = do
+  medium <- runDB $ get404 mediumId
+  recentComments <- runDB $ selectList [CommentOrigin ==. mediumId] [Desc CommentTime, LimitTo 10]
+  renderFeed Parameters
+    { pTitle = "Eidolon :: Newest comments on " `T.append` (mediumTitle medium)
+    , pLink  = MediumR mediumId
+    , pImage = T.pack $ mediumThumb medium
+    } (Left recentComments)

Handler/Upload.hs

@@ -48,7 +48,8 @@ postUploadR = do
       case result of
         FormSuccess temp -> do
           fil <- return $ tempMediumFile temp
-          case (fileContentType fil) `elem` acceptedTypes of
+          mime <- return $ (fileContentType fil)
+          case mime `elem` acceptedTypes of
             True -> do
               albRef <- runDB $ getJust (tempMediumAlbum temp)
               ownerId <- return $ albumOwner albRef
@@ -59,6 +60,7 @@ postUploadR = do
                 (tempMediumTitle temp)
                 ('/' : path)
                 ('/' : thumbPath)
+                mime
                 (tempMediumTime temp)
                 (tempMediumOwner temp)
                 (tempMediumDesc temp)
@@ -128,7 +130,8 @@ postDirectUploadR albumId = do
               case result of
                 FormSuccess temp -> do
                   fil <- return $ tempMediumFile temp
-                  case (fileContentType fil) `elem` acceptedTypes of
+                  mime <- return $ fileContentType fil
+                  case mime `elem` acceptedTypes of
                     True -> do
                       albRef <- runDB $ getJust (tempMediumAlbum temp)
                       ownerId <- return $ albumOwner albRef
@@ -138,6 +141,7 @@ postDirectUploadR albumId = do
                         (tempMediumTitle temp)
                         ('/' : path)
                         ('/' : thumbPath)
+                        mime
                         (tempMediumTime temp)
                         (tempMediumOwner temp)
                         (tempMediumDesc temp)

Helper.hs

@@ -13,6 +13,9 @@ module Helper
   , generateString
   , removeItem
   , acceptedTypes
+  , iso8601
+  , localTimeToZonedTime
+  , rfc822
   )
 where
 
@@ -27,10 +30,13 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.Text as T
+import Data.Time
+import Data.Char
 import Database.Persist
 import Database.Persist.Types
 import System.FilePath
 import System.Random
+import System.Locale
 import Yesod.Persist.Core
 import Yesod.Core.Types
 import Yesod
@@ -149,3 +155,22 @@ reverseLookup s ((x, y):zs)
 
 acceptedTypes :: [T.Text]
 acceptedTypes = ["image/jpeg", "image/jpg", "image/png", "image/x-ms-bmp", "image/x-bmp", "image/bmp", "image/tiff", "image/tiff-fx"]
+
+iso8601 :: FormatTime t => t -> String
+iso8601 time =
+  formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S") time ++
+  zone
+  where zone = case formatTime defaultTimeLocale "%z" time of
+                 (sig:digits@(h1:h2:m1:m2))
+                   | sig `elem` "+-" &&
+                     all isDigit digits ->
+                       sig:h1:h2:':':m1:m2
+                 _ ->
+                   "Z"
+
+localTimeToZonedTime :: TimeZone -> LocalTime -> ZonedTime
+localTimeToZonedTime tz =
+  utcToZonedTime tz . localTimeToUTC tz
+
+--rfc822 :: LocalTime -> String
+rfc822 = formatTime defaultTimeLocale rfc822DateFormat

config/models

@@ -27,6 +27,7 @@ Medium
     title Text
     path FilePath
     thumb FilePath
+    mime Text
     time UTCTime
     owner UserId
     description Textarea

config/routes

@@ -39,3 +39,10 @@
 /admin/medium/#MediumId		AdminMediumSettingsR	GET POST
 /admin/meidum/#MediumId/delete	AdminMediumDeleteR	GET
 /tag/#Text TagR GET
+
+/feed/root/atom.xml		RootFeedAtomR		GET
+/feed/root/rss.xml		RootFeedRssR		GET
+/feed/album/#AlbumId/atom.xml	AlbumFeedAtomR		GET
+/feed/album/#AlbumId/rss.xml	AlbumFeedRssR		GET
+/feed/medium/#MediumId/atom.xml	CommentFeedAtomR	GET
+/feed/medium/#MediumId/rss.xml	CommentFeedRssR		GET

eidolon.cabal

@@ -39,6 +39,7 @@ library
                      Handler.AdminAlbumSettings
                      Handler.AdminMediumSettings
                      Handler.Tag
+                     Handler.RootFeed
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -102,6 +103,8 @@ library
                  , imagemagick
                  , resourcet
                  , yesod-markdown                >= 0.8
+                 , blaze-builder
+                 , either
 
 executable         eidolon
     if flag(library-only)

templates/album.hamlet

@@ -18,3 +18,7 @@ by <a href=@{UserR ownerName}>#{ownerName}</a>
             <figure class="thumbnail">
               <img src=#{mediumThumb medium}>
               <figcaption>#{mediumTitle medium}
+
+get a feed from this:
+  <a href=@{AlbumFeedAtomR albumId}>Atom
+  <a href=@{AlbumFeedRssR albumId}>RSS

templates/home.hamlet

@@ -9,3 +9,6 @@ $else
           <figure class="thumbnail">
             <img src=#{mediumThumb medium}>
             <figcaption>#{mediumTitle medium}
+get a feed from this:
+  <a href=@{RootFeedAtomR}>Atom
+  <a href=@{RootFeedRssR}>RSS

templates/medium.hamlet

@@ -52,3 +52,7 @@ $if userId /= Nothing
     ^{commentWidget}
     <div>
       <input type=submit value="Post comment">
+
+get a feed from this:
+  <a href=@{CommentFeedAtomR mediumId}>Atom
+  <a href=@{CommentFeedRssR mediumId}>RSS