{-# 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.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 :: (MonadUnliftIO m) => (Credentials -> m (Credentials, r)) -> m r
atomicallyModifyCredentialsFile :: forall (m :: * -> *) r.
MonadUnliftIO m =>
(Credentials -> m (Credentials, r)) -> m r
atomicallyModifyCredentialsFile Credentials -> m (Credentials, r)
f = do
  FilePath
credentialJSONPath <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCredentialJSONFilePath
  IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
credentialJSONPath) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
False -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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

  m r -> IO r
toIO <- m (m r -> IO r)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  IO r -> m r
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ LockingParameters -> FilePath -> IO r -> IO r
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
LockingParameters -> FilePath -> m a -> m a
withLockFile LockingParameters
lockfileConfig (FilePath -> FilePath
withLockExt FilePath
credentialJSONPath) (IO r -> IO r) -> IO r -> IO r
forall a b. (a -> b) -> a -> b
$ m r -> IO r
toIO (m r -> IO r) -> m r -> IO r
forall a b. (a -> b) -> a -> b
$ do
    Credentials
credentials <-
      IO (Either FilePath Credentials) -> m (Either FilePath Credentials)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Either FilePath Credentials)
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
Aeson.eitherDecodeFileStrict FilePath
credentialJSONPath) m (Either FilePath Credentials)
-> (Either FilePath Credentials -> m Credentials) -> m Credentials
forall a b. m a -> (a -> m b) -> m 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
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Credentials -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
credentialJSONPath Credentials
emptyCredentials
          pure Credentials
emptyCredentials
        Right Credentials
creds -> Credentials -> m Credentials
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Credentials
creds
    (Credentials
newCredentials, r
r) <- Credentials -> m (Credentials, r)
f Credentials
credentials
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Credentials
newCredentials Credentials -> Credentials -> Bool
forall a. Eq a => a -> a -> Bool
/= Credentials
credentials) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Credentials -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
credentialJSONPath Credentials
newCredentials
    pure r
r