Initial commit: Add azure authentication

.gitignore

@@ -0,0 +1,29 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+.stack-work/
+
+# OS X
+.DS_Store
+*.yaml.lock
+dist-newstyle/

README.md

@@ -0,0 +1,23 @@
+# azure-haskell
+
+## Purpose
+
+This repository provides functions and types for common azure related
+operations. This is very much incomplete but serves as a boilerplate to get
+started. Covered areas:
+- Authentication (with managed identities)
+- Key Vault (To be pushed)
+- Blob storage (To be pushed)
+- Email communication service (To be pushed)
+
+## Building the project
+
+To build the entire project, run:
+```
+stack build
+```
+
+In order to build individual components of the library, run:
+```
+cabal build
+```

azure-auth/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for azure-auth
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

azure-auth/azure-auth.cabal

@@ -0,0 +1,74 @@
+cabal-version:      3.0
+name:               azure-auth
+version:            0.1.0.0
+license:            MIT
+author:             Nitin Prakash
+maintainer:         [email protected]
+category:           Azure
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common common-options
+    ghc-options:    -Wall
+                    -Wincomplete-uni-patterns
+                    -Wincomplete-record-updates
+                    -Wcompat
+                    -Widentities
+                    -Wredundant-constraints
+                    -fhide-source-paths
+                    -Wpartial-fields
+                    -Wunrecognised-pragmas
+                    -Wmissing-deriving-strategies
+                    -Wunticked-promoted-constructors
+                    -Winvalid-haddock
+                    -Woperator-whitespace
+                    -Wredundant-bang-patterns
+    build-depends:  base ^>=4.17.2.0
+    default-language:   GHC2021
+    default-extensions: DataKinds
+                        DerivingStrategies
+                        DerivingVia
+                        LambdaCase
+                        NoImportQualifiedPost
+                        NoGeneralisedNewtypeDeriving
+                        OverloadedStrings
+                        OverloadedLabels
+                        RecordWildCards
+                        TypeFamilies
+                        ViewPatterns
+    if os(linux)
+        ghc-options: -optl-fuse-ld=gold
+        ld-options:  -fuse-ld=gold
+
+library
+    import:           common-options
+    exposed-modules:  Azure
+                      Types
+                      Utils
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    aeson
+                    , bytestring
+                    , http-client
+                    , http-client-tls
+                    , http-types
+                    , servant
+                    , servant-client
+                    , text
+                    , time
+                    , unliftio
+    hs-source-dirs:   src
+    default-language: Haskell2010
+
+test-suite azure-auth-test
+    import:           common-options
+    default-language: Haskell2010
+    -- other-modules:
+    -- other-extensions:
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:
+        base ^>=4.17.2.0,
+        azure-auth

azure-auth/src/Azure.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Azure
+    ( defaultAzureCredential
+    , withManagedIdentity
+    ) where
+
+import Types (AccessToken (..), Token, readToken, updateToken)
+
+import Control.Monad.IO.Class (MonadIO)
+import Data.Data (Proxy (..))
+import Data.Text (Text)
+import Network.HTTP.Client (defaultManagerSettings, newManager)
+import Servant.API (Get, Header', JSON, Optional, QueryParam', Required, Strict, (:>))
+import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM)
+import UnliftIO (MonadIO (..), throwIO)
+import UnliftIO.Environment (lookupEnv)
+import Utils (isExpired)
+
+import qualified Data.Text as Text
+
+{- | IMDS is a REST API that's available at a well-known, non-routable IP address ( 169.254. 169.254 ).
+It can only be accessed from within the VM. Communication between the VM and IMDS never leaves the host.
+-}
+imdsHost :: String
+imdsHost = "169.254.169.254"
+
+imdsApiVersion :: Text
+imdsApiVersion = "2021-02-01"
+
+{- | Provides a default @TokenCredential@ authentication flow for applications that will be deployed to Azure.
+
+TODO: Implement other auth flows such as @withAzureCli@ and @withEnvironment@ and then apply
+      alternative instance to @defaultAzureCredential@
+      It should be of the form:
+      defaultAzureCredential =
+            withManagedIdentity
+        <|> withAzureCli
+        <|> withEnvironment
+
+      Order of authentication attempts:
+        1. EnvironmentCredential
+        2. Managed Identity (Only this is implemented at the moment)
+        3. Azure CLI
+
+-}
+defaultAzureCredential ::
+    MonadIO m =>
+    -- | Client ID
+    Maybe Text ->
+    -- | Azure Resource URI (required for @managed identity@)
+    Text ->
+    -- | Token (if empty, then a new one is fetched and stored into the token TVar)
+    Token ->
+    m AccessToken
+defaultAzureCredential = withManagedIdentity
+
+withManagedIdentity ::
+    MonadIO m =>
+    -- | ClientId
+    Maybe Text ->
+    -- | Resource URI
+    Text ->
+    -- | Access Token
+    Token ->
+    m AccessToken
+withManagedIdentity clientId resourceUri tokenStore = do
+    identityEndpoint <- lookupEnv "IDENTITY_ENDPOINT"
+    identityHeader <- lookupEnv "IDENTITY_HEADER"
+    case (,) <$> identityEndpoint <*> identityEndpoint of
+        -- TODO: incorporate @IDENTITY_ENDPOINT@ into this logic
+        --       If it's present, we can directly make a call to
+        --       to it and retrieve the access token.
+        Just (_endpoint, _header) -> undefined
+        -- We do not have the @IDENTITY_ENDPOINT@. Which means that that
+        -- the VM is possibly standalone and not inside an app service.
+        -- Therefore, in order to get the access token details, we need
+        -- to make GET request to Azure Instance Metadata Service.
+        -- But first, check for an existing token
+        Nothing -> do
+            tk <- readToken tokenStore
+            case tk of
+                -- In case there is no existing token, we fetch a new one
+                Nothing -> do
+                    newToken <- callAzureIMDSEndpoint getAzureIMDSClient resourceUri clientId (Text.pack <$> identityHeader)
+                    updateToken tokenStore (Just newToken)
+                    pure newToken
+                Just oldToken@AccessToken{atExpiresOn} -> do
+                    -- we do have a token but we should check for it's validity
+                    isTokenExpired <- isExpired atExpiresOn
+                    if isTokenExpired
+                        then do
+                            -- get a new token and write to the env
+                            newToken <- callAzureIMDSEndpoint getAzureIMDSClient resourceUri clientId (Text.pack <$> identityHeader)
+                            updateToken tokenStore (Just newToken)
+                            pure newToken
+                        else pure oldToken
+
+type AzureIMDSEndpoint =
+    "metadata"
+        :> "identity"
+        :> "oauth2"
+        :> "token"
+        :> QueryParam' '[Required, Strict] "api-version" Text
+        :> QueryParam' '[Required, Strict] "resource" Text
+        :> QueryParam' '[Optional, Strict] "client_id" Text
+        :> Header' '[Optional, Strict] "x-identity-header" Text
+        :> Header' '[Required, Strict] "Metadata" Bool
+        :> Get '[JSON] AccessToken
+
+getAzureIMDSClient ::
+    Text ->
+    Text ->
+    Maybe Text ->
+    Maybe Text ->
+    Bool ->
+    ClientM AccessToken
+getAzureIMDSClient = client (Proxy @AzureIMDSEndpoint)
+
+callAzureIMDSEndpoint ::
+    MonadIO m =>
+    (Text -> Text -> Maybe Text -> Maybe Text -> Bool -> ClientM AccessToken) ->
+    Text ->
+    Maybe Text ->
+    Maybe Text ->
+    m AccessToken
+callAzureIMDSEndpoint action resourceUri clientId identityHeader = do
+    manager <- liftIO $ newManager defaultManagerSettings
+    res <-
+        liftIO $
+            runClientM
+                (action imdsApiVersion resourceUri clientId identityHeader True)
+                (mkClientEnv manager $ BaseUrl Http imdsHost 80 "")
+    case res of
+        Left err ->
+            throwIO err
+        Right response ->
+            pure response

azure-auth/src/Types.hs

@@ -0,0 +1,75 @@
+module Types
+    ( ExpiresOn
+    , AccessToken (..)
+    , Token
+    , newEmptyToken
+    , updateToken
+    , expireToken
+    , readToken
+    ) where
+
+import Data.Aeson (FromJSON (..), withObject, (.:))
+import Data.Text (Text)
+import UnliftIO (MonadIO (..), writeTVar)
+import UnliftIO.STM (TVar, atomically, modifyTVar, newTVarIO, readTVarIO)
+
+type ExpiresOn = Text
+
+{- |
+Data type representing a response body when GET request is made
+using the Azure Instance Metadata Service (IMDS) endpoint.
+
+Source: https://learn.microsoft.com/en-us/entra/identity/managed-identities-azure-resources/how-to-use-vm-token#get-a-token-using-http
+
+TODO: Some of TokenType and Resource can possibly be represented using a sum type
+      along with FromJSON instance.
+-}
+data AccessToken = AccessToken
+    { atAccessToken :: !Text
+    -- ^ The requested access token. When you call a secured REST API, the
+    -- token is embedded in the Authorization request header field as a @bearer@
+    -- token, allowing the API to authenticate the caller.
+    , atRefreshToken :: !Text
+    -- ^ Not used by managed identities for Azure resources.
+    , atExpiresIn :: !Integer
+    -- ^ The number of seconds the access token continues to be valid, before
+    -- expiring, from time of issuance. Time of issuance can be found in
+    -- the token's @iat@ claim.
+    , atExpiresOn :: !ExpiresOn
+    -- ^ The timespan when the access token expires. The date is
+    -- represented as the number of seconds from @1970-01-01T0:0:0Z UTC@
+    -- (corresponds to the token's @exp@ claim).
+    -- NOTE: expires_on is a String version of unix epoch time, not an integer.
+    , atResource :: !Text
+    -- ^ The resource the access token was requested for, which
+    -- matches the resource query string parameter of the request.
+    , atTokenType :: !Text
+    -- ^ The type of token, which is a @Bearer@ access token, which means
+    -- the resource can give access to the bearer of this token.
+    }
+    deriving stock (Eq, Show)
+
+instance FromJSON AccessToken where
+    parseJSON = withObject "AccessToken" $ \o -> do
+        atAccessToken <- o .: "access_token"
+        atRefreshToken <- o .: "refresh_token"
+        atExpiresIn <- o .: "expires_in"
+        atExpiresOn <- o .: "expires_on"
+        atResource <- o .: "resource"
+        atTokenType <- o .: "token_type"
+        pure AccessToken{..}
+
+type Token = TVar (Maybe AccessToken)
+
+newEmptyToken :: MonadIO m => m Token
+newEmptyToken = newTVarIO Nothing
+
+expireToken :: MonadIO m => Token -> m ()
+expireToken token = atomically $ modifyTVar token (const Nothing)
+
+updateToken :: MonadIO m => Token -> Maybe AccessToken -> m ()
+updateToken tokenStore accessToken = atomically $ writeTVar tokenStore accessToken
+
+-- | Read the current value of the token
+readToken :: MonadIO m => Token -> m (Maybe AccessToken)
+readToken = readTVarIO

azure-auth/src/Utils.hs

@@ -0,0 +1,22 @@
+module Utils where
+
+import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Types (ExpiresOn)
+import UnliftIO (MonadIO (..))
+
+import qualified Text.Read as Text
+import qualified Data.Text as Text
+
+{- | Check if an azure access token expiration time
+is past or < 20 seconds from current time
+-}
+isExpired :: MonadIO m => ExpiresOn -> m Bool
+isExpired expiresOn = do
+    let timestamp = posixSecondsToUTCTime . secondsToNominalDiffTime <$> Text.readMaybe (Text.unpack expiresOn)
+    case timestamp of
+        Just time -> do
+            currentTime <- liftIO getCurrentTime
+            return $ time <= addUTCTime 20 currentTime
+        Nothing ->
+            return False

azure-auth/test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."

cabal.project

@@ -0,0 +1,3 @@
+packages:
+  azure-auth/
+