windowslive 0.1.1.1 → 0.2
raw patch · 7 files changed
+204/−186 lines, 7 filesdep ~dataencdep ~urlencoded
Dependency ranges changed: dataenc, urlencoded
Files
- src/Network/WindowsLive/App.hs +124/−0
- src/Network/WindowsLive/ConsentToken.hs +13/−15
- src/Network/WindowsLive/Login.hs +12/−18
- src/Network/WindowsLive/Secret.hs +45/−0
- src/Network/WindowsLive/Token.hs +0/−145
- test/Test.hs +4/−4
- windowslive.cabal +6/−4
+ src/Network/WindowsLive/App.hs view
@@ -0,0 +1,124 @@+module Network.WindowsLive.App+ ( App+ , AppID+ , appId+ , new++ , decode+ , verifier+ )+where++import Control.Monad ( replicateM, liftM )+import Control.Monad.Error ( MonadError )+import qualified Text.Parsec as Parsec++import qualified Network.WindowsLive.Secret as Secret+import qualified Codec.Binary.Base64 as Base64+import qualified Codec.Encryption.AES as AES+import Codec.Encryption.Modes ( unCbc )+import Codec.Utils ( Octet, fromOctets, toOctets, listFromOctets )+import Control.Monad ( when )+import qualified Data.Digest.SHA256 as SHA256+import Data.HMAC ( hmac, HashMethod(..) )+import Data.LargeWord ( Word128 )+import Data.List.Split ( splitOn )+import Data.Time.Clock.POSIX ( POSIXTime )+import Network.URI ( unEscapeString )+import Data.URLEncoded ( (%=), (%&), URLEncoded )+import qualified Data.URLEncoded as URLEnc++-- |Create a new 'App', validating the Application ID and Secret key+new :: MonadError e m => String -> String -> m App+new appIdStr secretStr = do+ validateAppId appIdStr+ App appIdStr `liftM` Secret.new secretStr++validateAppId :: MonadError e m => String -> m ()+validateAppId = either (fail . show) (const $ return ()) .+ Parsec.parse (replicateM 16 Parsec.hexDigit) "appid"+-- |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.Secret+ }++type AppID = String++encryptionKey :: App -> Secret.Key+encryptionKey = Secret.encryptionKey . secret++signingKey :: App -> Secret.Key+signingKey = Secret.signingKey . secret++-- |Decrypt a token (failing if it cannot be decrypted)+decodeOnly :: MonadError e m => App -> String -> m String+decodeOnly 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) $ encryptionKey app :: Word128+ decryptedBlocks = unCbc AES.decrypt initVector key encryptedBlocks++ return $ stripEOT $ toString decryptedBlocks++-- |Decode, validate, and parse a String containing x-www-urlencoded+-- |data encrypted with this application's secret+decode :: MonadError e m => App -> String -> m URLEncoded+decode app s = do+ decoded <- decodeOnly app s+ validate app decoded+ URLEnc.importString decoded++-- |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)+validate :: MonadError e m => App -> String -> m ()+validate 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 = sign app body+ when (extractedSig /= calculatedSig) $+ fail $ "Signature did not match: extracted=" ++ show extractedSig+ ++ " /= calculated=" ++ show calculatedSig++sign :: App -> String -> [Octet]+sign app = hmac (HashMethod SHA256.hash 512) (signingKey app) . 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+verifier :: App -> POSIXTime -> URLEncoded+verifier app ts =+ let q = "appid" %= appId app %& "ts" %= show (round ts :: Integer)+ sig = Base64.encode $ sign app $ URLEnc.export q+ in q %& "sig" %= sig
src/Network/WindowsLive/ConsentToken.hs view
@@ -22,11 +22,11 @@ import Control.Monad ( liftM, ap, when ) import Control.Monad.Error ( MonadError ) import Data.List ( intersperse )-import Data.Monoid ( mconcat )+import Data.Maybe ( fromJust ) import Data.Time.Clock.POSIX ( POSIXTime )-import Data.URLEncoded ( (%=), (%=?) )+import Data.URLEncoded ( (%=), (%=?), (%?), (%&), URLEncode(..) ) import qualified Data.URLEncoded as URLEnc-import Network.WindowsLive.Token+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 )@@ -65,6 +65,13 @@ -- 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@@ -79,15 +86,8 @@ -- @ getConsentUrl :: App -> POSIXTime -> ConsentQuery -> URI getConsentUrl app ts cq =- let Just pth = parseRelativeReference "Delegation.aspx"- q = mconcat [ "app" %= URLEnc.export (appVerifier app ts)- , "ru" %= (show $ qReturn cq)- , "pl" %= (show $ qPolicy cq)- , "appctx" %=? qContext cq- , "mkt" %=? qMarket cq- , "ps" %= offerStr (qOffers cq) ""- ]- in URLEnc.addToURI q pth+ fromJust (parseRelativeReference "Delegation.aspx")+ %? "app" %= verifier app ts %& urlEncode cq offerStr :: [OfferType] -> ShowS offerStr = foldr (.) id . intersperse (';':) . map shows@@ -130,9 +130,7 @@ processConsentToken app ct = do encodedToken <- URLEnc.importString (unEscapeString ct) >>= URLEnc.lookup1 "eact"- decoded <- decodeToken app encodedToken- validateToken app decoded- tok <- URLEnc.importString decoded+ tok <- decode app encodedToken let arg n = URLEnc.lookup1 n tok ofrs = parseOffers =<< arg "offer" expr = do expStr <- arg "exp"
src/Network/WindowsLive/Login.hs view
@@ -13,16 +13,17 @@ ) where -import Data.Char ( isDigit ) 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.WindowsLive.Token import Network.URI ( URI, parseURI, parseRelativeReference )-import Data.Monoid ( mconcat ) +import Network.WindowsLive.App ( App, appId, decode )+ import qualified Data.URLEncoded as URLEnc-import Data.URLEncoded ( (%=), (%=?) )+import Data.URLEncoded ( (%=), (%=?), (%?), (%&) ) baseUrl :: URI Just baseUrl = parseURI "http://login.live.com/"@@ -33,6 +34,9 @@ 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@@ -40,22 +44,14 @@ -- 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+ 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 =- let Just u = parseRelativeReference "logout.srf"- logoutQuery = mconcat [ appIdQ app, "mkt" %=? mkt ]- in URLEnc.addToURI logoutQuery u+getLogoutUrl app mkt = relUri "logout.srf" %? appIdQ app %& "mkt" %=? mkt data User = User { userID :: String , userTimestamp :: POSIXTime@@ -65,9 +61,7 @@ -- 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+ q <- decode app encryptedToken let qval k = URLEnc.lookup1 k q qAppID <- qval "appid"
+ src/Network/WindowsLive/Secret.hs view
@@ -0,0 +1,45 @@+module Network.WindowsLive.Secret+ ( Secret+ , Key+ , new+ , encryptionKey+ , signingKey+ )+where++import Codec.Utils ( Octet )+import Codec.Text.Raw ( hexdump )+import Text.PrettyPrint.HughesPJ ( text, (<+>), char )+import Control.Monad.Error ( MonadError )+import qualified Data.Digest.SHA256 as SHA256++type Key = [Octet]++newtype Secret = Secret [Octet]++instance Show Secret where+ showsPrec _ (Secret bs) =+ shows $ text "Secret<" <+> hexdump 24 bs <+> char '>'++new :: MonadError e m => String -> m Secret+new s = if null s+ then fail "Empty secret"+ else return $ Secret $ map (toEnum . fromEnum) s++data KeyType = Signature | Encryption deriving Show++keyPrefix :: KeyType -> Key+keyPrefix kt = map (toEnum . fromEnum) $+ case kt of+ Signature -> "SIGNATURE"+ Encryption -> "ENCRYPTION"++-- |Generate a cryptographic key from the secret and the key type+key :: Secret -> KeyType -> Key+key (Secret bytes) kt = take 16 $ SHA256.hash $ keyPrefix kt ++ bytes++encryptionKey :: Secret -> Key+encryptionKey = flip key Encryption++signingKey :: Secret -> Key+signingKey = flip key Signature
− src/Network/WindowsLive/Token.hs
@@ -1,145 +0,0 @@--- |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 Data.URLEncoded ( (%=) )-import qualified Data.URLEncoded as URLEnc-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 -> URLEnc.URLEncoded-appVerifier app ts =- let q = mconcat [ "appid" %= appId app- , "ts" %= show (round ts :: Integer)- ]- token = URLEnc.export q- sig = Base64.encode $ signToken (secret app) token- in q `mappend` ("sig" %= sig)
test/Test.hs view
@@ -2,7 +2,7 @@ where import Control.Monad.Error ( MonadError )-import qualified Network.WindowsLive.Token as Live+import qualified Network.WindowsLive.App as Live import qualified Data.URLEncoded as URLEnc import Network.WindowsLive.Login ( processToken, getLoginUrl, baseUrl ) import Network.WindowsLive.ConsentToken ( processConsentToken )@@ -50,7 +50,7 @@ secret = "wfMkKPJdTHHi64sWrmQlGE9uBY27Pjgl" getApp :: MonadError e m => m Live.App-getApp = Live.newApp appId secret+getApp = Live.new appId secret -- Very weak tests: test that processing these good strings does not -- throw an exception@@ -63,8 +63,8 @@ badAppTest :: Test badAppTest =- test [ "validates secret" ~: assert $ fails (Live.newApp appId "")- , "validates app id" ~: assert $ fails (Live.newApp "" secret)+ test [ "validates secret" ~: assert $ fails (Live.new appId "")+ , "validates app id" ~: assert $ fails (Live.new "" secret) ] where fails :: Either String Live.App -> Bool fails (Left _) = True
windowslive.cabal view
@@ -1,6 +1,6 @@ Name: windowslive Cabal-Version: >= 1.6-Version: 0.1.1.1+Version: 0.2 Synopsis: Implements Windows Live Web Authentication and Delegated Authentication @@ -23,7 +23,7 @@ Build-Depends: base == 4.*, Crypto == 4.2.*,- dataenc == 0.12,+ dataenc == 0.13.*, mtl == 1.*, network == 2.2.*, pretty == 1.*,@@ -31,12 +31,14 @@ time == 1.1.*, parsec >= 3.0.0 && < 3.1, HUnit == 1.2.*,- urlencoded+ urlencoded == 0.1.* HS-Source-Dirs: src Exposed-Modules:- Network.WindowsLive.Token,+ Network.WindowsLive.App, Network.WindowsLive.Login, Network.WindowsLive.ConsentToken+ Other-Modules:+ Network.WindowsLive.Secret -- This executable is not installed by the (custom) Setup program. It is -- used by the test hook (cabal test)