now creating feeds

This commit is contained in:
nek0 2014-12-14 20:21:23 +01:00
parent e226802379
commit 914a572ac7
12 changed files with 250 additions and 2 deletions

View file

@ -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

View file

@ -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)

View file

@ -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)

194
Handler/RootFeed.hs Normal file
View file

@ -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)

View file

@ -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)

View file

@ -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

View file

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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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