module Network.WindowsLive.ConsentToken
(
OfferType(..)
, ConsentQuery(..)
, consentQuery
, getConsentUrl
, consentUrl
, processConsentToken
, Offer(..)
, ConsentToken(..)
, DelegationToken
, RefreshToken
)
where
import Control.Monad ( liftM, ap, when )
import Control.Monad.Error ( MonadError )
import Data.List ( intersperse )
import Data.Maybe ( fromJust )
import Data.Time.Clock.POSIX ( POSIXTime )
import Data.URLEncoded ( (%=), (%=?), (%?), (%&), URLEncode(..) )
import qualified Data.URLEncoded as URLEnc
import Network.WindowsLive.App ( App, verifier, decode )
import Network.URI ( parseURI, URI, parseRelativeReference, unEscapeString )
import Text.ParserCombinators.Parsec
( parse, many1, char, eof, satisfy, sepBy1 )
import Data.Char ( isAlpha, isDigit )
type DelegationToken = String
type RefreshToken = String
consentUrl :: URI
Just consentUrl = parseURI "https://consent.live.com/"
data OfferType = OfferType { oName :: String, oAction :: String }
instance Show OfferType where
showsPrec _ (OfferType n a) = showString n . ('.':) . showString a
data ConsentQuery =
ConsentQuery { qOffers :: [OfferType]
, qReturn :: URI
, qPolicy :: URI
, qContext :: Maybe String
, qMarket :: Maybe String
}
instance URLEncode ConsentQuery where
urlEncode cq = "ru" %= qReturn cq
%& "pl" %= qPolicy cq
%& "appctx" %=? qContext cq
%& "mkt" %=? qMarket cq
%& "ps" %= offerStr (qOffers cq) ""
consentQuery :: [OfferType] -> URI -> URI -> ConsentQuery
consentQuery ofrs ru pu = ConsentQuery ofrs ru pu Nothing Nothing
getConsentUrl :: App -> POSIXTime -> ConsentQuery -> URI
getConsentUrl app ts cq =
fromJust (parseRelativeReference "Delegation.aspx")
%? "app" %= verifier app ts %& urlEncode cq
offerStr :: [OfferType] -> ShowS
offerStr = foldr (.) id . intersperse (';':) . map shows
data Offer = Offer { offerExp :: POSIXTime
, offerType :: OfferType
} deriving Show
data ConsentToken =
ConsentToken { delt :: DelegationToken
, reft :: RefreshToken
, skey :: String
, offers :: [Offer]
, expiration :: POSIXTime
, lid :: String
} deriving Show
parseOffers :: MonadError e m => String -> m [Offer]
parseOffers = either (fail . show) return . parse pOffs "<offer arg>"
where pOff = do
nam <- many1 $ satisfy isAlpha
char '.'
act <- many1 $ satisfy isAlpha
char ':'
ts <- many1 $ satisfy isDigit
return $ Offer (readPT ts) $ OfferType nam act
pOffs = do
os <- sepBy1 pOff (char ';')
eof
return os
readPT :: String -> POSIXTime
readPT s = fromIntegral (read s :: Integer)
processConsentToken :: MonadError e m => App -> String -> m ConsentToken
processConsentToken app ct = do
encodedToken <- URLEnc.importString (unEscapeString ct)
>>= URLEnc.lookup1 "eact"
tok <- decode app encodedToken
let arg n = URLEnc.lookup1 n tok
ofrs = parseOffers =<< arg "offer"
expr = do expStr <- arg "exp"
when (null expStr) $ fail "Empty expiration!"
case dropWhile isDigit expStr of
[] -> return $ readPT expStr
_ -> fail $ "Bad expiration: " ++ show expStr
ConsentToken `liftM` arg "delt"
`ap` arg "reft"
`ap` arg "skey"
`ap` ofrs
`ap` expr
`ap` arg "lid"