{-# 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 { SemaphoreProtocolVersion -> Int
getSemaphoreProtocolVersion :: Int }
  deriving (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
(SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> Eq SemaphoreProtocolVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
== :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
$c/= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
/= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
Eq, Eq SemaphoreProtocolVersion
Eq SemaphoreProtocolVersion =>
(SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Ordering)
-> (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> (SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool)
-> (SemaphoreProtocolVersion
    -> SemaphoreProtocolVersion -> SemaphoreProtocolVersion)
-> (SemaphoreProtocolVersion
    -> SemaphoreProtocolVersion -> SemaphoreProtocolVersion)
-> Ord SemaphoreProtocolVersion
SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Ordering
SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreProtocolVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Ordering
compare :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Ordering
$c< :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
< :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
$c<= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
<= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
$c> :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
> :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
$c>= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
>= :: SemaphoreProtocolVersion -> SemaphoreProtocolVersion -> Bool
$cmax :: SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreProtocolVersion
max :: SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreProtocolVersion
$cmin :: SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreProtocolVersion
min :: SemaphoreProtocolVersion
-> SemaphoreProtocolVersion -> SemaphoreProtocolVersion
Ord, Int -> SemaphoreProtocolVersion -> ShowS
[SemaphoreProtocolVersion] -> ShowS
SemaphoreProtocolVersion -> String
(Int -> SemaphoreProtocolVersion -> ShowS)
-> (SemaphoreProtocolVersion -> String)
-> ([SemaphoreProtocolVersion] -> ShowS)
-> Show SemaphoreProtocolVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemaphoreProtocolVersion -> ShowS
showsPrec :: Int -> SemaphoreProtocolVersion -> ShowS
$cshow :: SemaphoreProtocolVersion -> String
show :: SemaphoreProtocolVersion -> String
$cshowList :: [SemaphoreProtocolVersion] -> ShowS
showList :: [SemaphoreProtocolVersion] -> ShowS
Show)

-- | A semaphore name: a protocol version and an unversioned name string.
data SemaphoreName = SemaphoreName
  { SemaphoreName -> SemaphoreProtocolVersion
semaphoreProtocolVersion :: !SemaphoreProtocolVersion
  , SemaphoreName -> String
unversionedSemaphoreNameString :: !String
  } deriving (SemaphoreName -> SemaphoreName -> Bool
(SemaphoreName -> SemaphoreName -> Bool)
-> (SemaphoreName -> SemaphoreName -> Bool) -> Eq SemaphoreName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemaphoreName -> SemaphoreName -> Bool
== :: SemaphoreName -> SemaphoreName -> Bool
$c/= :: SemaphoreName -> SemaphoreName -> Bool
/= :: SemaphoreName -> SemaphoreName -> Bool
Eq, Int -> SemaphoreName -> ShowS
[SemaphoreName] -> ShowS
SemaphoreName -> String
(Int -> SemaphoreName -> ShowS)
-> (SemaphoreName -> String)
-> ([SemaphoreName] -> ShowS)
-> Show SemaphoreName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemaphoreName -> ShowS
showsPrec :: Int -> SemaphoreName -> ShowS
$cshow :: SemaphoreName -> String
show :: SemaphoreName -> String
$cshowList :: [SemaphoreName] -> ShowS
showList :: [SemaphoreName] -> ShowS
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
    { SemaphoreError -> String
semaphoreErrorIdentifier :: !SemaphoreIdentifier
    }
  | SemaphoreDoesNotExist
    { semaphoreErrorIdentifier :: !SemaphoreIdentifier
    }
  | SemaphoreIncompatibleVersion
    { SemaphoreError -> SemaphoreProtocolVersion
semaphoreErrorActualVersion   :: !SemaphoreProtocolVersion
    , SemaphoreError -> SemaphoreProtocolVersion
semaphoreErrorExpectedVersion :: !SemaphoreProtocolVersion
    }
  | SemaphoreOtherError
    { SemaphoreError -> IOException
semaphoreOtherError :: !IOException
    }
  deriving (Int -> SemaphoreError -> ShowS
[SemaphoreError] -> ShowS
SemaphoreError -> String
(Int -> SemaphoreError -> ShowS)
-> (SemaphoreError -> String)
-> ([SemaphoreError] -> ShowS)
-> Show SemaphoreError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemaphoreError -> ShowS
showsPrec :: Int -> SemaphoreError -> ShowS
$cshow :: SemaphoreError -> String
show :: SemaphoreError -> String
$cshowList :: [SemaphoreError] -> ShowS
showList :: [SemaphoreError] -> ShowS
Show, SemaphoreError -> SemaphoreError -> Bool
(SemaphoreError -> SemaphoreError -> Bool)
-> (SemaphoreError -> SemaphoreError -> Bool) -> Eq SemaphoreError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemaphoreError -> SemaphoreError -> Bool
== :: SemaphoreError -> SemaphoreError -> Bool
$c/= :: SemaphoreError -> SemaphoreError -> Bool
/= :: SemaphoreError -> SemaphoreError -> Bool
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
semaphoreVersion = Int -> SemaphoreProtocolVersion
SemaphoreProtocolVersion Int
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 :: SemaphoreName -> String
semaphoreIdentifier SemaphoreName
sn
  | Int
ver Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1  = SemaphoreName -> String
unversionedSemaphoreNameString SemaphoreName
sn
  | Bool
otherwise = String
"v" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SemaphoreName -> String
unversionedSemaphoreNameString SemaphoreName
sn
  where
    ver :: Int
ver = SemaphoreProtocolVersion -> Int
getSemaphoreProtocolVersion (SemaphoreName -> SemaphoreProtocolVersion
semaphoreProtocolVersion SemaphoreName
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 :: String -> Maybe SemaphoreName
parseSemaphoreIdentifier (Char
'v':String
rest) =
  case ReadS Int
forall a. Read a => ReadS a
reads String
rest of
    [(Int
n, Char
'-':String
name)] -> SemaphoreName -> Maybe SemaphoreName
forall a. a -> Maybe a
Just (SemaphoreProtocolVersion -> String -> SemaphoreName
SemaphoreName (Int -> SemaphoreProtocolVersion
SemaphoreProtocolVersion Int
n) String
name)
    [(Int, String)]
_               -> Maybe SemaphoreName
forall a. Maybe a
Nothing
parseSemaphoreIdentifier String
_ = Maybe SemaphoreName
forall a. Maybe a
Nothing

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

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

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

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