Common.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}

module System.Semaphore.Internal.Common
  ( SemaphoreName(..)
  , SemaphoreIdentifier
  , SemaphoreProtocolVersion(..)
  , SemaphoreError(..)
  , semaphoreVersion
  , semaphoreIdentifier
  , parseSemaphoreIdentifier
  , getSemaphoreSocketPath
  , iToBase62
  ) where

-- base
import Control.Exception ( Exception, IOException )
import GHC.Exts ( Char(..), Int(..), indexCharOffAddr# )

-- directory
import System.Directory ( getTemporaryDirectory, createDirectoryIfMissing )

-- filepath
import System.FilePath ( (</>) )

---------------------------------------
-- Types

-- | The protocol version of a semaphore.
newtype SemaphoreProtocolVersion =
  SemaphoreProtocolVersion { getSemaphoreProtocolVersion :: Int }
  deriving (Eq, Ord, Show)

-- | A semaphore name: a protocol version and an unversioned name string.
data SemaphoreName = SemaphoreName
  { semaphoreProtocolVersion :: !SemaphoreProtocolVersion
  , unversionedSemaphoreNameString :: !String
  } deriving (Eq, Show)

-- | The identifier string of a semaphore, as serialised for transport
-- between processes (e.g. on a command line via @-jsem@).
--
-- For version 1 this is a bare name; for version @N@ (with @N >= 2@)
-- this is @\"v\<N\>-\<name\>\"@.
type SemaphoreIdentifier = String

-- | Errors that can occur when creating or opening a semaphore.
data SemaphoreError
  = SemaphoreAlreadyExists
    { semaphoreErrorIdentifier :: !SemaphoreIdentifier
    }
  | SemaphoreDoesNotExist
    { semaphoreErrorIdentifier :: !SemaphoreIdentifier
    }
  | SemaphoreIncompatibleVersion
    { semaphoreErrorActualVersion   :: !SemaphoreProtocolVersion
    , semaphoreErrorExpectedVersion :: !SemaphoreProtocolVersion
    }
  | SemaphoreOtherError
    { semaphoreOtherError :: !IOException
    }
  deriving (Show, Eq)

instance Exception SemaphoreError

---------------------------------------
-- Version negotiation

-- | The protocol version on this platform.
--
-- The version tracks the IPC mechanism, not the library version:
--
--   * __POSIX:__ 2 (domain sockets, replacing v1 system semaphores).
--   * __Windows:__ 1 (Win32 named semaphores, unchanged from v1).
--   * __Unsupported platforms:__ 0 (no compatible IPC backend).
--
-- Because the version is 1 on Windows, 'semaphoreIdentifier' produces
-- a bare name (no @v\<N\>-@ prefix), matching the v1 format.
semaphoreVersion :: SemaphoreProtocolVersion
#if defined(mingw32_HOST_OS)
semaphoreVersion = SemaphoreProtocolVersion 1
#elif defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
semaphoreVersion = SemaphoreProtocolVersion 0
#else
semaphoreVersion = SemaphoreProtocolVersion 2
#endif


-- | The serialised identifier of a 'SemaphoreName' for transport
-- between processes.
--
-- For version 1 this is the bare name; for version @N@ (@N >= 2@) the
-- name is prefixed with @v\<N\>-@.
semaphoreIdentifier :: SemaphoreName -> SemaphoreIdentifier
semaphoreIdentifier sn
  | ver <= 1  = unversionedSemaphoreNameString sn
  | otherwise = "v" ++ show ver ++ "-" ++ unversionedSemaphoreNameString sn
  where
    ver = getSemaphoreProtocolVersion (semaphoreProtocolVersion sn)

-- | Parse a 'SemaphoreIdentifier' into a 'SemaphoreName'.
--
-- Returns @Nothing@ for unversioned strings (which should be treated as
-- v1 by the caller's compatibility logic).
parseSemaphoreIdentifier :: SemaphoreIdentifier -> Maybe SemaphoreName
parseSemaphoreIdentifier ('v':rest) =
  case reads rest of
    [(n, '-':name)] -> Just (SemaphoreName (SemaphoreProtocolVersion n) name)
    _               -> Nothing
parseSemaphoreIdentifier _ = Nothing

---------------------------------------
-- Utilities

-- | Convert an 'Int' to a base-62 string (digits @0@–@9@, @a@–@z@, @A@–@Z@).
iToBase62 :: Int -> String
iToBase62 m = go m' ""
  where
    m'
      | m == minBound = maxBound
      | otherwise     = abs m
    go n cs | n < 62
            = let !c = chooseChar62 n
              in c : cs
            | otherwise
            = let !(!q, r) = quotRem n 62
                  !c       = chooseChar62 r
              in go q (c : cs)

    chooseChar62 :: Int -> Char
    {-# INLINE chooseChar62 #-}
    chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)
    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#

-- | The socket file path for a semaphore.
getSemaphoreSocketPath :: SemaphoreName -> IO FilePath
getSemaphoreSocketPath sn = do
  tmp <- getTemporaryDirectory
  let dir = tmp </> "semaphore-compat"
  createDirectoryIfMissing True dir
  return (dir </> unversionedSemaphoreNameString sn)