{-# 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
    }