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.Monoid ( mconcat )
import Data.Time.Clock.POSIX ( POSIXTime )
import Network.WindowsLive.Query ( (%=), (%=?) )
import qualified Network.WindowsLive.Query as Query
import Network.WindowsLive.Token
import Network.URI ( parseURI, URI, parseRelativeReference, unEscapeString )
import Text.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
}
consentQuery :: [OfferType] -> URI -> URI -> ConsentQuery
consentQuery ofrs ru pu = ConsentQuery ofrs ru pu Nothing Nothing
getConsentUrl :: App -> POSIXTime -> ConsentQuery -> URI
getConsentUrl app ts cq =
let Just pth = parseRelativeReference "Delegation.aspx"
q = mconcat [ "app" %= Query.toQueryString (appVerifier app ts)
, "ru" %= (show $ qReturn cq)
, "pl" %= (show $ qPolicy cq)
, "appctx" %=? qContext cq
, "mkt" %=? qMarket cq
, "ps" %= offerStr (qOffers cq) ""
]
in Query.addToURI q pth
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 <- Query.parse (unEscapeString ct) >>= Query.lookup1 "eact"
decoded <- decodeToken app encodedToken
validateToken app decoded
tok <- Query.parse decoded
let arg n = Query.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"