module FriendFeed.Types.Import where
import FriendFeed.Types
import Text.JSON
import Text.JSON.Types
import Data.Char
import Data.Maybe
import Control.Monad
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 <- return []
ms <- return []
likes <- getJSON "likes" >>= \ x -> liftR (readJSON x)
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)
]
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
}