]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/TrackBack.hs
implemented page language select box
[Rakka.git] / Rakka / TrackBack.hs
1 module Rakka.TrackBack
2     ( TrackBack(..)
3     )
4     where
5
6 import           Control.Arrow
7 import           Control.Arrow.ArrowList
8 import           Control.Arrow.ArrowTree
9 import           Data.Maybe
10 import           Data.Time
11 import           Network.URI
12 import           Rakka.Attachment
13 import           Rakka.Utils
14 import           Rakka.W3CDateTime
15 import           Text.XML.HXT.Arrow.XmlArrow
16 import           Text.XML.HXT.Arrow.XmlNodeSet
17 import           Text.XML.HXT.DOM.TypeDefs
18
19
20 data TrackBack
21     = TrackBack {
22         tbTitle    :: !(Maybe String)
23       , tbExcerpt  :: !(Maybe String)
24       , tbURL      :: !URI
25       , tbBlogName :: !(Maybe String)
26       , tbTime     :: !UTCTime
27       }
28     deriving (Show, Eq)
29
30
31 {-
32   <trackbacks>
33     <trackback title="" url="" blogName="" time="">
34       excerpt...
35     </trackback>
36     ...
37   </trackbacks>
38 -}
39 instance Attachment [TrackBack] where
40     serializeToXmlTree 
41         = proc trackbacks
42         -> ( eelem "/"
43              += ( eelem "trackbacks"
44                   += ( arrL id
45                        >>>
46                        tbToTree
47                      )
48                 )
49            ) -< trackbacks
50         where
51           tbToTree :: ArrowXml a => a TrackBack XmlTree
52           tbToTree 
53               = proc tb
54               -> let title    = case tbTitle tb of
55                                   Nothing -> none
56                                   Just t  -> sattr "title" t
57                      excerpt  = case tbExcerpt tb of
58                                   Nothing -> none
59                                   Just e  -> txt e
60                      url      = sattr "url" (uriToString id (tbURL tb) "")
61                      blogName = case tbBlogName tb of
62                                   Nothing -> none
63                                   Just n  -> sattr "blogName" n
64                      time     = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb))
65                  in
66                    ( eelem "trackback"
67                      += title
68                      += url
69                      += blogName
70                      += time
71                      += excerpt
72                    ) -<< ()
73
74     deserializeFromXmlTree
75         = proc doc -> listA (getXPathTreesInDoc "/trackbacks/trackback" >>> treeToTb) -< doc
76         where
77           treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack
78           treeToTb 
79               = proc tree
80               -> do title    <- maybeA (getAttrValue0 "title") -< tree
81                     url      <- ( getAttrValue0 "url"
82                                   >>>
83                                   arr (fromJust . parseURI)
84                                 ) -< tree
85                     time     <- ( getAttrValue0 "time"
86                                   >>> 
87                                   arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
88                                 ) -< tree
89                     blogName <- maybeA (getAttrValue0 "blogName") -< tree
90                     excerpt  <- maybeA ( getChildren
91                                          >>>
92                                          getText
93                                        ) -< tree
94                     returnA -< TrackBack {
95                                   tbTitle    = title
96                                 , tbExcerpt  = excerpt
97                                 , tbURL      = url
98                                 , tbBlogName = blogName
99                                 , tbTime     = time
100                                 }