1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | Streaming renderer for the OPML 2.0 standard.
module Text.OPML.Conduit.Render
( -- * Renderers
renderOpmlHead
, renderOpmlOutline
, renderOpml
) where
-- {{{ Imports
import Control.Monad
import Data.Conduit
import Data.List.NonEmpty hiding (filter, map)
import Data.Monoid
import Data.String
import Data.Text (Text, intercalate, pack, toLower)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.RFC822
import Data.Tree
import Data.Version
import Data.XML.Types
import Lens.Simple
import Prelude hiding (foldr, lookup, show)
import qualified Prelude (show)
import Refined hiding (NonEmpty)
import Text.OPML.Lens
import Text.OPML.Types
import Text.XML.Stream.Render
import URI.ByteString
-- }}}
show :: (Show a, IsString t) => a -> t
show = fromString . Prelude.show
empty :: (Eq s, Monoid s) => s -> Bool
empty t = t == mempty
toMaybe :: (Eq s, Monoid s) => s -> Maybe s
toMaybe s | s == mempty = mempty
| otherwise = Just s
formatTime :: UTCTime -> Text
formatTime = formatTimeRFC822 . utcToZonedTime utc
formatCategories :: [NonEmpty (Refined (Not Null) Text)] -> Maybe Text
formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap unrefine)
formatBool :: Bool -> Text
formatBool = toLower . show
formatURI :: URI -> Text
formatURI = decodeUtf8 . serializeURIRef'
-- | Render the @\<head\>@ section.
renderOpmlHead :: (Monad m) => OpmlHead -> ConduitT () Event m ()
renderOpmlHead input = tag "head" mempty $ do
forM_ (input^.opmlCreatedL) $ tag "dateCreated" mempty . content . formatTime
forM_ (input^.modifiedL) $ tag "dateModified" mempty . content . formatTime
forM_ (input^.docsL) $ tag "docs" mempty . content . formatURI
unless (null es) $ tag "expansionState" mempty . content . intercalate "," $ show <$> es
unless (empty email) $ tag "ownerEmail" mempty $ content email
forM_ (input^.ownerIdL) $ tag "ownerId" mempty . content . formatURI
unless (empty name) $ tag "ownerName" mempty $ content name
unless (empty title) $ tag "title" mempty $ content title
forM_ (input^.vertScrollStateL) $ tag "vertScrollState" mempty . content . show
forM_ (input^.windowBottomL) $ tag "windowBottom" mempty . content . show
forM_ (input^.windowLeftL) $ tag "windowLeft" mempty . content . show
forM_ (input^.windowRightL) $ tag "windowRight" mempty . content . show
forM_ (input^.windowTopL) $ tag "windowTop" mempty . content . show
where es = input ^.. expansionStateL
email = input ^. ownerEmailL
name = input ^. ownerNameL
title = input ^. opmlTitleL
-- | Render an @\<outline\>@ section.
renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> ConduitT () Event m ()
renderOpmlOutline (Node outline subOutlines) = tag "outline" attributes $ mapM_ renderOpmlOutline subOutlines
where attributes = case outline of
OpmlOutlineGeneric b t -> baseAttr b <> optionalAttr "type" (toMaybe t)
OpmlOutlineLink b uri -> baseAttr b <> attr "type" "link" <> attr "url" (formatURI uri)
OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s
baseAttr b = attr "text" (unrefine $ b^.textL)
<> optionalAttr "isComment" (formatBool <$> b^.isCommentL)
<> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpointL)
<> optionalAttr "created" (formatTime <$> b^.outlineCreatedL)
<> optionalAttr "category" (formatCategories $ b^.categoriesL)
subscriptionAttr s = attr "type" "rss"
<> attr "xmlUrl" (formatURI $ s^.xmlUriL)
<> optionalAttr "htmlUrl" (formatURI <$> s^.htmlUriL)
<> optionalAttr "description" (toMaybe $ s^.descriptionL)
<> optionalAttr "language" (toMaybe $ s^.languageL)
<> optionalAttr "title" (toMaybe $ s^.subscriptionTitleL)
<> optionalAttr "version" (toMaybe $ s^.subscriptionVersionL)
-- | Render the top-level @\<opml\>@ section.
renderOpml :: Monad m => Opml -> ConduitT () Event m ()
renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersionL) $ do
renderOpmlHead $ opml^.opmlHeadL
tag "body" mempty . mapM_ renderOpmlOutline $ opml^.opmlOutlinesL
|
