{-# LINE 1 "System/Xattr.hsc" #-}

{-# LINE 2 "System/Xattr.hsc" #-}
{-# LANGUAGE Trustworthy #-}

{-# LINE 4 "System/Xattr.hsc" #-}
--------------------------------------------------------------------------------
-- |
-- Module : System.Xattr
-- Copyright : (c) Evan Klitzke 2009
--             (c) Deian Stefan 2012
-- License : BSD3
-- Maintainer: Evan Klitzke <evan@eklitzke.org>
--             Deian Stefan <deian@cs.stanford.edu>
-- Stability : experimental
-- Portability : GHC only
--
-- Relatively low-level interface to work with extended attributes on Unix
-- systems. This is a fairly straightforward port of the API exposed by SGI's
-- libattr.
--
--------------------------------------------------------------------------------

{-# LINE 21 "System/Xattr.hsc" #-}


{-# LINE 27 "System/Xattr.hsc" #-}

module System.Xattr
    (
    -- * Functions
    -- ** Set Functions
      setxattr
    , lsetxattr
    , fsetxattr

    -- ** Get Functions
    , getxattr
    , lgetxattr
    , fgetxattr

    -- ** List Functions
    , listxattr
    , llistxattr
    , flistxattr

    -- * Data Types
    , AttrName
    , AttrValue
    , XattrMode(..)
    )
    where


{-# LINE 54 "System/Xattr.hsc" #-}

{-# LINE 55 "System/Xattr.hsc" #-}

import Data.Functor ((<$>))
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal.Alloc
import System.Posix.Types
import System.Posix.IO
import System.IO

import Data.ByteString (ByteString
                       , useAsCStringLen
                       , packCStringLen
                       , split)
import Data.ByteString.Char8 (unpack)

-- | Mode for setting attributes.
data XattrMode =
      RegularMode
    -- ^ The attribute will be created if it does not yet exist,
    -- and replace the existing named attribute otherwise.
    | CreateMode
    -- ^ Specifies a pure create, which fails if the named attribute
    -- exists already.
    | ReplaceMode
    -- ^ Specifies a pure replace operation, which fails if the
    -- named attribute does not already exist.
    deriving (Eq, Show)

instance Enum XattrMode where
    fromEnum RegularMode = 0
    fromEnum CreateMode  = 1
{-# LINE 86 "System/Xattr.hsc" #-}
    fromEnum ReplaceMode = 2
{-# LINE 87 "System/Xattr.hsc" #-}
    toEnum 1  = CreateMode
{-# LINE 88 "System/Xattr.hsc" #-}
    toEnum 2 = ReplaceMode
{-# LINE 89 "System/Xattr.hsc" #-}
    toEnum _                      = RegularMode

-- | The name of an attribute. Some filesystems support arbitrarily
-- long names, but for portability it is recommended to use relatively
-- short names (less than 256 bytes).
type AttrName = String 

-- | Thevalue of an attribute. Most filesystems allow for arbitrary
-- binary data with relatively. It is recommended that the length of
-- the value be at most 64KB.
type AttrValue = ByteString

-- | Type for void.
type Void = CChar

--
-- Set extended attributes
--

-- | High level wrapper for a @setxattr@ variant
mkSetxattr :: Show cStringOrCInt =>  String            -- ^ Function name
           -> cStringOrCInt     -- ^ Filepath ('CString') or handle ('CInt')
           -> (cStringOrCInt -> CString -> Ptr Void -> CSize -> CInt -> IO CInt)
           -> AttrName          -- ^ Attribute name
           -> AttrValue         -- ^ New value
           -> XattrMode         -- ^ Mode
           -> IO ()
mkSetxattr funcName pathOrHandle cFunc attrName attrData mode =
  throwErrnoIfMinus1_ funcName $ withCString attrName $ \cName ->
    useAsCStringLen attrData $ \(cVal, cValLen) ->
      let l = fromIntegral cValLen
          m = fromIntegral . fromEnum $ mode
      in cFunc pathOrHandle cName cVal l m

-- | Set extended attribute of a filesystem object.
setxattr :: FilePath    -- ^ Object path
         -> AttrName    -- ^ Attribute name
         -> AttrValue   -- ^ Value
         -> XattrMode   -- ^ Mode
         -> IO ()

{-# LINE 130 "System/Xattr.hsc" #-}
setxattr path name val mode = withCString path $ \cName ->
  mkSetxattr "setxattr" cName c_setxattr name val mode

foreign import ccall unsafe "setxattr"
  c_setxattr  :: CString -> CString -> Ptr Void -> CSize -> CInt -> IO CInt

{-# LINE 138 "System/Xattr.hsc" #-}


-- | Same as 'setxattr', but if the object is a symbolic link the
-- attribute is set on the symbolic link itself, not the object
-- refered to by the link.
lsetxattr :: FilePath -> AttrName -> AttrValue -> XattrMode -> IO ()

{-# LINE 145 "System/Xattr.hsc" #-}
lsetxattr path name val mode = withCString path $ \cName ->
  mkSetxattr "lsetxattr" cName c_lsetxattr name val mode

foreign import ccall unsafe "lsetxattr"
  c_lsetxattr :: CString -> CString -> Ptr Void -> CSize -> CInt -> IO CInt

{-# LINE 153 "System/Xattr.hsc" #-}

-- | Same as 'setxattr', but set the attribute of an open handle.
fsetxattr :: Handle -> AttrName -> AttrValue -> XattrMode -> IO ()

{-# LINE 157 "System/Xattr.hsc" #-}
fsetxattr handle name val mode = handleToFd handle >>= \fd ->
  mkSetxattr "fsetxattr" (fromIntegral fd) c_fsetxattr name val mode

foreign import ccall unsafe "fsetxattr"
  c_fsetxattr :: CInt    -> CString -> Ptr Void -> CSize -> CInt -> IO CInt

{-# LINE 165 "System/Xattr.hsc" #-}

--
-- Get extended attributes
--

-- | High level wrapper for a @getxattr@ variant
mkGetxattr :: String            -- ^ Function name
           -> cStringOrCInt     -- ^ Filepath ('CString') or handle ('CInt')
           -> (cStringOrCInt -> CString -> Ptr Void -> CSize -> IO CSsize)
           -> AttrName          -- ^ Attribute name
           -> IO AttrValue
mkGetxattr funcName pathOrHandle cFunc attrName = do
  withCString attrName $ \cName -> do
    len <- throwErrnoIfMinus1 funcName $
      cFunc pathOrHandle cName (nullPtr) 0
    allocaBytes (fromIntegral len) $ \mem -> do
      len' <- throwErrnoIfMinus1 funcName $
        cFunc pathOrHandle cName mem (fromIntegral len)
      packCStringLen (mem, fromIntegral len')

-- | Get extended attribute of an object.
getxattr :: FilePath -> AttrName -> IO AttrValue

{-# LINE 188 "System/Xattr.hsc" #-}
getxattr path name = withCString path $ \cName ->
  mkGetxattr "getxattr" cName c_getxattr name

foreign import ccall unsafe "getxattr"
  c_getxattr  :: CString -> CString -> Ptr Void -> CSize -> IO CSsize

{-# LINE 196 "System/Xattr.hsc" #-}

-- | Same as 'getxattr', but if the object is a symbolic link, the
-- attribute is retrieved from the link itself and not the referenced
-- object.
lgetxattr :: FilePath -> AttrName -> IO AttrValue

{-# LINE 202 "System/Xattr.hsc" #-}
lgetxattr path name = withCString path $ \cName ->
  mkGetxattr "lgetxattr" cName c_lgetxattr name

foreign import ccall unsafe "lgetxattr"                           
  c_lgetxattr :: CString -> CString -> Ptr Void -> CSize -> IO CSsize

{-# LINE 210 "System/Xattr.hsc" #-}

-- | Same as 'getxattr', but get the attribute of an open handle.
fgetxattr :: Handle -> AttrName -> IO AttrValue

{-# LINE 214 "System/Xattr.hsc" #-}
fgetxattr handle name = handleToFd handle >>= \fd ->
  mkGetxattr "fgetxattr" (fromIntegral fd) c_fgetxattr name

foreign import ccall unsafe "fgetxattr"                           
  c_fgetxattr :: CInt    -> CString -> Ptr Void -> CSize -> IO CSsize

{-# LINE 222 "System/Xattr.hsc" #-}

--
-- List extended attributes
--

-- | High level wrapper for a @listxattr@ variant
mkListxattr :: String            -- ^ Function name
            -> cStringOrCInt     -- ^ Filepath ('CString') or handle ('CInt')
            -> (cStringOrCInt -> CString -> CSize -> IO CSsize)
            -> IO [AttrName]
mkListxattr funcName pathOrHandle cFunc = do
  len <- throwErrnoIfMinus1 funcName $
    cFunc pathOrHandle (nullPtr) 0
  allocaBytes (fromIntegral len) $ \mem -> do
    len' <- throwErrnoIfMinus1 funcName $
      cFunc pathOrHandle mem (fromIntegral len)
    splitNull <$> packCStringLen (mem, fromIntegral len')
  where splitNull s = filter (/= "") $ map unpack $ split 0x0 s

-- | Get a list of all of the extended attributes of an object.
listxattr :: FilePath -> IO [AttrName]

{-# LINE 244 "System/Xattr.hsc" #-}
listxattr path = withCString path $ \cName ->
  mkListxattr "listxattr" cName c_listxattr

foreign import ccall unsafe "listxattr"
  c_listxattr  :: CString -> CString -> CSize -> IO CSsize

{-# LINE 252 "System/Xattr.hsc" #-}

-- | Same as 'listxattr', but if the object is a symbolic link, the
-- attributes of the link itself are returned, not on the referenced object.
llistxattr :: FilePath -> IO [AttrName]

{-# LINE 257 "System/Xattr.hsc" #-}
llistxattr path = withCString path $ \cName ->
  mkListxattr "llistxattr" cName c_llistxattr

foreign import ccall unsafe "llistxattr"
  c_llistxattr :: CString -> CString -> CSize -> IO CSsize

{-# LINE 265 "System/Xattr.hsc" #-}

-- | Same as 'listxattr', but get the attributes of an open handle.
flistxattr :: Handle -> IO [AttrName]

{-# LINE 269 "System/Xattr.hsc" #-}
flistxattr handle = handleToFd handle >>= \fd ->
  mkListxattr "flistxattr" (fromIntegral fd) c_flistxattr

foreign import ccall unsafe "flistxattr"
  c_flistxattr :: CInt    -> CString -> CSize -> IO CSsize

{-# LINE 277 "System/Xattr.hsc" #-}


{-# LINE 279 "System/Xattr.hsc" #-}