Rakka/Wiki/Interpreter/Trackback.hs

   1 module Rakka.Wiki.Interpreter.Trackback
   2     ( interpreters
   3     )
   4     where
   5
   6 import           Data.Maybe
   7 import           Data.Time
   8 import           Network.HTTP.Lucu.RFC1123DateTime
   9 import           Rakka.Page
  10 import           Rakka.Storage
  11 import           Rakka.SystemConfig
  12 import           Rakka.TrackBack
  13 import           Rakka.Wiki
  14 import           Rakka.Wiki.Interpreter
  15
  16
  17 interpreters :: [Interpreter]
  18 interpreters = [ trackbackURLInterp
  19                , trackbacksInterp
  20                ]
  21
  22
  23 trackbackURLInterp :: Interpreter
  24 trackbackURLInterp
  25     = InlineCommandInterpreter {
  26         iciName = "trackbackURL"
  27       , iciInterpret
  28           = \ ctx _ -> case ctxPageName ctx of
  29                          Nothing
  30                              -> return (Text "No trackbacks for this page.")
  31                          Just name
  32                              -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
  33                                    let uri = mkAuxiliaryURI baseURI ["trackback"] name
  34                                    return $ ExternalLink uri (Just "Trackback URL")
  35       }
  36
  37
  38 trackbacksInterp :: Interpreter
  39 trackbacksInterp
  40     = BlockCommandInterpreter {
  41         bciName = "trackbacks"
  42       , bciInterpret
  43           = \ ctx _ ->
  44             do trackbacks <- case ctxPageName ctx of
  45                                Nothing
  46                                    -> return []
  47                                Just name
  48                                    -> liftM (fromMaybe [])
  49                                             (getAttachment (ctxStorage ctx) name "trackbacks" Nothing)
  50                items <- mapM mkListItem trackbacks
  51
  52                let divElem = Div [("class", "trackbacks")] [list]
  53                    list    = Block (List Bullet items)
  54
  55                return divElem
  56       }
  57     where
  58       mkListItem :: TrackBack -> IO ListItem
  59       mkListItem tb
  60           = do zonedTime <- utcToLocalZonedTime (tbTime tb)
  61
  62                let anchor  = Just (Inline (ExternalLink (tbURL tb) label))
  63                    label   = case (tbTitle tb, tbBlogName tb) of
  64                                (Nothing   , Nothing      ) -> Nothing
  65                                (Just title, Nothing      ) -> Just title
  66                                (Nothing   , Just blogName) -> Just blogName
  67                                (Just title, Just blogName) -> Just (title ++ " (" ++ blogName ++ ")")
  68                    date    = Just ( Block ( Div [("class", "date")]
  69                                             [Inline (Text (formatRFC1123DateTime zonedTime))]
  70                                           )
  71                                   )
  72                    excerpt = do e <- tbExcerpt tb
  73                                 return $ Block $ Paragraph [Text e]
  74
  75                return $ catMaybes [anchor, date, excerpt]