ConsentToken.hs

-- |Perform Delegated Authentication with Windows Live. See
-- <http://msdn.microsoft.com/en-us/library/cc287637.aspx> for more
-- information about Delegated Authentication.

module Network.WindowsLive.ConsentToken
    ( -- * Building a Delegated Authentication consent request
      OfferType(..)
    , ConsentQuery(..)
    , consentQuery
    , getConsentUrl
    , consentUrl

    -- * Processing a Delegated Authentication consent response
    , 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.Parsec ( parse, many1, char, eof, satisfy, sepBy1 )
import Data.Char ( isAlpha, isDigit )

type DelegationToken = String
type RefreshToken = String

-- |The base consent URL for consent requests
consentUrl :: URI
Just consentUrl = parseURI "https://consent.live.com/"

-- |A type of offer that we are requesting consent for. In the Windows
-- Live documentation, an offer is represented as
-- e.g. \"Contacts.View\".
data OfferType = OfferType { oName :: String, oAction :: String }

instance Show OfferType where
    showsPrec _ (OfferType n a) = showString n . ('.':) . showString a

-- |A data type containing the fields that are necessary to make a
-- delegated authentication consent request
data ConsentQuery =
    ConsentQuery { qOffers :: [OfferType]   -- ^Offers we are
                                            -- requesting consent for
                 , qReturn :: URI           -- ^The URL that the
                                            -- user's browser will be
                                            -- returned to upon
                                            -- consenting
                 , qPolicy :: URI           -- ^The URL to your site's
                                            -- privacy policy
                 , qContext :: Maybe String -- ^Any state your
                                            -- application wants to
                                            -- preserve through the
                                            -- authentication process
                 , qMarket :: Maybe String  -- ^The locale for the
                                            -- request
                 }

instance URLEncode ConsentQuery where
    urlEncode cq = "ru" %= qReturn cq
                   %& "pl" %= qPolicy cq
                   %& "appctx" %=? qContext cq
                   %& "mkt" %=? qMarket cq
                   %& "ps" %= offerStr (qOffers cq) ""

-- |Generate a consent query with the minimum information filled in
consentQuery :: [OfferType] -> URI -> URI -> ConsentQuery
consentQuery ofrs ru pu = ConsentQuery ofrs ru pu Nothing Nothing

-- |Given a consent query, generate a (relative) 'URI' to initiate
-- Delegated Authentication. This URI must be turned into an absolute
-- URI by e.g:
--
-- @
--   let relConsentUrl = getConsentUrl app ts consentQuery
--   in relConsentUrl \`relativeTo\` 'consentUrl'
-- @
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

-- |An offer type along with an expiration time
data Offer = Offer { offerExp :: POSIXTime
                   , offerType :: OfferType
                   } deriving Show

-- |The parsed consent token
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)

-- |Extract and validate an encrypted consent token. This function
-- does not check to see if the token has expired.
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"