Rakka/TrackBack.hs

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