windowslive (empty) → 0.1.0
raw patch · 8 files changed
+654/−0 lines, 8 filesdep +Cryptodep +HUnitdep +basebuild-type:Customsetup-changed
Dependencies added: Crypto, HUnit, base, dataenc, mtl, network, parsec, pretty, split, time
Files
- LICENSE +30/−0
- Setup.lhs +21/−0
- src/Network/WindowsLive/ConsentToken.hs +148/−0
- src/Network/WindowsLive/Login.hs +84/−0
- src/Network/WindowsLive/Query.hs +71/−0
- src/Network/WindowsLive/Token.hs +145/−0
- test/Test.hs +108/−0
- windowslive.cabal +47/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2009, Josh Hoyt.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of the contributors may not be used to endorse or+ promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,21 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> import Distribution.PackageDescription+> import Distribution.Simple.Setup ( defaultBuildFlags )+> import Distribution.Simple.LocalBuildInfo ( buildDir )+> import Distribution.Simple.Utils ( rawSystemExit )+> import Distribution.Verbosity ( normal )+> import System.FilePath ( (</>) )++> main = defaultMainWithHooks hooks++> hooks = simpleUserHooks { instHook = inst+> , runTests = test+> }++> inst pkg = instHook simpleUserHooks $ pkg { executables = [] }++> test args _unknown pkg lbi = do+> buildHook hooks pkg lbi hooks defaultBuildFlags+> let testPath = buildDir lbi </> "test" </> "test"+> rawSystemExit normal testPath args
+ src/Network/WindowsLive/ConsentToken.hs view
@@ -0,0 +1,148 @@+-- |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.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++-- |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+ }++-- |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 =+ 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++-- |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 <- 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"
+ src/Network/WindowsLive/Login.hs view
@@ -0,0 +1,84 @@+-- |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 Network.WindowsLive.Query as Query+import Network.WindowsLive.Query ( (%=), (%=?) )++baseUrl :: URI+Just baseUrl = parseURI "http://login.live.com/"++secureUrl :: URI+Just secureUrl = parseURI "https://login.live.com/"++appIdQ :: App -> Query.Query+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 Query.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 Query.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 <- Query.parse tok+ let qval k = Query.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
+ src/Network/WindowsLive/Query.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.WindowsLive.Query+ ( parse+ , fromList+ , empty+ , null+ , keys+ , Query+ , lookup1+ , (%=)+ , (%=?)+ , addToURI+ , toQueryString+ )+where++import qualified Prelude+import Prelude hiding ( null )+import Data.List.Split ( splitOn )+import Control.Monad ( liftM )+import Control.Arrow ( (>>>) )+import Control.Monad.Error ( MonadError )+import Network.URI ( unEscapeString, escapeURIString, isUnreserved, URI(uriQuery) )+import Data.Monoid ( Monoid )+import Data.List ( intercalate )++newtype Query = Query { pairs :: [(String, String)] }+ deriving (Monoid, Show)++null :: Query -> Bool+null = Prelude.null . pairs++empty :: Query+empty = Query []++fromList :: [(String, String)] -> Query+fromList = Query++keys :: Query -> [String]+keys = map fst . pairs++(%=) :: String -> String -> Query+k %= v = Query [(k, v)]++(%=?) :: String -> Maybe String -> Query+k %=? v = maybe empty (k %=) v++addToURI :: Query -> URI -> URI+addToURI q u =+ let initialChar = if Prelude.null (uriQuery u) then '?' else '&'+ in u { uriQuery = uriQuery u ++ (initialChar:toQueryString q) }++toQueryString :: Query -> String+toQueryString q =+ let esc = escapeURIString isUnreserved+ encodePair (k, v) = esc k ++ "=" ++ esc v+ in intercalate "&" $ map encodePair $ pairs q++parse :: MonadError e m => String -> m Query+parse = splitOn "&" >>> mapM parsePair >>> liftM Query+ where parsePair p =+ case break (== '=') p of+ (_, []) -> fail $ "Missing value in query string: " ++ show p+ (k, '=':v) -> return ( unEscapeString k+ , unEscapeString v+ )+ unknown -> error $ "impossible: " ++ show unknown++lookup1 :: MonadError e m => String -> Query -> m String+lookup1 k = pairs >>> Prelude.lookup k >>> maybe missing return+ where missing = fail $ "Missing query arg: " ++ show k
+ src/Network/WindowsLive/Token.hs view
@@ -0,0 +1,145 @@+-- |Code that is common to Web Authentication+-- ("Network.WindowsLive.Login") and Delegated Authentication+-- ("Network.WindowsLive.ConsentToken")+module Network.WindowsLive.Token+ ( -- * Application State+ App(..)+ , AppID+ , Secret+ , newApp++ -- * Decryption and validation (internal)+ , decodeToken+ , validateToken++ -- * Generate a signed application verifier+ , appVerifier+ )+where+import qualified Codec.Binary.Base64 as Base64+import qualified Codec.Encryption.AES as AES+import Codec.Encryption.Modes ( unCbc )+import Codec.Text.Raw ( hexdump )+import Codec.Utils ( Octet, fromOctets, toOctets, listFromOctets )+import Control.Monad ( when, replicateM )+import Control.Monad.Error ( MonadError )+import qualified Data.Digest.SHA256 as SHA256+import Data.HMAC ( hmac, HashMethod(..) )+import Data.LargeWord ( Word128 )+import Data.List.Split ( splitOn )+import Data.Monoid ( mconcat, mappend )+import Data.Time.Clock.POSIX ( POSIXTime )+import Network.URI ( unEscapeString )+import Network.WindowsLive.Query ( (%=) )+import qualified Network.WindowsLive.Query as Query+import qualified Text.Parsec as Parsec+import Text.PrettyPrint.HughesPJ ( text, (<+>), char )++-- |Visit+-- <https://lx.azure.microsoft.com/Cloud/Provisioning/Default.aspx> to+-- get your application's Application ID and Secret key+data App = App { appId :: AppID+ , secret :: Secret+ }++type AppID = String++newtype Secret = Secret [Octet]++instance Show Secret where+ showsPrec _ (Secret bs) =+ shows $ text "Secret<" <+> hexdump 24 bs <+> char '>'++-- |Create a new 'App', validating the Application ID and Secret key+newApp :: MonadError e m => String -> String -> m App+newApp appIdStr secretStr = do+ validateAppId appIdStr+ validateSecret secretStr+ let sec = Secret $ map (toEnum . fromEnum) secretStr+ return $ App appIdStr $ sec++validateAppId :: MonadError e m => String -> m ()+validateAppId = either (fail . show) (const $ return ()) .+ Parsec.parse (replicateM 16 Parsec.hexDigit) "appid"++validateSecret :: MonadError e m => String -> m ()+validateSecret s = when (null s) $ fail "Empty secret"++data KeyType = Signature | Encryption deriving Show++keyPrefix :: KeyType -> [Octet]+keyPrefix kt = map (toEnum . fromEnum) $+ case kt of+ Signature -> "SIGNATURE"+ Encryption -> "ENCRYPTION"++-- |Generate a cryptographic key from the secret and the key type+derive :: Secret -> KeyType -> [Octet]+derive (Secret bytes) kt = take 16 $ SHA256.hash $ keyPrefix kt ++ bytes++-- |Decrypt a token (failing if it cannot be decrypted)+decodeToken :: MonadError e m => App -> String -> m String+decodeToken app tokStr = do+ -- First, the string is URL-unescaped and base64 decoded+ encryptedBytes <- u64 tokStr+ when (null encryptedBytes) $ fail "Missing initialization vector"+ when ((length encryptedBytes `mod` 16) /= 0) $+ fail "Attempted to decode invalid token"++ -- Second, the IV is extracted from the first 16 bytes of the string+ let initVector:encryptedBlocks = toBlocks encryptedBytes++ -- Finally, the string is decrypted using the encryption key+ key = fromOctets (256::Integer) $ derive (secret app) Encryption :: Word128+ decryptedBlocks = unCbc AES.decrypt initVector key encryptedBlocks++ return $ stripEOT $ toString decryptedBlocks++-- |decode a Base64 encoded, URL-escaped string into a sequence of bytes+u64 :: MonadError e m => String -> m [Octet]+u64 str =+ case Base64.decode $ unEscapeString str of+ Nothing -> fail "Data was not valid base64"+ Just bs -> return bs++-- |Check the signature of this token (failing if it is not valid)+validateToken :: MonadError e m => App -> String -> m ()+validateToken app tok = do+ (body, sig) <- case splitOn "&sig=" tok of+ [b, s] -> return (b, s)+ [_] -> fail $ "No sig found: " ++ show tok+ unexpected ->+ fail $ "More than one sig found: " ++ show unexpected++ extractedSig <- u64 sig+ let calculatedSig = signToken (secret app) body+ when (extractedSig /= calculatedSig) $+ fail $ "Signature did not match: extracted=" ++ show extractedSig+ ++ " /= calculated=" ++ show calculatedSig++signToken :: Secret -> String -> [Octet]+signToken sec =+ hmac (HashMethod SHA256.hash 512) (derive sec Signature) . toBytes++stripEOT :: String -> String+stripEOT = reverse . dropWhile (== '\EOT') . reverse++toBytes :: String -> [Octet]+toBytes = map (toEnum . fromEnum)++toString :: [Word128] -> String+toString = map (toEnum . fromEnum) . concatMap (toOctets (256::Integer))++toBlocks :: [Octet] -> [Word128]+toBlocks = reverse . listFromOctets . reverse++-- |Generate an application verifier to prove to the server that we+-- know the secret and application ID+appVerifier :: App -> POSIXTime -> Query.Query+appVerifier app ts =+ let q = mconcat [ "appid" %= appId app+ , "ts" %= show (round ts :: Integer)+ ]+ token = Query.toQueryString q+ sig = Base64.encode $ signToken (secret app) token+ in q `mappend` ("sig" %= sig)
+ test/Test.hs view
@@ -0,0 +1,108 @@+module Main+where++import Control.Monad.Error ( MonadError )+import qualified Network.WindowsLive.Token as Live+import qualified Network.WindowsLive.Query as Query+import Network.WindowsLive.Login ( processToken, getLoginUrl, baseUrl )+import Network.WindowsLive.ConsentToken ( processConsentToken )+import Network.URI ( relativeTo, uriQuery )+import Test.HUnit+import System.Exit+import System.IO ( stderr )++-- A login token from a response from login.live.com+loginToken :: String+loginToken =+ "0HlkHc47u2pVQKrkm3zzvvfUbIxS%2FfdOkiHsvbUnUUeVlZ21O%2F%2BYbvXDGTEMc%2BG\+ \%2BQ78pf8LLG1lsO3FAcbsJdeMcOZhwuaqubx7%2BDZq2WtOdK%2F3XJw39kWMPSvUrzwSa\+ \6aT1l1oi6UHPFuBpKSVq4NXHbnZb0IfSWwv%2BNa3BkiIY%2BZyxCjV5k%2BYbLD4Xz9%2B\+ \s"++-- A consent token from a response from consent.live.com+consentToken :: String+consentToken =+ "eact%3DvFcrnZDughQ9O2jrtckfcEF26jJcvdYE6U3Dh%252Fs6y2ZAB8T%252FyaFoehz1\+ \Y8Flp%252Bh6o3FB2BFormNo4on3xXDYmCc6NXnw4HLnO314bmsl4apTga1ekfbo49xfzjh\+ \1uncXJNwKrRYdeF5qeqBAdtdFbz3vwKsqxlbLuMnEdImGervS5UNE88lbGaS7bVv28FySwQ\+ \d1U9dlOi5H%252FUf7X9hfPCVquifMG%252BFLfdUgRUFRbFXJlp%252F8iV4J7uzV1JX3Q\+ \l7TAKtj%252FOHeL0Cmr5q5qJZxO55JljZwFfhy6NNKcZniQzWFsKqFAAzEYEnBuNSU4sRR\+ \dm5hHS7LzrTdSdo1EcZLT01PdmE%252FcUEH2W9m7cO1FNuKSzxWcdi%252BojCUK6UwbSD\+ \TxFMs3zEiUHsHh5Ue24JCq9ocTpPg3GJTebVLLVltQHfvXXsycS12FetlrGxbgvxrfqqX7F\+ \gw04aDyQjCOFidub9Rtfh9%252BF4VsqAHS2uedCs%252FC7kjBT8pwyP0GBeELRlDmZ1Uy\+ \3LwZSNK%252FycC8so%252BaH%252FQAQJDfIk%252F539ZiNkQkyukrRx9eceirNr24gUj\+ \8h7%252BzC9%252FuPAkubOJAXOVKx0ROr1EcDJZpUeLax4RDx53tM0S5egPgmpLQ%252Br\+ \gdWeCgWZuXmah71lWt65ewqggRs%252FEWsBvFbqZ0UVWQnN6iOx1h%252B6qrDjS5wx5Nv\+ \tmT6E1rHGzPkLUAh8BT1TioltoLwpnZYRr8vimahrYgI19QSft5Lplouay8t9POSCG%252B\+ \RrZLLGUXvvyW6EkdNLdNQbeudcBt3kE7H5iYiZWL8n0nAukqJtEql100tKEfntAW1PZQ4Zy\+ \yIA%252F%252BaXwfVXOVztu1GnYmVGl8uK4%252BqsqW797bgvktj%252BroGfY5CbBwlU\+ \rywUA2Zy4NupJH3jm0rf5PvN6UzyscygPTNnPxgrzvdVHJizvz9%252BIcf%252F%252Bs8\+ \Oh4OIiwXKBXW4CvmVu1yFqD%252FvkrqF8P4UpqE7fiJOP20Lw%252FfRpac5Dl0gvJK08I\+ \E8unTy8s0uKwdy0BIa2EpZV4Nlupp%252BWfZl2rgYDjtF8rCzA73LMtkrUpByO3JwbmRiB\+ \URjvYJR%252FMvdlcWaw1CTt%252B6pOrr9YLesmJe%252FxqjfjquDx%252B%252BdkJRF\+ \GT%252B2gGo4YfTTpoy7IsiQy1b1NDVVJRYmINmIj1HLOuHbKl%252F0JMOJMr0jjn7GXwT\+ \wgSCg3TMZtK1W7xdoqOC8xOFdw"++appId :: String+appId = "000000004C00F507"++secret :: String+secret = "wfMkKPJdTHHi64sWrmQlGE9uBY27Pjgl"++getApp :: MonadError e m => m Live.App+getApp = Live.newApp appId secret++-- Very weak tests: test that processing these good strings does not+-- throw an exception+processLoginTest :: Live.App -> Test+processLoginTest app = test (processToken app loginToken >> return () :: IO ())++processConsentTest :: Live.App -> Test+processConsentTest app =+ test (processConsentToken app consentToken >> return () :: IO ())++badAppTest :: Test+badAppTest =+ test [ "validates secret" ~: assert $ fails (Live.newApp appId "")+ , "validates app id" ~: assert $ fails (Live.newApp "" secret)+ ]+ where fails :: Either String Live.App -> Bool+ fails (Left _) = True+ fails _ = False++loginUrlTest :: Live.App -> Test+loginUrlTest app =+ test $ do+ let mkt = "> =&abc#://"+ ctx = "123/?<{}!456"+ relLoginUri = getLoginUrl app (Just ctx) (Just mkt)++ uri <- case relLoginUri `relativeTo` baseUrl of+ Nothing -> fail $ "Failed to combine: " ++ show relLoginUri+ ++ " and " ++ show baseUrl+ Just u -> return u++ q <- case uriQuery uri of+ '?':qs -> Query.parse qs+ "" -> Query.parse ""+ unexpected ->+ fail $ "No ? at start of query string: " ++ show unexpected++ let assertQ (k, v) = assertEqual k v =<< Query.lookup1 k q+ mapM_ assertQ [ ("appid", Live.appId app)+ , ("mkt", mkt)+ , ("appctx", ctx)+ ]++main :: IO ()+main = do+ app <- getApp+ let tests = [ processConsentTest app+ , processLoginTest app+ , loginUrlTest app+ , badAppTest+ ]+ (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests+ exitWith $ if (errors testResults + failures testResults) /= 0+ then ExitFailure 1+ else ExitSuccess
+ windowslive.cabal view
@@ -0,0 +1,47 @@+Name: windowslive+Cabal-Version: >= 1.6+Version: 0.1.0+Synopsis: Implements Windows Live Web Authentication and+ Delegated Authentication++Description: Implements functions for initiating and processing+ Web Authentication requests, as well as Delegated+ Authentication. See+ <http://msdn.microsoft.com/en-us/library/bb404787.aspx>++Category: Web+License: BSD3+License-File: LICENSE+Author: Josh Hoyt+Maintainer: joshhoyt@gmail.com+Homepage: http://patch-tag.com/repo/windowslive+Stability: alpha+Build-Type: Custom++Library+ GHC-Options: -Wall+ Build-Depends:+ base == 4.*,+ Crypto == 4.2.*,+ dataenc == 0.12,+ mtl == 1.*,+ network == 2.2.*,+ pretty == 1.*,+ split == 0.1.*,+ time == 1.1.*,+ parsec >= 3.0.0 && < 3.1,+ HUnit == 1.2.*+ HS-Source-Dirs: src+ Exposed-Modules:+ Network.WindowsLive.Token,+ Network.WindowsLive.Login,+ Network.WindowsLive.ConsentToken+ Other-Modules:+ Network.WindowsLive.Query++-- This executable is not installed by the (custom) Setup program. It is+-- used by the test hook (cabal test)+Executable test+ GHC-Options: -Wall+ Main-is: Test.hs+ HS-Source-Dirs: src, test