- Turned caching off by default

- Secret can now be set on the command line

ChangeLog.md

@@ -1,3 +1,6 @@
-# Changelog for local-managed-identity-haskell
+# Changelog for local-managed-identity
 
 ## Unreleased changes
+
+## 1.0.0.0
+* Initial release

README.md

@@ -32,14 +32,26 @@ Set the `MSI_ENDPOINT` and `MSI_SECRET` environment variables as specified in th
 
 If you're running your application from inside Docker container, you'll need to use `host.docker.internal` instead of `localhost` on Windows and Mac systems to ensure you get the host PC's IP address correctly inside the container. The terminal output shows example parameters you can pass to `docker run`.
 
+There are some parameters you can pass to the executable to set some settings:
+```
+Available options:
+  -h,--help                Show this help text
+  -v,--version             Prints the version of the application and quits
+  -p,--port PORT           The port the server will run on (default: 5436)
+  -s,--secret VALUE        The required value of the 'secret' header that must
+                           be sent by the client in its requests. If omitted, a
+                           random GUID will be used.
+  -c,--cache-tokens        Enables in-memory caching of tokens until just before
+                           expiry. Without caching Azure CLI is invoked on every
+                           request.
+```
+
 ## How to Build
 This project uses [Stack](https://haskellstack.org/) to build.
 
 ```
-> stack setup
 > stack build
 ```
-The `setup` command is only required the first time to ensure you have the correct version of GHC installed.
 
 
 [1]: https://github.com/Azure/azure-sdk-for-net/tree/main/sdk/identity/Azure.Identity

app/Main.hs

@@ -7,22 +7,35 @@ import           Data.Text.IO (putStrLn)
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 import           Data.Version (showVersion)
-import           LMI.WebApi (runWebApi, Port(..), SecretValue(..))
-import           Options.Applicative (Parser, auto, help, hidden, info, infoOption, long, metavar, option, progDesc, short, value, execParser)
+import           LMI.WebApi (ApiSettings(..), runWebApi, Port(..), SecretValue(..))
+import           Options.Applicative (Parser, auto, help, hidden, info, infoOption, long, metavar, option, strOption, progDesc, short, value, execParser, optional, switch, helper, showDefault)
 import           System.Log.FastLogger (LogType'(..), newTimeCache, simpleTimeFormat, withTimedFastLogger, defaultBufSize, ToLogStr (toLogStr))
 import qualified Paths_local_managed_identity as PackageInfo
 
-newtype CommandLineArguments =
-  CommandLineArguments { _claPort :: Port }
+data CommandLineArguments =
+  CommandLineArguments { _claPort :: Port
+                       , _claSecret :: Maybe Text
+                       , _claCacheTokens :: Bool }
 
 commandLineArgumentsParser :: Parser CommandLineArguments
 commandLineArgumentsParser =
   CommandLineArguments
   <$> option auto
     ( long "port"
       <> short 'p'
+      <> help "The port the server will run on"
       <> value 5436
+      <> showDefault
       <> metavar "PORT" )
+  <*> optional (strOption
+    ( long "secret"
+      <> short 's'
+      <> help "The required value of the 'secret' header that must be sent by the client in its requests. If omitted, a random GUID will be used."
+      <> metavar "VALUE" ))
+  <*> switch
+    ( long "cache-tokens"
+      <> help "Enables in-memory caching of tokens until just before expiry. Without caching Azure CLI is invoked on every request."
+      <> short 'c' )
 
 version :: Parser (a -> a)
 version =
@@ -35,14 +48,16 @@ version =
 
 readArguments :: IO CommandLineArguments
 readArguments =
-  execParser $ info (version <*> commandLineArgumentsParser) argsInfo
+  execParser $ info (helper <*> version <*> commandLineArgumentsParser) argsInfo
   where argsInfo = progDesc "Local Managed Identity"
 
 main :: IO ()
 main = do
   timeCache <- newTimeCache "%Y-%m-%d %H:%M:%S"
   CommandLineArguments{..} <- readArguments
-  secret <- UUID.toText <$> UUID.nextRandom
+  secret <- case _claSecret of
+    Just secret -> pure secret
+    Nothing -> UUID.toText <$> UUID.nextRandom
 
   withTimedFastLogger timeCache (LogStdout defaultBufSize) $ \timedFastLogger -> do
     let fastLogger logStr = timedFastLogger (\time -> "[" <> toLogStr time <> "] " <> logStr <> "\n")
@@ -59,7 +74,7 @@ main = do
     putStrLn "-----------------------------------------"
     putStrLn "Server started. Ctrl+C to quit."
 
-    runWebApi fastLogger _claPort (SecretValue secret)
+    runWebApi fastLogger (ApiSettings _claPort (SecretValue secret) _claCacheTokens)
 
 showt :: Show a => a -> Text
 showt = Text.pack . show

src/LMI/Cache.hs

@@ -1,25 +1,49 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 module LMI.Cache
-  ( Cache
-  , newCache
-  , readCache
-  , putCache
+  ( Cache(..)
+  , MVarCache
+  , newMVarCache
+  , NoCache
+  , noCache
   ) where
 
 import           Control.Concurrent.MVar (MVar, readMVar, modifyMVar_, newMVar)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 
-newtype Cache key value = Cache (MVar (Map key value))
+class Cache (cache :: * -> * -> *) where
+  readCache :: (MonadIO m, Ord key) => key -> cache key value -> m (Maybe value)
+  putCache :: (MonadIO m, Ord key) => key -> value -> cache key value -> m ()
 
-newCache :: MonadIO m => m (Cache key value)
-newCache = liftIO $ Cache <$> newMVar Map.empty
 
-readCache :: (MonadIO m, Ord key) => key -> Cache key value -> m (Maybe value)
-readCache key (Cache cacheMVar) = do
-  liftIO $ Map.lookup key <$> readMVar cacheMVar
+newtype MVarCache key value = MVarCache (MVar (Map key value))
 
-putCache :: (MonadIO m, Ord key) => key -> value -> Cache key value -> m ()
-putCache key value (Cache cacheMVar) = do
-  liftIO . modifyMVar_ cacheMVar $ \cache ->
-    pure $ Map.insert key value cache
+instance Cache MVarCache where
+  readCache :: (MonadIO m, Ord key) => key -> MVarCache key value -> m (Maybe value)
+  readCache key (MVarCache cacheMVar) = do
+    liftIO $ Map.lookup key <$> readMVar cacheMVar
+
+  putCache :: (MonadIO m, Ord key) => key -> value -> MVarCache key value -> m ()
+  putCache key value (MVarCache cacheMVar) = do
+    liftIO . modifyMVar_ cacheMVar $ \cache ->
+      pure $ Map.insert key value cache
+
+newMVarCache :: MonadIO m => m (MVarCache key value)
+newMVarCache = liftIO $ MVarCache <$> newMVar Map.empty
+
+
+newtype NoCache key value = NoCache ()
+
+instance Cache NoCache where
+  readCache :: (MonadIO m) => key -> NoCache key value -> m (Maybe value)
+  readCache key _ = do
+    pure Nothing
+
+  putCache :: (MonadIO m, Ord key) => key -> value -> NoCache key value -> m ()
+  putCache key value _ = do
+    pure ()
+
+noCache :: NoCache key value
+noCache = NoCache ()

src/LMI/WebApi.hs

@@ -1,5 +1,6 @@
 module LMI.WebApi
-  ( runWebApi
+  ( ApiSettings(..)
+  , runWebApi
   , SecretValue(..)
   , Port
   ) where
@@ -17,7 +18,7 @@ import           Data.Thyme.Time (UTCTime, getCurrentTime, fromSeconds)
 import           GHC.Base (join)
 import           LMI.AzureCli (AccessToken(..), AccessTokenParams(..), AccessTokenError(..), Error(..))
 import qualified LMI.AzureCli as AzureCli
-import           LMI.Cache (Cache, readCache, putCache, newCache)
+import           LMI.Cache (Cache(readCache, putCache), newMVarCache, MVarCache, noCache)
 import           Network.HTTP.Types.Status (status401, status500)
 import           Network.Wai (Request, queryString)
 import           Network.Wai.Handler.Warp (Port, defaultSettings, setPort)
@@ -52,21 +53,31 @@ instance ToJSON ErrorResponse where
 
 newtype SecretValue = SecretValue Text
 
-runWebApi :: FastLogger -> Port -> SecretValue -> IO ()
-runWebApi log port secretValue = do
-  accessTokenCache <- newCache
-  scottyOpts scottyOptions (api log secretValue accessTokenCache)
+data ApiSettings =
+  ApiSettings { _asPort :: Port
+              , _asSecretValue :: SecretValue
+              , _asCacheTokens :: Bool }
+
+runWebApi :: FastLogger -> ApiSettings -> IO ()
+runWebApi log ApiSettings{..} = do
+  api' <-
+    if _asCacheTokens then do
+      api log _asSecretValue <$> newMVarCache
+    else
+      pure $ api log _asSecretValue noCache
+
+  scottyOpts scottyOptions api'
   where
     scottyOptions = Options silent settings
     silent = 0
-    settings = setPort port defaultSettings
+    settings = setPort _asPort defaultSettings
 
-api :: FastLogger -> SecretValue -> Cache (Maybe Resource) AccessToken -> ScottyM ()
+api :: Cache cache => FastLogger -> SecretValue -> cache (Maybe Resource) AccessToken -> ScottyM ()
 api log expectedSecret accessTokenCache = do
   get "/" (getAccessTokenRoute log expectedSecret accessTokenCache)
 
 
-getAccessTokenRoute :: FastLogger -> SecretValue -> Cache (Maybe Resource) AccessToken -> ActionM ()
+getAccessTokenRoute :: Cache cache => FastLogger -> SecretValue -> cache (Maybe Resource) AccessToken -> ActionM ()
 getAccessTokenRoute log (SecretValue expectedSecret) accessTokenCache = do
   secret <- fmap toStrict <$> header "secret"
   resource <- lookupQueryParam "resource" <$> request
@@ -107,7 +118,7 @@ getAccessTokenRoute log (SecretValue expectedSecret) accessTokenCache = do
     logText :: MonadIO m => Text -> m ()
     logText = liftIO . log . toLogStr
 
-tryAccessTokenCache :: MonadIO m => Maybe Resource -> Cache (Maybe Resource) AccessToken -> m (Maybe AccessToken)
+tryAccessTokenCache :: (MonadIO m, Cache cache) => Maybe Resource -> cache (Maybe Resource) AccessToken -> m (Maybe AccessToken)
 tryAccessTokenCache resource cache = do
   cachedAccessToken <- readCache resource cache
   case cachedAccessToken of