diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 diff --git a/src/Network/WindowsLive/ConsentToken.hs b/src/Network/WindowsLive/ConsentToken.hs new file mode 100644 --- /dev/null +++ b/src/Network/WindowsLive/ConsentToken.hs @@ -0,0 +1,148 @@ +-- |Perform Delegated Authentication with Windows Live. See +-- 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 "" + 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" diff --git a/src/Network/WindowsLive/Login.hs b/src/Network/WindowsLive/Login.hs new file mode 100644 --- /dev/null +++ b/src/Network/WindowsLive/Login.hs @@ -0,0 +1,84 @@ +-- |Windows Live Web Authentication. See +-- . +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 diff --git a/src/Network/WindowsLive/Query.hs b/src/Network/WindowsLive/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/WindowsLive/Query.hs @@ -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 diff --git a/src/Network/WindowsLive/Token.hs b/src/Network/WindowsLive/Token.hs new file mode 100644 --- /dev/null +++ b/src/Network/WindowsLive/Token.hs @@ -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 +-- 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) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 diff --git a/windowslive.cabal b/windowslive.cabal new file mode 100644 --- /dev/null +++ b/windowslive.cabal @@ -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 + + +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