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
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"
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
decodeOnly :: MonadError e m => App -> String -> m String
decodeOnly app tokStr = do
encryptedBytes <- u64 tokStr
when (null encryptedBytes) $ fail "Missing initialization vector"
when ((length encryptedBytes `mod` 16) /= 0) $
fail "Attempted to decode invalid token"
let initVector:encryptedBlocks = toBlocks encryptedBytes
key = fromOctets (256::Integer) $ encryptionKey app :: Word128
decryptedBlocks = unCbc AES.decrypt initVector key encryptedBlocks
return $ stripEOT $ toString decryptedBlocks
decode :: MonadError e m => App -> String -> m URLEncoded
decode app s = do
decoded <- decodeOnly app s
validate app decoded
URLEnc.importString decoded
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
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
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