now creating feeds

2014-12-14 20:21:23 +01:00 · 2014-12-14 20:21:23 +01:00 · 914a572ac7
commit 914a572ac7
parent e226802379
12 changed files with 250 additions and 2 deletions
--- a/Application.hs
+++ b/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
--- a/Handler/AdminMediumSettings.hs
+++ b/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)
--- a/Handler/MediumSettings.hs
+++ b/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)
--- a/Handler/RootFeed.hs
+++ b/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)
--- a/Handler/Upload.hs
+++ b/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)
--- a/Helper.hs
+++ b/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
--- a/config/models
+++ b/config/models
@ -27,6 +27,7 @@ Medium
    title Text
    path FilePath
    thumb FilePath
+    mime Text
    time UTCTime
    owner UserId
    description Textarea
--- a/config/routes
+++ b/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
--- a/eidolon.cabal
+++ b/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)
--- a/templates/album.hamlet
+++ b/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
--- a/templates/home.hamlet
+++ b/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
--- a/templates/medium.hamlet
+++ b/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