{-# LANGUAGE NumericUnderscores #-}

module Unison.Auth.CredentialFile (atomicallyModifyCredentialsFile) where

import Data.Aeson qualified as Aeson
import System.FilePath (takeDirectory, (</>))
import System.IO.LockFile
import Unison.Auth.Types
import Unison.Debug qualified as Debug
import Unison.Prelude
import UnliftIO.Directory

lockfileConfig :: LockingParameters
lockfileConfig :: LockingParameters
lockfileConfig =
  LockingParameters
    { retryToAcquireLock :: RetryStrategy
retryToAcquireLock = Word8 -> RetryStrategy
NumberOfTimes Word8
3,
      sleepBetweenRetries :: Word64
sleepBetweenRetries = Word64
sleepTimeMicros
    }
  where
    sleepTimeMicros :: Word64
sleepTimeMicros = Word64
100_000 -- 100ms

getCredentialJSONFilePath :: (MonadIO m) => m FilePath
getCredentialJSONFilePath :: forall (m :: * -> *). MonadIO m => m FilePath
getCredentialJSONFilePath = do
  FilePath
unisonDataDir <- XdgDirectory -> FilePath -> m FilePath
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> FilePath -> m FilePath
getXdgDirectory XdgDirectory
XdgData FilePath
"unisonlanguage"
  pure (FilePath
unisonDataDir FilePath -> FilePath -> FilePath
</> FilePath
"credentials.json")

-- | Atomically update the credential storage file.
-- Creates an empty file automatically if one doesn't exist.
atomicallyModifyCredentialsFile :: (MonadIO m) => (Credentials -> Credentials) -> m Credentials
atomicallyModifyCredentialsFile :: forall (m :: * -> *).
MonadIO m =>
(Credentials -> Credentials) -> m Credentials
atomicallyModifyCredentialsFile Credentials -> Credentials
f = IO Credentials -> m Credentials
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> m Credentials)
-> IO Credentials -> m Credentials
forall a b. (a -> b) -> a -> b
$ do
  FilePath
credentialJSONPath <- IO FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCredentialJSONFilePath
  FilePath -> IO Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
credentialJSONPath IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
False -> do
      Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
credentialJSONPath
      FilePath -> Credentials -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
credentialJSONPath Credentials
emptyCredentials

  LockingParameters -> FilePath -> IO Credentials -> IO Credentials
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
LockingParameters -> FilePath -> m a -> m a
withLockFile LockingParameters
lockfileConfig (FilePath -> FilePath
withLockExt FilePath
credentialJSONPath) (IO Credentials -> IO Credentials)
-> IO Credentials -> IO Credentials
forall a b. (a -> b) -> a -> b
$ do
    Credentials
credentials <-
      FilePath -> IO (Either FilePath Credentials)
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
Aeson.eitherDecodeFileStrict FilePath
credentialJSONPath IO (Either FilePath Credentials)
-> (Either FilePath Credentials -> IO Credentials)
-> IO Credentials
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- If something goes wrong, just wipe the credentials file so we're in a clean slate.
        -- In the worst case the user will simply need to log in again.
        Left FilePath
err -> do
          DebugFlag -> FilePath -> FilePath -> IO ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> FilePath -> a -> m ()
Debug.debugM DebugFlag
Debug.Auth FilePath
"Error decoding credentials file" FilePath
err
          FilePath -> Credentials -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
credentialJSONPath Credentials
emptyCredentials
          pure Credentials
emptyCredentials
        Right Credentials
creds -> Credentials -> IO Credentials
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Credentials
creds
    let newCredentials :: Credentials
newCredentials = Credentials -> Credentials
f Credentials
credentials
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Credentials
newCredentials Credentials -> Credentials -> Bool
forall a. Eq a => a -> a -> Bool
/= Credentials
credentials) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> Credentials -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
credentialJSONPath (Credentials -> IO ()) -> Credentials -> IO ()
forall a b. (a -> b) -> a -> b
$ Credentials
newCredentials
    pure Credentials
newCredentials