mediawiki 0.2.3 → 0.2.4

raw patch · 7 files changed

+165/−69 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• MediaWiki/API.hs +8/−4
• MediaWiki/API/Output.hs +16/−13
• MediaWiki/API/Query/Categories.hs +12/−7
• MediaWiki/API/Query/Categories/Import.hs +14/−9
• MediaWiki/Util/Fetch.hs +74/−28
• examples/ListCat.hs +34/−6
• mediawiki.cabal +7/−2

@@ -48,26 +48,30 @@ 
 -- | @webGet mbUser url req@ issues a POST to a MediaWiki server, appending
 -- @api.php?@ followed by the request @req@ to the URL base @url@.
-webPost :: Maybe Fetch.User -> URLString -> String -> Request -> IO ([(String,String)], String)
+webPost :: Maybe Fetch.AuthUser -> URLString -> String -> Request -> IO ([(String,String)], String)
 webPost mbUser url act req = do
   let url_q  = url ++ "api.php?action="++act
   let pload  = showRequest req
-  postContentsURL mbUser url_q
+  (_cookiesOut, hs, p) <- 
+     postContentsURL mbUser 
+                  url_q
                   [ ("Content-Length", show $ length pload)
 		  , ("Content-Type",   showMIMEType form_mime_ty)
 		  ]
+		  [{-no cookies..-}]
 		  pload
+  return (hs, p)
  where
   form_mime_ty = Application "x-www-form-urlencoded"
 
 webPostXml :: (String -> Either (String,[String]) a)
-           -> Maybe Fetch.User
+           -> Maybe Fetch.AuthUser
            -> URLString
 	   -> String
 	   -> Request
 	   -> IO (Maybe a)
 webPostXml p mbUser url act req = do
-  (hs,mb) <- webPost mbUser url act req
+  (_hs,mb) <- webPost mbUser url act req
   case mb of
     "" -> return Nothing
     ls -> do

@@ -17,12 +17,12 @@ import MediaWiki.API.Types
 import MediaWiki.API.Base
 
+import MediaWiki.Util.Codec.Percent
+
 import Data.List
 import Data.Maybe
 
-
-showRequest :: Request
-            -> String
+showRequest :: Request -> String
 showRequest req = 
   join (showAction (reqAction req) : showMaxLag (reqMaxLag req) (showFormat (reqFormat req)))
 
@@ -129,16 +129,18 @@ 
 showQuery :: QueryRequest -> [String]
 showQuery q = catMaybes
-  [ fieldList "titles"  "," (quTitles q)
-  , fieldList "pageids" "," (quPageIds q)
-  , fieldList "revids"  "," (quRevIds q)
-  , fieldList "prop"    "|" (map showPropKind $ quProps q)
-  , fieldList "list"    "|" (map showListKind $ quLists q)
-  , fieldList "meta"    "|" (map showMetaKind $ quMetas q)
-  , fieldMb   "generator" showGeneratorKind  (quGenerator q)
-  , fieldMb   "redirects" showBool           (quFollowRedirects q)
-  , fieldMb   "indexpageids" showBool        (quIndexPageIds q)
+  [ fList    "titles"  (quTitles q)
+  , fList    "pageids" (quPageIds q)
+  , fList    "revids"  (quRevIds q)
+  , fList    "prop"    (map showPropKind $ quProps q)
+  , fList    "list"    (map showListKind $ quLists q)
+  , fList    "meta"    (map showMetaKind $ quMetas q)
+  , fieldMb  "generator"    showGeneratorKind  (quGenerator q)
+  , fieldMb  "redirects"    showBool           (quFollowRedirects q)
+  , fieldMb  "indexpageids" showBool           (quIndexPageIds q)
   ]
+ where
+  fList t ls = fieldList t "|" ls
 
 showExpandTemplates :: ExpandTemplatesRequest -> [String]
 showExpandTemplates et = catMaybes
@@ -205,5 +207,6 @@ 
 fieldList :: String -> String -> [String] -> Maybe String
 fieldList _ _ [] = Nothing
-fieldList n s xs = Just (field n (concat $ intersperse s xs))
+fieldList n s xs = Just (field n (intercalate (getEncodedString s) xs))
+
 

@@ -12,24 +12,30 @@ -- Representing 'categories' requests. --  ---------------------------------------------------------------------module MediaWiki.API.Query.Categories where+module MediaWiki.API.Query.Categories +       ( CategoriesRequest(..)+       , emptyCategoriesRequest+       +       , CategoriesResponse(..)+       , emptyCategoriesResponse+       ) where  import MediaWiki.API.Types import MediaWiki.API.Utils  data CategoriesRequest  = CategoriesRequest-    { clProps :: [PropKind]-    , clShow  :: Maybe Bool-    , clLimit :: Maybe Int+    { clProps        :: [PropKind]+    , clShow         :: Maybe Bool+    , clLimit        :: Maybe Int     , clContinueFrom :: Maybe String     }  instance APIRequest CategoriesRequest where   queryKind _ = QProp "categories"   showReq r = -   [ opt1 "clprop" (map prKind $ clProps r)-   , mbOpt "clshow" (\ x -> if x then "!hidden" else "hidden") (clShow r)+   [ opt1  "clprop" (map prKind $ clProps r)+   , mbOpt "clshow" (\ x -> (if x then ('!':) else id) "hidden") (clShow r)    , mbOpt "cllimit" show (clLimit r)    , mbOpt "clcontinue" id (clContinueFrom r)    ]@@ -41,7 +47,6 @@     , clLimit = Nothing     , clContinueFrom = Nothing     }-  data CategoriesResponse  = CategoriesResponse

@@ -19,21 +19,26 @@   p  <- pNode "query" es1   let es2 = children p   p  <- pNode "pages" es2-  let es = children p-  ps <- fmap (mapMaybe xmlPage) (fmap children $ pNode "page" es)+  let ps0 = pNodes "page" $ children p+  let ps1 = catMaybes (map xmlPage ps0)+--  ps <- fmap (mapMaybe xmlPage) (fmap children $ pNode "page" es)   let cont = pNode "query-continue" es1 >>= xmlContinue "categories" "clcontinue"-  return emptyCategoriesResponse{clPages=ps,clContinue=cont}+  return emptyCategoriesResponse{clPages=ps1,clContinue=cont}  xmlPage :: Element -> Maybe (PageTitle,[PageTitle]) xmlPage e = do    guard (elName e == nsName "page")    let es = children e-   p <- pNode "categories" es-   let es1 = children p-   cs <- fmap (mapMaybe xmlCL) (fmap children $ pNode "cl" es1)-   let ns     = fromMaybe "0" $ pAttr "ns" p-   let tit    = fromMaybe ""  $ pAttr "title" p-   let mbpid  = pAttr "pageid" p+     -- depending on being 'prop'-constrained, a 'page'+     -- may have a 'categories' child. (Or the page may not belong+     -- to a category at all, I suppose..)+   let cs = +        maybe []+              (\ c -> catMaybes (map xmlCL (pNodes "cl" $ children c)))+              (pNode "categories" es)+   let ns     = fromMaybe "0" $ pAttr "ns" e+   let tit    = fromMaybe ""  $ pAttr "title" e+   let mbpid  = pAttr "pageid" e    return (emptyPageTitle{pgNS=ns,pgTitle=tit,pgMbId=mbpid}, cs)  xmlCL :: Element -> Maybe PageTitle

@@ -17,7 +17,9 @@        , postContentsURL
 
 --       , URLString
-       , User(..)
+       , AuthUser(..)
+       , nullAuthUser
+       , Cookie
        ) where
        
 --import Network.Curl
@@ -27,11 +29,18 @@ 
 type URLString = String
 
-data User
- = User { userName :: String
-        , userPass :: String
-	}
+data AuthUser
+ = AuthUser 
+     { authUserName :: String
+     , authUserPass :: String
+     }
 
+nullAuthUser :: AuthUser
+nullAuthUser = AuthUser
+            { authUserName = ""
+	    , authUserPass = ""
+	    }
+
 readContentsURL :: URLString -> IO String
 readContentsURL u = do
   req <- 
@@ -54,18 +63,34 @@   return xs
 -}
 
-readUserContentsURL :: User -> URLString -> IO String
-readUserContentsURL usr us = do -- readContentsURL u
-  req <- 
+readUserContentsURL :: Maybe AuthUser -> Bool -> Bool -> URLString -> [(String,String)] -> IO ([(String,String)], String)
+readUserContentsURL mbU doRedir isHead us hdrs = do -- readContentsURL u
+  let hs = 
+       case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders 0 hdrs) of
+         Left{} -> []
+	 Right xs -> xs
+  req0 <- 
     case parseURI us of
       Nothing -> fail ("ill-formed URL: " ++ us)
       Just ur -> return (defaultGETRequest ur)
     -- don't like doing this, but HTTP is awfully chatty re: cookie handling..
+  let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $
+              req0{ rqMethod=if isHead then HEAD else GET
+	          , rqHeaders= hs
+		  , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing}
+	          }
   let nullHandler _ = return ()
   (u, resp) <- browse $ do 
-                  setOutHandler nullHandler
-                  setAllowBasicAuth True
-		  setAuthorityGen (\ _ _ -> return (Just (userName usr,userPass usr)))
+     setOutHandler nullHandler
+     case mbU of
+       Nothing -> return ()
+       Just usr -> do
+         setAllowRedirects doRedir
+         setAllowBasicAuth True
+         setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr)))
+
+--                  setAllowBasicAuth True
+--		  setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr)))
 {-
                   addAuthority AuthBasic{ auUsername = userName usr
                                         , auPassword = userPass usr
@@ -73,48 +98,69 @@                                         , auSite     = nullURI{uriPath="/"}
                                         }
 -}
-                  request req
+     request req
   case rspCode resp of
-    (2,_,_) -> return (rspBody resp)
+    (2,_,_) -> return (map toP (rspHeaders resp), rspBody resp)
+    (3,_,_) | not doRedir -> return (map toP (rspHeaders resp), rspBody resp)
     _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp))
 
 
-postContentsURL :: Maybe User -> URLString -> [(String,String)] -> String -> IO ([(String,String)], String)
-postContentsURL mbU u hdrs body = do
+postContentsURL :: Maybe AuthUser
+                -> URLString
+		-> [(String,String)]
+		-> [Cookie]
+		-> String
+		-> IO ([Cookie],[(String,String)], String)
+postContentsURL mbU u hdrs csIn body = do
   let hs = 
-       case parseHeaders $ map (\ (x,y) -> x++": " ++ y) hdrs of
+       case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders  (length body) hdrs) of
          Left{} -> []
 	 Right xs -> xs
   req0 <- 
     case parseURI u of
       Nothing -> fail ("ill-formed URL: " ++ u)
       Just ur -> return (defaultGETRequest ur)
-  let req = req0{rqMethod=POST
-                ,rqBody=body
-		,rqHeaders=hs
-	        }
+  let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $
+              req0{ rqMethod=POST
+                  , rqBody=body
+		  , rqHeaders= hs
+		  , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing}
+	          }
+--  print req -- ,body)
   let nullHandler _ = return ()
-  (_,rsp) <- browse $ do
+  ((_,rsp),cs) <- browse $ do
      setOutHandler nullHandler
+     setAllowRedirects True
+     setCookies csIn
      case mbU of
        Nothing -> return ()
        Just usr -> do
          setAllowBasicAuth True
-         setAuthorityGen (\ _ _ -> return (Just (userName usr,userPass usr)))
+         setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr)))
 		   
-     request req
+     v <- request req
+     ls <- getCookies
+     return (v,ls)
   case rspCode rsp of
-    (2,_,_) -> return (map toP (rspHeaders rsp), rspBody rsp)
-    x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u)
+    (2,_,_) -> return (cs,map toP (rspHeaders rsp), rspBody rsp)
+    x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u ++ show (rspBody rsp))
+
+toP :: Header -> (String, String)
+toP (Header k v) = (show k, v)
+
+addDefaultHeaders :: Int -> [(String,String)] -> [(String,String)]
+addDefaultHeaders clen hs = 
+  addIfMiss "User-Agent" "hs-twitter" $
+  addIfMiss "Content-Length"  (show clen) hs
  where
-  toP (Header k v) = (show k, v)
+  addIfMiss f v xs = maybe ((f,v):xs) (const xs) (lookup f xs)
 
 {- Curl versions:
 readUserContentsURL :: User -> URLString -> IO String
 readUserContentsURL u url = do
   let opts = [ CurlHttpAuth [HttpAuthAny]
-             , CurlUserPwd (userName u ++ 
-	                    case userPass u of {"" -> ""; p -> ':':p })
+             , CurlUserPwd (authUserName u ++ 
+	                    case authUserPass u of {"" -> ""; p -> ':':p })
              , CurlFollowLocation True
 	     ] 
   (_,xs) <- curlGetString url opts

@@ -14,6 +14,9 @@ import MediaWiki.API.Query.CategoryMembers as CatMem
 import MediaWiki.API.Query.CategoryMembers.Import as CatMem
 
+import MediaWiki.API.Query.Categories as Cats
+import MediaWiki.API.Query.Categories.Import as Cats
+
 import Util.GetOpts
 import System.IO
 import System.Environment
@@ -30,6 +33,7 @@     , optUser    :: Maybe String
     , optPass    :: Maybe String
     , optCat     :: Maybe String
+    , optPage    :: Maybe String
     }
 
 nullOptions :: Options
@@ -38,6 +42,7 @@     , optUser    = Nothing
     , optPass    = Nothing
     , optCat     = Nothing
+    , optPage    = Nothing
     }
 
 option_descr :: [OptDescr (Options -> Options)]
@@ -54,6 +59,9 @@   , Option ['c'] ["cat"]
            (ReqArg (\ x o -> o{optCat=Just x}) "CAT")
 	   "the Wiki category to query for"
+  , Option ['P'] ["page"]
+           (ReqArg (\ x o -> o{optPage=Just x}) "PAGE")
+	   "the page title to list category pages for"
   ]
 
 
@@ -98,6 +106,20 @@         Nothing -> return acc'
 	Just x  -> queryCat' url catName cReq{cmContinueFrom=Just x} acc'
 
+queryPageCats :: URLString -> String -> IO [PageTitle]
+queryPageCats url pgName = queryPageCats' emptyCategoriesRequest []
+ where
+  queryPageCats' cReq acc = do
+    let req = emptyXmlRequest (mkQueryAction (queryPage pgName) cReq)
+    mb <- webGetXml Cats.stringXml url req
+    case mb of
+      Nothing -> fail ("Failed to fetch page" ++ pgName ++ " from " ++ url)
+      Just c  -> do
+        let acc' = (acc ++ clPages c)
+        case clContinue c of
+          Nothing -> return (concatMap snd acc')
+	  Just x  -> queryPageCats' cReq{clContinueFrom=Just x} acc'
+
 main :: IO ()
 main = do
   (opts, fs) <- processOptions
@@ -111,8 +133,11 @@          Just lg -> print (lgSuccess lg)
     _ -> return ()
   case mbCons (optCat opts) fs of
-    [] -> putStrLn "No categories specified!"
+    [] -> putStrLn "No categories specified."
     xs -> mapM_ (showCat url) xs
+  case mbCons (optPage opts) fs of
+    [] -> return ()
+    xs -> mapM_ (showPages url) xs
 
 showCat :: URLString -> String -> IO ()
 showCat url cat = do
@@ -121,11 +146,14 @@   mapM_ (putStrLn.toTitle) ps
  where
   toTitle pg = ' ':pgTitle pg
-{- NS prefix seems to be included in title..
-    case pgNS pg of
-      "" -> pgTitle pg
-      xs -> xs ++ ':':pgTitle pg
--}
+
+showPages :: URLString -> String -> IO ()
+showPages url pgName = do
+  ps <- queryPageCats url pgName
+  putStrLn ("Page " ++ show pgName ++ " is a member of the following categories: ")
+  mapM_ (putStrLn.toTitle) ps
+ where
+  toTitle pg = ' ':pgTitle pg
 
 mbCons :: Maybe a -> [a] -> [a]
 mbCons Nothing xs = xs

@@ -1,10 +1,15 @@ Name:               mediawiki
-Version:            0.2.3
+Version:            0.2.4
 License:            BSD3
 License-file:       LICENSE
 Category:           Web
 Synopsis:           Interfacing with the MediaWiki API
-Description:        A complete Haskell binding to the MediaWiki API
+Description:        
+  A complete Haskell binding to the MediaWiki API letting you
+  programmatically access (read and write) MediaWiki content.
+  .
+  See <http://www.mediawiki.org/wiki/API> and <http://haskell.forkio.com/>
+  for more.
 Author:             Sigbjorn Finne <sof@forkIO.com>
 Maintainer:         Sigbjorn Finne <sof@forkIO.com>
 Cabal-version:   >= 1.2