Resurrection from bitrot

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

diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs
index 2a10372d1b4e253c6cf174e11cb2ca7d2236e1c1..d94f67ea1545a597b511c8f116e8fac5ebe37c44 100644 (file)
--- a/Rakka/Wiki/Interpreter/PageList.hs
+++ b/Rakka/Wiki/Interpreter/PageList.hs
@@ -1,26 +1,57 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Rakka.Wiki.Interpreter.PageList
     ( interpreters
     )
     where
-
-import           Data.Maybe
-import           Network.HTTP.Lucu.RFC1123DateTime
-import           Rakka.Page
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import Data.Monoid.Unicode
+import qualified Data.Text as T
+import           Data.Time
+import qualified Data.Time.RFC1123 as RFC1123
+import           Network.URI
+import Prelude.Unicode
 import           Rakka.Storage
+import           Rakka.SystemConfig
+import           Rakka.Utils
 import           Rakka.Wiki
 import           Rakka.Wiki.Interpreter
+import           System.FilePath
 import           Text.HyperEstraier
 
 
 interpreters :: [Interpreter]
-interpreters = [ recentUpdatesInterp ]
+interpreters = [ recentUpdatesURLInterp
+               , recentUpdatesInterp
+               ]
+
+
+recentUpdatesURLInterp :: Interpreter
+recentUpdatesURLInterp
+    = InlineCommandInterpreter {
+        iciName = "recentUpdatesURL"
+      , iciInterpret
+          = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
+                          let uri = baseURI {
+                                      uriPath  = uriPath baseURI </> "search.html"
+                                    , uriQuery = '?' : mkQueryString [ ("q"    , "[UVSET]")
+                                                                     , ("order", "@mdate NUMD")
+                                                                     ]
+                                    }
+                          return $ ExternalLink uri (Just "List all pages")
+      }
 
 
 -- <div class="recentUpdates">
 --   <ul>
 --     <li>
 --       <a href="...">...</a>
---       <span class="date">...</span>
+--       <div class="date">...</div>
 --       <p> <!-- サマリが無ければ存在しない -->
 --         blah blah...
 --       </p>
@@ -28,48 +59,49 @@ interpreters = [ recentUpdatesInterp ]
 --     ...
 --   </ul>
 -- </div>
-recentUpdatesInterp :: Interpreter
+recentUpdatesInterp ∷ Interpreter
 recentUpdatesInterp 
     = BlockCommandInterpreter {
         bciName      = "recentUpdates"
       , bciInterpret
-          = \ ctx (BlockCommand _ args _)
-          -> do let items = fromMaybe 10 $ fmap read $ lookup "items" args
-                    sto   = ctxStorage ctx
-                
-                cond <- newCondition
-                setPhrase   cond "[UVSET]"
-                addAttrCond cond "rakka:isBoring STREQ no"
-                addAttrCond cond "rakka:summary STRNE" -- summary が空でない
-                setOrder    cond "@mdate NUMD"
-                setMax      cond items
-
-                result <- searchPages sto cond
-                pages  <- mapM ( \ (name, rev)
-                                     -> getPage sto name (Just rev) >>= return . fromJust
-                               ) result
-
-                return $ mkPageList pages
+          = \(InterpreterContext {..}) (BlockCommand _ args _) →
+            do let items          = fromMaybe 10   $ read ∘ T.unpack <$> lookup "items" args
+                   showSummary    = fromMaybe True $ parseYesOrNo    <$> lookup "showSummary" args
+                   onlyEntity     = fromMaybe True $ parseYesOrNo    <$> lookup "onlyEntity" args
+                   onlySummarized = fromMaybe True $ parseYesOrNo    <$> lookup "onlySummarized" args
+               cond ← newCondition
+               when onlyEntity
+                   $ addAttrCond cond "@type STRNE application/x-rakka-redirection"
+               when onlySummarized
+                   $ addAttrCond cond "rakka:summary STRNE" -- summary が空でない
+               setPhrase cond "[UVSET]"
+               setOrder  cond "@mdate NUMD"
+               setMax    cond items
+               result ← searchPages ctxStorage cond
+               mkPageList showSummary (srPages result)
       }
     where
-      mkPageList :: [Page] -> BlockElement
-      mkPageList pages
-          = Div [("class", "recentUpdates")]
-            [ Block (List Bullet (map mkListItem pages)) ]
+      mkPageList :: Bool -> [HitPage] -> IO BlockElement
+      mkPageList showSummary pages
+          = do items <- mapM (mkListItem showSummary) pages
+               return (Div [("class", "recentUpdates")]
+                       [ Block (List Bullet items) ])
 
-      mkListItem :: Page -> ListItem
-      mkListItem page
-          = [ Inline ( PageLink {
-                         linkPage     = Just (pageName page)
-                       , linkFragment = Nothing
-                       , linkText     = Nothing
-                       }
-                    )
-            , Inline ( Span [("class", "date")]
-                                [Text (formatRFC1123DateTime (pageLastMod page))]
-                     )
-            ]
-            ++
-            case pageSummary page of
-              Just s  -> [ Block (Paragraph [Text s]) ]
-              Nothing -> []
+      mkListItem ∷ Bool → HitPage → IO ListItem
+      mkListItem showSummary page
+          = do lastMod ← utcToLocalZonedTime (hpLastMod page)
+               return ( [ Inline PageLink {
+                                       linkPage     = Just (hpPageName page)
+                                     , linkFragment = Nothing
+                                     , linkText     = Nothing
+                                     }
+                        , Block ( Div [("class", "date")]
+                                  [Inline (Text (T.pack $ RFC1123.format lastMod))]
+                                )
+                        ]
+                        ⊕
+                        case (showSummary, hpSummary page) of
+                          (True, Just s)
+                              → [ Block (Paragraph [Text s]) ]
+                          _   → []
+                      )