diff --git a/Network/MicrosoftAzure/ACS.hs b/Network/MicrosoftAzure/ACS.hs new file mode 100644 --- /dev/null +++ b/Network/MicrosoftAzure/ACS.hs @@ -0,0 +1,132 @@ +-- | +-- Module : Network.MicrosoftAzure.ACS +-- Description : API for requesting password token from Windows Azure ACS. +-- Copyright : (c) Hemanth Kapila, 2014 +-- License : BSD3 +-- Maintainer : saihemanth@gmail.com +-- Stability : Experimental +-- +-- Provides API to request password token from WindowsAzure ACS. The security token is needed by web applications and services that handle authentication using ACS. +-- Please refer to for further information on ACS. +-- +-- Following piece of code illustrates the use of API +-- +-- @ +-- import Network.MicrosoftAzure.ACS +-- import Network.HTTP.Conduit +-- import Network.HTTP.Client.Conduit +-- import Network.Connection (TLSSettings (..)) +-- import qualified Data.ByteString.Char8 as C +-- +-- main = do +-- acsCtx <- acsContext (AcsInfo "blahblah-sb" (C.pack "http://blahblah.servicebus.windows.net/" ) (C.pack "owner") (C.pack "blahBlahBlahBlah")) +-- manager <- newManagerSettings (mkManagerSettings (TLSSettingsSimple True False False) Nothing) +-- t1 <- acsToken manager acsCtx +-- print t1 +-- @ +-- +module Network.MicrosoftAzure.ACS ( + -- * Types + -- * Acs Info + AcsInfo (..), + -- * Acs Context + AcsContext, + AcsToken, + -- * functions + acsContext, + acsToken + )where + +import Network.HTTP.Conduit +import Data.Conduit +import Network.HTTP.Types.URI +import qualified Data.ByteString.Char8 as C +import qualified Data.Attoparsec.ByteString.Lazy as AP +import Data.Attoparsec.ByteString.Char8 +import Control.Concurrent.MVar +import Network.HTTP.Types.Method(methodPost) +import Network.HTTP.Types.Header +import Data.Time.Clock(getCurrentTime, addUTCTime,UTCTime) +import Data.Conduit.Attoparsec(sinkParser) +import Data.Conduit.Binary(sourceLbs) +import Network(withSocketsDo) + +-- | 'AcsInfo' encapsulates the information needed to get the token from Azure ACS: +-- +-- +-- * acs namespace +-- * the relying party address +-- * the issuer and +-- * the issuer key. +data AcsInfo = AcsInfo String !C.ByteString !C.ByteString !C.ByteString + deriving (Eq,Show) + +{- | synonym for the ACS password token +-} +type AcsToken = Header + +data AcsResponse = AcsResponse !AcsToken !UTCTime + | NotConnectedToAcs + + +{- | An abstract datatype that keeps track of acs token expiry and gets a new one as necessary. +-} +data AcsContext = AcsContext !AcsInfo (MVar AcsResponse) + + + +-- | construct the context object. This call does not perform any network call yet. +acsContext :: AcsInfo -> IO AcsContext +acsContext a = do + b <- newMVar NotConnectedToAcs + return $ AcsContext a b + + +{-# INLINE canReuse #-} +canReuse :: UTCTime -> AcsResponse -> Bool +canReuse _ NotConnectedToAcs = False +canReuse currentTime (AcsResponse _ time) = currentTime < time + +{-# INLINE wrapToken #-} +wrapToken :: AcsResponse -> AcsToken +wrapToken (AcsResponse t _) = t +wrapToken _ = undefined + +-- | If a valid token is available, it is returned. Otherwise, requests password a fresh password token from windows azure acs +-- +-- Refer to for information about creating and using 'Manager' +acsToken :: Manager -> AcsContext -> IO AcsToken +acsToken manager (AcsContext info mv) = do + utcTime <- getCurrentTime + acsResp <- takeMVar mv + if canReuse utcTime acsResp + then do { putMVar mv acsResp; return (wrapToken acsResp)} + else do + resp <- doAcsPost info manager + putMVar mv resp + return (wrapToken resp) + + + +doAcsPost :: AcsInfo -> Manager ->IO AcsResponse +doAcsPost (AcsInfo url endpoint issuer key) manager = do + request' <- parseUrl ("https://" ++ url ++ ".accesscontrol.windows.net/WRAPv0.9/") + let request = addBody $ request' { + method = methodPost + } + res <- withSocketsDo $ httpLbs request manager + utcTime <- getCurrentTime + acsResp <- sourceLbs (responseBody res) $$ (sinkParser $ parseResponse utcTime) + return acsResp + where + addBody = urlEncodedBody [(C.pack "wrap_scope",endpoint),(C.pack "wrap_name", issuer),(C.pack "wrap_password",key)] + parseResponse currTime = do + AP.takeTill (== 61) + AP.anyWord8 + b1 <- AP.takeTill (== 38) + AP.anyWord8 + AP.takeTill (== 61) + AP.anyWord8 + i <- decimal + return $ AcsResponse (toHeader b1) (addUTCTime (fromInteger $ i - 300) currTime) + toHeader bs = (hAuthorization, C.concat [(C.pack "WRAP access_token=\""), (urlDecode False bs), C.pack "\""]) diff --git a/Web/WindowsAzure/ACS.hs b/Web/WindowsAzure/ACS.hs --- a/Web/WindowsAzure/ACS.hs +++ b/Web/WindowsAzure/ACS.hs @@ -1,11 +1,14 @@ -- | -- Module : Web.WindowsAzure.ACS --- Description : API for requesting password token from Windows Azure ACS. +-- Description : __Deprecated__ API for requesting password token from Windows Azure ACS. -- Copyright : (c) Hemanth Kapila, 2014 -- License : BSD3 -- Maintainer : saihemanth@gmail.com -- Stability : Experimental -- +-- +-- __ DEPRECATED __ Use "Network.MicrosoftAzure.ACS" instead. +-- -- Provides API to request password token from WindowsAzure ACS. The security token is needed by web applications and services that handle authentication using ACS. -- Please refer to for further information on ACS. -- @@ -51,6 +54,7 @@ import Data.Time.Clock(getCurrentTime, addUTCTime,UTCTime) import Data.Conduit.Attoparsec(sinkParser) import Data.Conduit.Binary(sourceLbs) +import Network(withSocketsDo) -- | 'AcsInfo' encapsulates the information needed to get the token from Azure ACS: -- @@ -115,7 +119,7 @@ let request = addBody $ request' { method = methodPost } - res <- httpLbs request manager + res <- withSocketsDo $ httpLbs request manager utcTime <- getCurrentTime acsResp <- sourceLbs (responseBody res) $$ (sinkParser $ parseResponse utcTime) return acsResp diff --git a/azure-acs.cabal b/azure-acs.cabal --- a/azure-acs.cabal +++ b/azure-acs.cabal @@ -2,10 +2,11 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: azure-acs -version: 0.0.1.0 +version: 0.0.1.1 synopsis: Windows Azure ACS description: Haskell wrappers over REST API for . + . Currently only API that is supported is the one to request a password token from ACS via the homepage: https://github.com/kapilash/hs-azure license: BSD3 @@ -21,10 +22,20 @@ library - exposed-modules: Web.WindowsAzure.ACS + exposed-modules: Web.WindowsAzure.ACS, + Network.MicrosoftAzure.ACS -- other-modules: -- other-extensions: - build-depends: base >= 4 && <5 , bytestring,conduit,conduit-extra,http-conduit,attoparsec,http-types,time,connection + build-depends: base >= 4 && <5 , + bytestring, + conduit, + conduit-extra, + http-conduit, + attoparsec, + http-types, + time, + connection, + network -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -1,14 +1,20 @@ module Main where -import Webbaau.WindowsAzure.ACS +import Network.MicrosoftAzure.ACS import Network.HTTP.Conduit import Network.HTTP.Client.Conduit import Network.Connection (TLSSettings (..)) import qualified Data.ByteString.Char8 as C import Control.Concurrent + +acsNS = "XXXX" +issuerKey = C.pack "YYYYYYYYYYYYYYYYYYYYYYY==" +issuerName = C.pack "owner" +relyingPartyUrl = C.pack "http://XXXX.servicebus.windows.net" + main = do - acsCtx <- acsContext (AcsInfo "-sb" (C.pack "http://blahblah.servicebus.windows.net/" ) (C.pack "owner") (C.pack "basjasj=")) + acsCtx <- acsContext (AcsInfo acsNS relyingPartyUrl issuerName issuerKey) manager <- newManagerSettings (mkManagerSettings (TLSSettingsSimple True False False) Nothing) forkIO (acsToken manager acsCtx >>= print) t1 <- acsToken manager acsCtx