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                                 }