flickr 0.2.2 → 0.3.0

raw patch · 5 files changed

+233/−3 lines, 5 filesnew-component:exe:mtagsPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Flickr/MachineTags.hs +53/−0
• Flickr/Types.hs +42/−0
• Flickr/Types/Import.hs +80/−2
• examples/ShowTags.hs +50/−0
• flickr.cabal +8/−1

@@ -0,0 +1,53 @@+--------------------------------------------------------------------
+-- |
+-- Module      : Flickr.MachineTags
+-- Description : flickr.machinetags - fetch photos by triple (ns,pred,val) tags.
+-- Copyright   : (c) Sigbjorn Finne, 2008
+-- License     : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- The flickr.machinetags API, fetching photos by their machinetags.
+--------------------------------------------------------------------
+module Flickr.MachineTags where
+
+import Flickr.Monad
+import Flickr.Types
+import Flickr.Types.Import
+
+-- | Return a list of unique namespaces, optionally limited by a given predicate, in alphabetical order.
+getNamespaces :: Maybe String -- ^ optional predicate
+              -> FM (NameContext, [Namespace])
+getNamespaces mbPred = 
+   flickTranslate toNamespaceList $
+     flickrCall "flickr.machinetags.getNamespaces"
+                (mbArg "predicate" mbPred [])
+
+-- | Return a list of unique namespace and predicate pairs, optionally 
+-- limited by predicate or namespace, in alphabetical order.
+getPairs :: Maybe String  -- ^ namespace constraint
+         -> Maybe String  -- ^ predicate constraint
+	 -> FM (ResContext MachineTagPair, [MachineTagPair])
+getPairs mbNS mbPred = 
+   flickTranslate toPairList $
+     flickrCall "flickr.machinetags.getPairs"
+                (mbArg "predicate" mbPred $ 
+		 mbArg "namespace" mbNS [])
+
+-- | Return a list of unique predicates, optionally limited by a given namespace.
+getPredicates :: Maybe String -> FM (ResContext MachineTagPred, [MachineTagPred])
+getPredicates mbNS = 
+   flickTranslate toPredList $
+     flickrCall "flickr.machinetags.getPredicates"
+                (mbArg "namespace" mbNS [])
+
+-- | Return a list of unique values for a namespace and predicate.
+getValues :: String -> String -> FM (ResContext MachineTag, [MachineTag])
+getValues ns pre = 
+   flickTranslate toMachineTagList $
+     flickrCall "flickr.machinetags.getValues"
+                [ ("namespace", ns)
+		, ("predicate", pre)
+		]

@@ -561,3 +561,45 @@      , sizeDetailsSource :: URLString
      , sizeDetailsURL    :: URLString
      }
+
+type NameContext = ResContext Namespace
+
+data Namespace
+ = Namespace
+     { namespaceUsage  :: Integer
+     , namespacePreds  :: Integer
+     , namespaceName   :: String
+     }
+
+data ResContext a
+ = ResContext
+     { resCtxtPage    :: Maybe Int
+     , resCtxtPages   :: Maybe Int
+     , resCtxtPerPage :: Maybe Int
+     , resCtxtTotal   :: Maybe Int
+     }
+
+data MachineTagPair
+ = MachineTagPair
+     { mtPairNamespace :: String
+     , mtPairPredicate :: String
+     , mtPairUsage     :: Integer
+     , mtPairName      :: String
+     }
+
+data MachineTagPred
+ = MachineTagPred
+     { mtPredNamespaces :: Integer
+     , mtPredUsage      :: Integer
+     , mtPredName       :: String
+     }
+
+data MachineTag
+ = MachineTag
+     { mTagNamespace :: String
+     , mTagPredicate :: String
+     , mTagUsage     :: Integer
+     , mTagValue     :: String
+     }
+
+ 

@@ -355,8 +355,6 @@   s <- findChild (nsName "nextphoto") e >>= eltPhoto    return (f,s) -- eltPhoto :: Element -> Maybe Photo eltPhoto e = do   pid <- pAttr "id" e@@ -804,3 +802,83 @@ eltTagDetailsList e = do   t <- pNode "tags" (children e)   return $ mapMaybe eltTagDetails $ pNodes "tag" (children t)++toNamespaceList :: String -> ErrM (NameContext, [Namespace])+toNamespaceList s = parseDoc eltNamespaceList s++eltNamespaceList :: Element -> Maybe (NameContext, [Namespace])+eltNamespaceList e = ifNamed "namespaces" e $ do+  ls <- mapM eltNamespace $ pNodes "namespace" (children e)+  c  <- eltResContext e+  return (c, ls)++eltResContext :: Element -> Maybe (ResContext a)+eltResContext e = + return ResContext+     { resCtxtPage    = eltIntAttr "page" e+     , resCtxtPages   = eltIntAttr "pages" e+     , resCtxtPerPage = eltIntAttr "perpage" e+     , resCtxtTotal   = eltIntAttr "total" e+     }++eltNamespace :: Element -> Maybe Namespace+eltNamespace e = ifNamed "namespace" e $ do+  return Namespace+    { namespaceUsage = fromIntegral $ fromMaybe 0 (eltIntAttr "usage" e)+    , namespacePreds = fromIntegral $ fromMaybe 0 (eltIntAttr "predicates" e)+    , namespaceName  = strContent e+    }++eltMTPair :: Element -> Maybe MachineTagPair+eltMTPair e = ifNamed "pair" e $ do+  return MachineTagPair+    { mtPairNamespace = fromMaybe "" (pAttr "namespace" e)+    , mtPairPredicate = fromMaybe "" (pAttr "predicate" e)+    , mtPairUsage     = fromIntegral $ fromMaybe 0 (eltIntAttr "usage" e)+    , mtPairName      = strContent e+    }++eltMTPred :: Element -> Maybe MachineTagPred+eltMTPred e = ifNamed "predicate" e $ do+  return MachineTagPred+    { mtPredNamespaces = fromIntegral $ fromMaybe 0 (eltIntAttr "namespaces" e)+    , mtPredUsage      = fromIntegral $ fromMaybe 0 (eltIntAttr "usage" e)+    , mtPredName       = strContent e+    }++eltMTag :: Element -> Maybe MachineTag+eltMTag e = ifNamed "value" e $ do+  return MachineTag+    { mTagNamespace = ""+    , mTagPredicate = ""+    , mTagUsage     = fromIntegral $ fromMaybe 0 (eltIntAttr "usage" e)+    , mTagValue     = strContent e+    }++toMachineTagList :: String -> ErrM (ResContext MachineTag, [MachineTag])+toMachineTagList s = parseDoc eltMachineTagList s++eltMachineTagList :: Element -> Maybe (ResContext MachineTag, [MachineTag])+eltMachineTagList e = ifNamed "values" e $ do+  ls <- mapM eltMTag $ pNodes "value" (children e)+  c  <- eltResContext e+  return (c, ls)++toPredList :: String -> ErrM (ResContext MachineTagPred, [MachineTagPred])+toPredList s = parseDoc eltMachinePredList s++eltMachinePredList :: Element -> Maybe (ResContext MachineTagPred, [MachineTagPred])+eltMachinePredList e = ifNamed "predicates" e $ do+  ls <- mapM eltMTPred $ pNodes "predicate" (children e)+  c  <- eltResContext e+  return (c, ls)++toPairList :: String -> ErrM (ResContext MachineTagPair, [MachineTagPair])+toPairList s = parseDoc eltMachinePairList s++eltMachinePairList :: Element -> Maybe (ResContext MachineTagPair, [MachineTagPair])+eltMachinePairList e = ifNamed "pairs" e $ do+  ls <- mapM eltMTPair $ pNodes "pair" (children e)+  c  <- eltResContext e+  return (c, ls)+

@@ -0,0 +1,50 @@+{-
+  List machine tag info example.
+-}
+module Main(main) where
+
+import Flickr.API
+import Util.Keys ( hsflickrAPIKey )
+
+import Flickr.MachineTags as MT
+import System.Environment
+
+getTags :: String -> String -> FM [MachineTag]
+getTags ns pre = do
+  (_, xs) <- MT.getValues ns pre
+  return xs
+
+getPreds :: Maybe String -> FM [MachineTagPred]
+getPreds ns = do
+  (_, xs) <- MT.getPredicates ns
+  return xs
+
+getNSes :: Maybe String -> FM [Namespace]
+getNSes mbP = do
+  (_, xs) <- MT.getNamespaces mbP
+  return xs
+
+main :: IO ()
+main = do
+  ls <- getArgs
+  case ls of
+    [] -> do
+      prg <- getProgName
+      putStrLn ("Usage: " ++ prg ++ " {+[pred],-,namespace} [predicate]")
+    [ns] -> do
+      (l,ps) <- flickAPI hsflickrAPIKey $ 
+             case ns of
+	       ('+':pr) -> do
+	         rs <- getNSes (if null pr then Nothing else Just pr) >>= return.(map namespaceName)
+		 return ("namespaces with predicate: " ++ ns, rs)
+	       _   -> do
+	         rs <- getPreds (if ns == "-" then Nothing else Just ns) >>= return.(map mtPredName)
+		 return ("predicates for NS: " ++ ns, rs)
+      putStrLn ("Machine tag " ++ l)
+      mapM_ (\ p -> putStrLn (' ':p)) ps
+    (ns:pre:_) -> do
+      ps <- flickAPI hsflickrAPIKey $ getTags ns pre
+      putStrLn ("Machine tags for (NS,pred) pair: " ++ show (ns,pre))
+      mapM_ (\ p -> putStrLn (' ':mTagValue p)) ps
+
+  

@@ -1,5 +1,5 @@ name: flickr
-version: 0.2.2
+version: 0.3.0
 Synopsis: Haskell binding to the Flickr API
 Description:
    The flickr API binding lets you access flickr.com's
@@ -18,6 +18,7 @@                     examples/Gallery.hs
                     examples/SearchPhotos.hs
                     examples/ShowPublicPhotos.hs
+                    examples/ShowTags.hs
 
 flag new-base
   Description: Build with new smaller base library
@@ -36,6 +37,7 @@                   Flickr.Groups,
                   Flickr.Groups.Pools,
                   Flickr.Interestingness,
+                  Flickr.MachineTags,
                   Flickr.Prefs,
                   Flickr.People,
                   Flickr.Photos,
@@ -88,5 +90,10 @@ 
 executable uploader {
   main-is:              examples/Uploader.hs
+  ghc-options:          -Wall
+}
+
+executable mtags {
+  main-is:              examples/ShowTags.hs
   ghc-options:          -Wall
 }