{-# LANGUAGE NumericUnderscores #-}

module Unison.Auth.CredentialFile
  ( atomicallyModifyCredentialsFile,
    getCredentialJSONFilePath,
  )
where

import Control.Monad.Catch (MonadMask)
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 :: IO FilePath
getCredentialJSONFilePath :: IO FilePath
getCredentialJSONFilePath = do
  FilePath
unisonDataDir <- XdgDirectory -> FilePath -> IO 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 :: (MonadMask m, MonadIO m) => (Credentials -> m (Credentials, r)) -> FilePath -> m r
atomicallyModifyCredentialsFile :: forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
(Credentials -> m (Credentials, r)) -> FilePath -> m r
atomicallyModifyCredentialsFile Credentials -> m (Credentials, r)
f FilePath
credentialJSONPath = 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 -> 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 -> m r -> m r
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
LockingParameters -> FilePath -> m a -> m a
withLockFile LockingParameters
lockfileConfig (FilePath -> FilePath
withLockExt FilePath
credentialJSONPath) do
    Credentials
credentials <-
      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
$
        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
            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
    (Credentials
newCredentials, r
r) <- Credentials -> m (Credentials, r)
f Credentials
credentials
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 () -> 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