ffeed 0.3 → 0.3.1
raw patch · 2 files changed
+587/−9 lines, 2 filesdep ~base
Dependency ranges changed: base
Files
- FriendFeed/Types/Import.hs +578/−0
- ffeed.cabal +9/−9
+ FriendFeed/Types/Import.hs view
@@ -0,0 +1,578 @@+{-# OPTIONS_GHC -XFlexibleInstances -XUndecidableInstances -XOverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Types.Import +-- Description : Converting to/from FriendFeed JSON payloads. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- Stability : provisional +-- Portability: portable +-- +-- (De)serializing JSON values representing FriendFeed API data types. +-- +-------------------------------------------------------------------- +module FriendFeed.Types.Import where + +import FriendFeed.Types + +import Text.JSON +import Text.JSON.Types + +import Data.Char +import Data.Maybe +import Control.Monad + +--import Debug.Trace + +data JM a = JM (String -> [(String,JSValue)] -> Result a) + +instance Monad JM where + return x = JM (\ _ _ -> return x) + (JM a) >>= k = JM $ \ loc env -> do + v <- a loc env + case k v of + (JM b) -> b loc env + +(-=>) :: a -> b -> (a,b) +(-=>) a b = (a,b) + +runJM :: String -> [(String,JSValue)] -> JM a -> Result a +runJM loc ps (JM a) = a loc ps + +liftR :: Result a -> JM a +liftR r = JM $ \ _ _ -> r + +getLoc :: JM String +getLoc = JM (\ l _ -> return l) + +get :: String -> JM String +get k = do + m <- getMb k + case m of + Just (JSString s) -> return (fromJSString s) + Just js -> return (showJSValue js "") + Nothing -> do + loc <- getLoc + fail (loc ++ ": missing value for key " ++ show k) + +getInt :: String -> JM Integer +getInt k = do + s <- get k + case reads s of + ((v,_):_) -> return v + _ -> do + loc <- getLoc + fail (loc ++ ": expected valid int, got " ++ show s) + +getMbS :: String -> JM (Maybe String) +getMbS k = do + v <- getMb k + case v of + Just (JSString s) -> return (Just (fromJSString s)) + _ -> return Nothing + +getMb :: String -> JM (Maybe JSValue) +getMb k = JM $ \ _loc env -> return (lookup k env) + +getB :: String -> JM Bool +getB v = do + b <- get v + case map toLower b of + "true" -> return True + "false" -> return False + "0" -> return False + "1" -> return True + bs -> do + loc <- getLoc + fail (loc ++ ": expected valid bool, got " ++ show bs) + + +getJSON :: String -> JM JSValue +getJSON k = do + mb <- getMb k + case mb of + Just x -> return x + Nothing -> do + loc <- getLoc + fail (loc ++ ": missing value for key " ++ show k) + +showJS :: (a -> [(String, JSValue)]) -> a -> JSValue +showJS f x = JSObject (toJSObject (f x)) + +readJS :: String -> a -> (JM a) -> JSValue -> Result a +readJS _ n _ (JSArray []) = return n +readJS m n f (JSArray [x]) = readJS m n f x +readJS m _ f (JSObject (JSONObject pairs)) = runJM m pairs f +readJS m _ _ v = fail (m ++ ": unexpected JSON value " ++ show v) + +readJSONs :: JSON a => JSValue -> Result [a] +readJSONs ls@JSArray{} = readJSON ls +readJSONs x = readJSON (JSArray [x]) + +toEntry :: String -> Result Entry +toEntry s = decodeStrict s + +toList :: String -> Result List +toList s = decodeStrict s + +instance JSON a => Show a where + show x = showJSValue (showJSON x) "" + +instance JSON Entry where + showJSON e = showJS showEntry e + readJSON m = readJS "FriendFeed.Types.Entry" nullEntry readEntry m + +showEntry :: Entry -> [(String, JSValue)] +showEntry e = + [ "id" -=> showJSON (JSONString (entryId e)) + , "title" -=> showJSON (JSONString (entryTitle e)) + , "link" -=> showJSON (JSONString (entryLink e)) + , "published" -=> showJSON (JSONString (entryPublished e)) + , "updated" -=> showJSON (JSONString (entryUpdated e)) + , "hidden" -=> showJSON (JSONString (map toLower $ show $ entryIsHidden e)) + , "anonymous" -=> showJSON (JSONString (map toLower $ show $ entryIsAnon e)) + , "user" -=> showJSON (entryUser e) + , "service" -=> showJSON (entryService e) + , "comments" -=> JSArray (map showJSON (entryComments e)) + , "likes" -=> JSArray (map showJSON (entryLikes e)) + , "media" -=> JSArray (map showJSON (entryMedia e)) + ] ++ catMaybes + [ mb "via" (fmap (showJS showVia) (entryVia e)) + , mb "room" (fmap showJSON (entryRoom e)) + ] + where + mb _ Nothing = Nothing + mb t (Just v) = Just (t,v) + +readEntry :: JM Entry +readEntry = do + [i,tit,lnk,pub,upd] <- mapM get ["id","title","link","published","updated"] + ish <- getB "hidden" + isa <- getB "anonymous" + usr <- getJSON "user" >>= \ x -> liftR (readJSON x) + s <- getJSON "service" >>= \ x -> liftR (readJSON x) +-- cs <- getJSON "comments" >>= \ x -> liftR (readJSON x) + cs <- return [] +-- ms <- getJSON "media" >>= \ x -> liftR (readJSON x) + ms <- return [] + likes <- getJSON "likes" >>= \ x -> liftR (readJSON x) +-- likes <- return [] + mbV <- getMb "via" + mbVia <- case mbV of { Nothing -> return Nothing ; Just v -> liftR $ readVia v >>= return.Just} + mbR <- getMb "room" + mbRoom <- case mbR of { Nothing -> return Nothing ; Just r -> liftR (readJSON r) >>= return.Just } + return nullEntry + { entryId = i + , entryTitle = tit + , entryLink = lnk + , entryPublished = pub + , entryUpdated = upd + , entryIsHidden = ish + , entryIsAnon = isa + , entryUser = usr + , entryService = s + , entryLikes = likes + , entryComments = cs + , entryMedia = ms + , entryVia = mbVia + , entryRoom = mbRoom + } + +instance JSON List where + showJSON l = showJS showFFList l + readJSON m = readJS "FriendFeed.Types.List" nullList readFFList m + +showFFList :: List -> [(String,JSValue)] +showFFList l = + [ "id" -=> showJSON (JSONString (listId l)) + , "name" -=> showJSON (JSONString (listName l)) + , "nickname" -=> showJSON (JSONString (listNickname l)) + , "url" -=> showJSON (JSONString (listURL l)) + , "users" -=> JSArray (map showJSON (listUsers l)) + , "rooms" -=> JSArray (map showJSON (listRooms l)) + ] + +readFFList :: JM List +readFFList = do + [i,name,nick,u] <- mapM get [ "id", "name", "nickname", "url"] + us <- getJSON "users" + usrs <- liftR (readJSON us) + rms <- getJSON "room" >>= liftR.readJSON + return $ nullList + { listId = i + , listName = name + , listNickname = nick + , listURL = u + , listUsers = usrs + , listRooms = rms + } + +readVia :: JSValue -> Result Via +readVia = readJS "FriendFeed.Types.Via" nullVia readV + where + readV = do + n <- get "name" + u <- get "url" + return (n,u) + +showVia :: Via -> [(String, JSValue)] +showVia (s,v) = [ "name" -=> showJSON (JSONString s) + , "url" -=> showJSON (JSONString v) + ] + +{- +readResource :: JSValue -> Result (Resource a) +readResource = readJS "FriendFeed.Types.Resource" nullResource readR + where + readR = do + i <- get "id" + nm <- get "name" + ni <- get "nickname" + u <- getMbS "url" + pu <- getMbS "profileUrl" + return nullResource + { resourceId = i + , resourceName = nm + , resourceNickname = ni + , resourceUrl = u `mplus` pu + } + +readRoom :: JSValue -> Result Room +readRoom = readJS "FriendFeed.Types.Via" nullRoom readR + where + readR = do + i <- get "id" + nm <- get "name" + ni <- get "nickname" + u <- get "url" + return nullRoom{ roomId = i + , roomName = nm + , roomNickname = ni + , roomUrl = u + } +-} + +instance JSON Comment where + showJSON c = showJS showComment c + readJSON m = readJS "FriendFeed.Types.Comment" nullComment readComment m + +showComment :: Comment -> [(String,JSValue)] +showComment c = + [ "date" -=> showJSON (JSONString (commentDate c)) + , "user" -=> JSArray (map showJSON (commentUser c)) + , "body" -=> showJSON (JSONString (commentBody c)) + ] + +readComment :: JM Comment +readComment = do + d <- get "date" + b <- get "body" + usrs <- getJSON "user" >>= liftR.readJSON + return $ nullComment + { commentDate = d + , commentBody = b + , commentUser = usrs + } + +instance JSON User where + showJSON u = showJS showUser u + readJSON m = readJS "FriendFeed.Types.User" nullUser readUser m + +showStr :: String -> JSValue +showStr x = showJSON (JSONString x) + +showUser :: User -> [(String,JSValue)] +showUser u = + [ "status" -=> showStr (userStatus u) + , "id" -=> showStr (userId u) + , "name" -=> showStr (userName u) + , "nickname" -=> showStr (userNickname u) + , "profileUrl" -=> showStr (userProfileURL u) + , "services" -=> JSArray (map showJSON (userServices u)) + , "subscriptions" -=> JSArray (map showJSON (userSubscriptions u)) + , "rooms" -=> JSArray (map showJSON (userRooms u)) + , "lists" -=> JSArray (map showJSON (userLists u)) + ] + +readUser :: JM User +readUser = do + st <- get "status" + i <- get "id" + nm <- get "name" + ni <- get "nickname" + pu <- getMbS "profileUrl" + u <- getMbS "url" + ses <- getJSON "services" >>= liftR.readJSON + sus <- getJSON "subscriptions" >>= liftR.readJSON + ros <- getJSON "rooms" >>= liftR.readJSON + lis <- do + mb <- getMb "lists" + case mb of + Nothing -> return [] + Just s -> liftR (readJSON s) + return nullUser + { userStatus = st + , userId = i + , userName = nm + , userNickname = ni + , userProfileURL = fromMaybe "" (u `mplus` pu) + , userServices = ses + , userSubscriptions = sus + , userRooms = ros + , userLists = lis + } + +instance JSON (Resource a) where + showJSON l = showJS showResource l + readJSON m = readJS "FriendFeed.Types.Resource" + nullResource + readResource m + +instance JSON Like where + showJSON l = showJS showLike l + readJSON m = readJS "FriendFeed.Types.Like" + nullLike + readLike m + +instance JSON Room where + showJSON r = showJS showRoom r + readJSON m = readJS "FriendFeed.Types.Room" + nullRoom + readRoom m + +instance JSON Enclosure where + showJSON e = showJS showEnclosure e + readJSON m = readJS "FriendFeed.Types.Enclosure" + nullEnclosure + readEnclosure m + +instance JSON Content where + showJSON c = showJS showContent c + readJSON m = readJS "FriendFeed.Types.Content" + nullContent + readContent m + +instance JSON Thumbnail where + showJSON t = showJS showThumbnail t + readJSON m = readJS "FriendFeed.Types.Thumbnail" + nullThumbnail + readThumbnail m + +instance JSON Media where + showJSON u = showJS showMedia u + readJSON m = readJS "FriendFeed.Types.Media" nullMedia readMedia m + +instance JSON Service where + showJSON u = showJS showService u + readJSON m = readJS "FriendFeed.Types.User" nullService readService m + +showRoom :: Room -> [(String,JSValue)] +showRoom r = + [ "id" -=> showStr (roomId r) + , "name" -=> showStr (roomName r) + , "nickname" -=> showStr (roomNickname r) + , "status" -=> showStr (roomStatus r) + , "description" -=> showStr (roomDescription r) + , "url" -=> showStr (roomUrl r) + ] ++ + ls "administrators" (roomAdmins r) ++ + ls "members" (roomMember r) + where + ls _ [] = [] + ls t xs = [(t,JSArray (map showJSON xs))] + +readRoom :: JM Room +readRoom = do + s <- get "status" + d <- get "description" + u <- get "url" + i <- get "id" + n <- get "name" + nn <- getMb "nickname" + as <- getJSON "administrators" >>= liftR.readJSON + ms <- getJSON "members" >>= liftR.readJSON + return nullRoom + { roomStatus = s + , roomDescription = d + , roomUrl = u + , roomAdmins = as + , roomMember = ms + , roomId = i + , roomName = n + , roomNickname = fromMaybe "" (fmap (\ (JSString x) -> fromJSString x) nn) + } + +showResource :: Resource a -> [(String,JSValue)] +showResource r = + [ "id" -=> showStr (resourceId r) + , "name" -=> showStr (resourceName r) + , "nickname" -=> showStr (resourceNickname r) + , "url" -=> showStr (resourceUrl r) + ] + +readResource :: JM (Resource a) +readResource = do + i <- get "id" + n <- get "name" + nn <- get "nickname" + u <- getMbS "url" + pu <- getMbS "profileUrl" + return nullResource + { resourceId = i + , resourceName = n + , resourceNickname = nn + , resourceUrl = fromMaybe "" (u `mplus` pu) + } + +showLike :: Like -> [(String,JSValue)] +showLike l = + [ "date" -=> showStr (likeDate l) + , "user" -=> showJSON (likeUser l) + ] + +readLike :: JM Like +readLike = do + d <- get "date" + u <- getJSON "user" >>= \ c -> liftR (readJSON c) + return nullLike + { likeDate = d + , likeUser = u + } + +showEnclosure :: Enclosure -> [(String,JSValue)] +showEnclosure e = + [ "url" -=> showStr (enclosureUrl e) + , "type" -=> showStr (enclosureType e) + , "length" -=> showStr (show $ enclosureLength e) + ] + +readEnclosure :: JM Enclosure +readEnclosure = do + u <- get "url" + t <- get "type" + l <- getInt "length" + return nullEnclosure + { enclosureUrl = u + , enclosureType = t + , enclosureLength = l + } + +showContent :: Content -> [(String,JSValue)] +showContent c = + [ "url" -=> showStr (contentUrl c) + , "type" -=> showStr (contentType c) + , "width" -=> showStr (show $ contentWidth c) + , "height" -=> showStr (show $ contentHeight c) + ] + +readContent :: JM Content +readContent = do + u <- get "url" + t <- get "type" + w <- getInt "width" + h <- getInt "height" + return nullContent + { contentUrl = u + , contentType = t + , contentWidth = fromIntegral w + , contentHeight = fromIntegral h + } + +showThumbnail :: Thumbnail -> [(String,JSValue)] +showThumbnail t = + [ "url" -=> showStr (thumbUrl t) + , "width" -=> showStr (show (thumbWidth t)) + , "height" -=> showStr (show (thumbHeight t)) + ] + +readThumbnail :: JM Thumbnail +readThumbnail = do + u <- get "url" + w <- getInt "width" + h <- getInt "height" + return nullThumbnail + { thumbUrl = u + , thumbWidth = fromIntegral w + , thumbHeight = fromIntegral h + } + +showMedia :: Media -> [(String,JSValue)] +showMedia m = concat + [ mb "title" (mediaTitle m) + , mb "player" (mediaPlayer m) + , [ "link" -=> (showStr $ mediaLink m) ] + , ls "thumbnails" (mediaThumbs m) + , ls "content" (mediaContent m) + , ls "enclosures" (mediaEnclosure m) + ] + where + mb _ Nothing = [] + mb t (Just v) = [(t, showStr v)] + + ls _ [] = [] + ls t xs = [(t,JSArray (map showJSON xs))] + +readMedia :: JM Media +readMedia = do + t <- getMb "title" + p <- getMb "player" + l <- get "link" + ts <- getJSON "thumbnails" >>= liftR.readJSON + cs <- getJSON "content" >>= liftR.readJSON + es <- getJSON "enclosures" >>= liftR.readJSON + return nullMedia + { mediaTitle = fmap (\ (JSString x) -> fromJSString x) t + , mediaPlayer = fmap (\ (JSString x) -> fromJSString x) p + , mediaLink = l + , mediaThumbs = ts + , mediaContent = cs + , mediaEnclosure = es + } + + +showService :: Service -> [(String,JSValue)] +showService s = + [ "profileUrl" -=> showStr (serviceUrl s) + , "id" -=> showStr (serviceId s) + , "name" -=> showStr (serviceName s) + , "iconUrl" -=> showStr (serviceIconUrl s) + ] + +readService :: JM Service +readService = do + i <- get "id" + nm <- get "name" + iu <- get "iconUrl" + u <- getMbS "url" + pu <- getMbS "profileUrl" + return nullService + { serviceUrl = fromMaybe "" (u `mplus` pu) + , serviceIconUrl = iu + , serviceId = i + , serviceName = nm + } + +instance JSON UpdateInfo where + showJSON u = showJS showUpdateInfo u + readJSON m = readJS "FriendFeed.Types.UpdateInfo" nullUpdateInfo readUpdateInfo m + +showUpdateInfo :: UpdateInfo -> [(String,JSValue)] +showUpdateInfo u = + [ "token" -=> showJSON (JSONString (updToken u)) + , "poll_interval" -=> showJSON (JSONString (show $ updInterval u)) + , "incomplete" -=> showJSON (JSONString (map toLower $ show $ updIncomplete u)) + ] + +readUpdateInfo :: JM UpdateInfo +readUpdateInfo = do + t <- get "token" + p <- getInt "poll_interval" + i <- getB "incomplete" + return $ nullUpdateInfo + { updToken = t + , updInterval = p + , updIncomplete = i + }
ffeed.cabal view
@@ -1,5 +1,5 @@ name: ffeed -version: 0.3 +version: 0.3.1 synopsis: Haskell binding to the FriendFeed API description: The hs-ffeed API binding lets you access friendfeed.com's @@ -11,20 +11,20 @@ license-file: LICENSE author: Sigbjorn Finne maintainer: sof@forkio.com -build-depends: base, HTTP, xml cabal-version: >= 1.2 build-type: Simple extra-source-files: README examples/ShowPublic.hs examples/Util/GetOpts.hs -flag new-base - Description: Build with new smaller base library - Default: False +flag old-base + description: Old, monolithic base + default: False library Exposed-modules: FriendFeed.Types, + FriendFeed.Types.Import, FriendFeed.Monad, FriendFeed.API, FriendFeed.Entry, @@ -40,12 +40,12 @@ Util.Codec.URLEncoder, Util.Fetch Ghc-Options: -Wall - build-depends: base, HTTP, network, utf8-string, json + build-depends: HTTP, network, utf8-string, json - if flag(new-base) - Build-Depends: base >= 3 - else + if flag(old-base) Build-Depends: base < 3 + else + Build-Depends: base > 3 executable main { build-depends: base