diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Hemanth Kapila + +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. + + * Neither the name of Hemanth Kapila nor the names of other + contributors may 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 +OWNER 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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/WindowsAzure/ACS.hs b/Web/WindowsAzure/ACS.hs new file mode 100644 --- /dev/null +++ b/Web/WindowsAzure/ACS.hs @@ -0,0 +1,135 @@ +-- | +-- Module : Web.WindowsAzure.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 Web.WindowsAzure.ACS +-- import Network.HTTP.Conduit +-- import Network.HTTP.Client.Conduit +-- import Network.Connection (TLSSettings (..)) +-- import qualified Data.ByteString.Char8 as C +-- import Control.Concurrent +-- +-- 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 Web.WindowsAzure.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) + +-- | '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 <- 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/azure-acs.cabal b/azure-acs.cabal new file mode 100644 --- /dev/null +++ b/azure-acs.cabal @@ -0,0 +1,35 @@ +-- Initial azure-acs.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: azure-acs +version: 0.0.1.0 +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 +license-file: LICENSE +author: Hemanth Kapila +maintainer: saihemanth@gmail.com +copyright: Hemanth Kapila (c) 2014 +category: Web +build-type: Simple +extra-source-files: examples/*.hs +cabal-version: >=1.10 + + + +library + exposed-modules: Web.WindowsAzure.ACS + -- other-modules: + -- other-extensions: + build-depends: base >= 4 && <5 , bytestring,conduit,conduit-extra,http-conduit,attoparsec,http-types,time,connection + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind + ghc-prof-options: -prof -auto-all + +source-repository head + type: git + location: https://github.com/kapilash/hs-azure.git diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -0,0 +1,17 @@ +module Main where + +import Webbaau.WindowsAzure.ACS +import Network.HTTP.Conduit +import Network.HTTP.Client.Conduit +import Network.Connection (TLSSettings (..)) +import qualified Data.ByteString.Char8 as C +import Control.Concurrent + +main = do + acsCtx <- acsContext (AcsInfo "-sb" (C.pack "http://blahblah.servicebus.windows.net/" ) (C.pack "owner") (C.pack "basjasj=")) + manager <- newManagerSettings (mkManagerSettings (TLSSettingsSimple True False False) Nothing) + forkIO (acsToken manager acsCtx >>= print) + t1 <- acsToken manager acsCtx + print t1 + +