diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0d66033 --- /dev/null +++ b/.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/ diff --git a/README.md b/README.md new file mode 100644 index 0000000..5b1d1ea --- /dev/null +++ b/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 +``` diff --git a/azure-auth/CHANGELOG.md b/azure-auth/CHANGELOG.md new file mode 100644 index 0000000..18f52d5 --- /dev/null +++ b/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. diff --git a/azure-auth/azure-auth.cabal b/azure-auth/azure-auth.cabal new file mode 100644 index 0000000..2cb54f6 --- /dev/null +++ b/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: prakash.nitin63@gmail.com +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 diff --git a/azure-auth/src/Azure.hs b/azure-auth/src/Azure.hs new file mode 100644 index 0000000..b265d3f --- /dev/null +++ b/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 diff --git a/azure-auth/src/Types.hs b/azure-auth/src/Types.hs new file mode 100644 index 0000000..0a85178 --- /dev/null +++ b/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 diff --git a/azure-auth/src/Utils.hs b/azure-auth/src/Utils.hs new file mode 100644 index 0000000..d6ffcfc --- /dev/null +++ b/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 diff --git a/azure-auth/test/Main.hs b/azure-auth/test/Main.hs new file mode 100644 index 0000000..3e2059e --- /dev/null +++ b/azure-auth/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..48efb45 --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: + azure-auth/ + diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..dfccfe9 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,17 @@ +indentation: 4 +comma-style: leading # for lists, tuples etc. - can also be 'trailing' +record-brace-space: false # rec {x = 1} vs. rec{x = 1} +indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword +respectful: true # don't be too opinionated about newlines etc. +haddock-style: multi-line # '--' vs. '{-' +haddock-style-module: multi-line +newlines-between-decls: 1 # number of newlines between top-level declarations +import-export-style: leading +let-style: auto +in-style: right-align +fixities: + - infixl 5 .= # both in tomland (fixyty 5) and aeson (fixity 8) +unicode: never +column-limit: none # Disclaimer: enabling column-limit breaks idempotence in a few cases. +function-arrows: trailing +single-constraint-parens: never diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..d6fa8aa --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +resolver: lts-21.25 # based on ghc-9.4.8 + +packages: +- ./azure-auth +