implemented trackback receiver

[Rakka.git] / Rakka / Wiki / Interpreter / Trackback.hs

diff --git a/Rakka/Wiki/Interpreter/Trackback.hs b/Rakka/Wiki/Interpreter/Trackback.hs
index 984c4aa9cc66b1b96705c57207de4fe047ad331a..485c46f1d6e343b48eece25ae6dc384ae146d36f 100644 (file)
--- a/Rakka/Wiki/Interpreter/Trackback.hs
+++ b/Rakka/Wiki/Interpreter/Trackback.hs
@@ -3,8 +3,13 @@ module Rakka.Wiki.Interpreter.Trackback
     )
     where
 
+import           Data.Maybe
+import           Data.Time
+import           Network.HTTP.Lucu.RFC1123DateTime
 import           Rakka.Page
+import           Rakka.Storage
 import           Rakka.SystemConfig
+import           Rakka.TrackBack
 import           Rakka.Wiki
 import           Rakka.Wiki.Interpreter
 
@@ -20,9 +25,13 @@ trackbackURLInterp
     = InlineCommandInterpreter {
         iciName = "trackbackURL"
       , iciInterpret
-          = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
-                          let uri = mkAuxiliaryURI baseURI ["trackback"] (ctxPageName ctx)
-                          return $ ExternalLink uri (Just "Trackback URL")
+          = \ ctx _ -> case ctxPageName ctx of
+                         Nothing
+                             -> return (Text "No trackbacks for this page.")
+                         Just name
+                             -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
+                                   let uri = mkAuxiliaryURI baseURI ["trackback"] name
+                                   return $ ExternalLink uri (Just "Trackback URL")
       }
 
 
@@ -31,5 +40,37 @@ trackbacksInterp
     = BlockCommandInterpreter {
         bciName = "trackbacks"
       , bciInterpret
-          = \ _ _ -> return $ Div [("class", "trackbacks")] []
+          = \ ctx _ ->
+            do trackbacks <- case ctxPageName ctx of
+                               Nothing
+                                   -> return []
+                               Just name
+                                   -> getAttachment (ctxStorage ctx) name "trackbacks" Nothing
+                                      >>=
+                                      return . fromMaybe []
+               items <- mapM mkListItem trackbacks
+
+               let divElem = Div [("class", "trackbacks")] [list]
+                   list    = Block (List Bullet items)
+                   
+               return divElem
       }
+    where
+      mkListItem :: TrackBack -> IO ListItem
+      mkListItem tb
+          = do zonedTime <- utcToLocalZonedTime (tbTime tb)
+
+               let anchor  = Just (Inline (ExternalLink (tbURL tb) label))
+                   label   = case (tbTitle tb, tbBlogName tb) of
+                               (Nothing   , Nothing      ) -> Nothing
+                               (Just title, Nothing      ) -> Just title
+                               (Nothing   , Just blogName) -> Just blogName
+                               (Just title, Just blogName) -> Just (title ++ " (" ++ blogName ++ ")")
+                   date    = Just ( Block ( Div [("class", "date")]
+                                            [Inline (Text (formatRFC1123DateTime zonedTime))]
+                                          )
+                                  )
+                   excerpt = do e <- tbExcerpt tb
+                                return $ Block $ Paragraph [Text e]
+
+               return $ catMaybes [anchor, date, excerpt]
\ No newline at end of file