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
  76         -> do tree <- getXPathTreesInDoc "/trackbacks/trackback" -< doc
  77               tb   <- treeToTb -< tree
  78               listA this -< tb
  79         where
  80           treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack
  81           treeToTb
  82               = proc tree
  83               -> do title    <- maybeA (getAttrValue0 "title") -< tree
  84                     url      <- ( getAttrValue0 "url"
  85                                   >>>
  86                                   arr (fromJust . parseURI)
  87                                 ) -< tree
  88                     time     <- ( getAttrValue0 "time"
  89                                   >>>
  90                                   arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
  91                                 ) -< tree
  92                     blogName <- maybeA (getAttrValue0 "blogName") -< tree
  93                     excerpt  <- maybeA ( getChildren
  94                                          >>>
  95                                          getText
  96                                        ) -< tree
  97                     returnA -< TrackBack {
  98                                   tbTitle    = title
  99                                 , tbExcerpt  = excerpt
 100                                 , tbURL      = url
 101                                 , tbBlogName = blogName
 102                                 , tbTime     = time
 103                                 }