-- |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 Control.Monad ( liftM, ap, unless )
import Control.Monad.Error ( MonadError )
import Data.Char ( isDigit )
import Data.Maybe ( fromJust )
import Data.Time.Clock.POSIX ( POSIXTime )
import Network.URI ( URI, parseURI, parseRelativeReference )

import Network.WindowsLive.App ( App, appId, decode )

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

relUri :: String -> URI
relUri = fromJust . parseRelativeReference

-- |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 =
    relUri "wlogin.srf" %? appIdQ app %& "alg" %= "wsignin1.0"
                        %& "appctx" %=? ctx %& "mkt" %=? mkt

-- |Generate a /relative/ sign out URL
getLogoutUrl :: App -> Maybe String -- ^The locale in which to display
                                    -- the sign out process
             -> URI
getLogoutUrl app mkt = relUri "logout.srf" %? appIdQ app %& "mkt" %=? mkt

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
  q <- decode app encryptedToken
  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