diff --git a/Application.hs b/Application.hs index ea65e10..9bcb05d 100644 --- 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 diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index 3b44a81..730a344 100644 --- 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) diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index 4387307..92636f8 100644 --- 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) diff --git a/Handler/RootFeed.hs b/Handler/RootFeed.hs new file mode 100644 index 0000000..7f74061 --- /dev/null +++ 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 "\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 + + #{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) diff --git a/Handler/Upload.hs b/Handler/Upload.hs index d2f218e..64aeb6c 100644 --- 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) diff --git a/Helper.hs b/Helper.hs index 0694c3d..1acfeed 100644 --- 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 diff --git a/config/models b/config/models index 483a817..780351d 100644 --- 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 diff --git a/config/routes b/config/routes index 7a1e9e6..77b3983 100644 --- 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 diff --git a/eidolon.cabal b/eidolon.cabal index 297c6f9..870737c 100644 --- 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) diff --git a/templates/album.hamlet b/templates/album.hamlet index 0069ee5..cae3413 100644 --- 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 diff --git a/templates/home.hamlet b/templates/home.hamlet index 377a9ab..6156776 100644 --- 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 diff --git a/templates/medium.hamlet b/templates/medium.hamlet index 0073a76..a2c94f7 100644 --- 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