implemented things related to attachment

[Rakka.git] / Rakka / TrackBack.hs

diff --git a/Rakka/TrackBack.hs b/Rakka/TrackBack.hs
new file mode 100644 (file)
index 0000000..2ea34cd
--- /dev/null
+++ b/Rakka/TrackBack.hs
@@ -0,0 +1,103 @@
+module Rakka.TrackBack
+    ( TrackBack(..)
+    )
+    where
+
+import           Control.Arrow
+import           Control.Arrow.ArrowList
+import           Control.Arrow.ArrowTree
+import           Data.Maybe
+import           Data.Time
+import           Network.URI
+import           Rakka.Attachment
+import           Rakka.Utils
+import           Rakka.W3CDateTime
+import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlNodeSet
+import           Text.XML.HXT.DOM.TypeDefs
+
+
+data TrackBack
+    = TrackBack {
+        tbTitle    :: !(Maybe String)
+      , tbExcerpt  :: !(Maybe String)
+      , tbURL      :: !URI
+      , tbBlogName :: !(Maybe String)
+      , tbTime     :: !UTCTime
+      }
+    deriving (Show, Eq)
+
+
+{-
+  <trackbacks>
+    <trackback title="" url="" blogName="" time="">
+      excerpt...
+    </trackback>
+    ...
+  </trackbacks>
+-}
+instance Attachment [TrackBack] where
+    serializeToXmlTree 
+        = proc trackbacks
+        -> ( eelem "/"
+             += ( eelem "trackbacks"
+                  += ( arrL id
+                       >>>
+                       tbToTree
+                     )
+                )
+           ) -< trackbacks
+        where
+          tbToTree :: ArrowXml a => a TrackBack XmlTree
+          tbToTree 
+              = proc tb
+              -> let title    = case tbTitle tb of
+                                  Nothing -> none
+                                  Just t  -> sattr "title" t
+                     excerpt  = case tbExcerpt tb of
+                                  Nothing -> none
+                                  Just e  -> txt e
+                     url      = sattr "url" (uriToString id (tbURL tb) "")
+                     blogName = case tbBlogName tb of
+                                  Nothing -> none
+                                  Just n  -> sattr "blogName" n
+                     time     = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb))
+                 in
+                   ( eelem "trackback"
+                     += title
+                     += url
+                     += blogName
+                     += time
+                     += excerpt
+                   ) -<< ()
+
+    deserializeFromXmlTree
+        = proc doc
+        -> do tree <- getXPathTreesInDoc "/trackbacks/trackback" -< doc
+              tb   <- treeToTb -< tree
+              listA this -< tb
+        where
+          treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack
+          treeToTb 
+              = proc tree
+              -> do title    <- maybeA (getAttrValue0 "title") -< tree
+                    url      <- ( getAttrValue0 "url"
+                                  >>>
+                                  arr (fromJust . parseURI)
+                                ) -< tree
+                    time     <- ( getAttrValue0 "time"
+                                  >>> 
+                                  arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+                                ) -< tree
+                    blogName <- maybeA (getAttrValue0 "blogName") -< tree
+                    excerpt  <- maybeA ( getChildren
+                                         >>>
+                                         getText
+                                       ) -< tree
+                    returnA -< TrackBack {
+                                  tbTitle    = title
+                                , tbExcerpt  = excerpt
+                                , tbURL      = url
+                                , tbBlogName = blogName
+                                , tbTime     = time
+                                }
\ No newline at end of file