Login.hs

-- |Windows Live Web Authentication. See
-- <http://msdn.microsoft.com/en-us/library/bb676633.aspx>.
module Network.WindowsLive.Login
    ( -- * Generate URLs for starting authentication and signing out
      getLoginUrl
    , getLogoutUrl
    , baseUrl
    , secureUrl

    -- * Proces authentication responses
    , processToken
    , User(..)
    )
where

import Data.Char ( isDigit )
import Control.Monad ( liftM, ap, unless )
import Control.Monad.Error ( MonadError )
import Data.Time.Clock.POSIX ( POSIXTime )
import Network.WindowsLive.Token
import Network.URI ( URI, parseURI, parseRelativeReference )
import Data.Monoid ( mconcat )

import qualified Data.URLEncoded as URLEnc
import Data.URLEncoded ( (%=), (%=?) )

baseUrl :: URI
Just baseUrl = parseURI "http://login.live.com/"

secureUrl :: URI
Just secureUrl = parseURI "https://login.live.com/"

appIdQ :: App -> URLEnc.URLEncoded
appIdQ = ("appid" %=) . appId

-- |Generate a /relative/ authentication start URL
getLoginUrl :: App
            -> Maybe String -- ^The application context
            -> Maybe String -- ^The locale in which to display the
                            -- authentication UI
            -> URI
getLoginUrl app ctx mkt =
    let Just u = parseRelativeReference "wlogin.srf"
        loginQuery = mconcat [ appIdQ app
                             , "alg" %= "wsignin1.0"
                             , "appctx" %=? ctx
                             , "mkt" %=? mkt
                             ]
    in URLEnc.addToURI loginQuery u

-- |Generate a /relative/ sign out URL
getLogoutUrl :: App -> Maybe String -- ^The locale in which to display
                                    -- the sign out process
             -> URI
getLogoutUrl app mkt =
    let Just u = parseRelativeReference "logout.srf"
        logoutQuery = mconcat [ appIdQ app, "mkt" %=? mkt ]
    in URLEnc.addToURI logoutQuery u

data User = User { userID :: String
                 , userTimestamp :: POSIXTime
                 } deriving Show

-- |Parse and validate a token from an authentication response. Throws
-- an error on failure.
processToken :: MonadError e m => App -> String -> m User
processToken app encryptedToken = do
  tok <- decodeToken app encryptedToken
  validateToken app tok
  q <- URLEnc.importString tok
  let qval k = URLEnc.lookup1 k q

  qAppID <- qval "appid"
  unless (appId app == qAppID) $
         fail $ "Expected AppID " ++ show (appId app)
                  ++ " but got " ++ show qAppID

  User `liftM` qval "uid" `ap` (parseTimestamp =<< qval "ts")

parseTimestamp :: MonadError e m => String -> m POSIXTime
parseTimestamp ts = do
    unless (all isDigit ts && not (null ts)) $
         fail $ "Bad timestamp value: " ++ show ts
    return $ fromInteger $ read ts