{- |XAttr provides bindings to the glibc function for reading and manipulating extended attributes (setxattr, getxattr, listxattr, ...).
Each function in this module has two variants: the one with the name
prefixed by \"l\" and \"fd\".  Both of these are identical to the original
version except that the \"l\"-variant does not follow symbolic link but
acts on the link itself, and the \"fd\"-variant take a file descriptor
as argument rather than a filepath.  -}

module System.XAttr
    ( -- *Set extended attributes
      setXAttr
    , lSetXAttr
    , fdSetXAttr
      -- *Create extended attributes
    , createXAttr
    , lCreateXAttr
    , fdCreateXAttr
      -- * Replace extended attributes
    , replaceXAttr
    , lReplaceXAttr
    , fdReplaceXAttr
      -- * Retrive extended attributes
    , getXAttr
    , lGetXAttr
    , fdGetXAttr
      -- * List extended attributes
    , listXAttr
    , lListXAttr
    , fdListXAttr
      -- *Remove extended attributes
    , removeXAttr
    , lRemoveXAttr
    , fdRemoveXAttr )
    where

#include <sys/xattr.h>

import Foreign.C
import Foreign.Ptr
import Foreign.Marshal.Alloc
import System.Posix.Types

xAttrSet :: a ->
            String ->
            String ->
           (a -> CString -> Ptr () -> CSize -> CInt -> IO CInt) ->
           String ->
           CInt ->
           IO ()
xAttrSet f attr value func name mode = throwErrnoIfMinus1_ name $
                                       withCString attr $
                                       \b -> withCStringLen value $
                                       \(c,d) -> func
                                                 f
                                                 b
                                                 (castPtr c)
                                                 (fromIntegral d)
                                                 mode

-- | setXAttr sets the value of an extended attribute.
setXAttr :: FilePath -- ^ target file
         -> String   -- ^ name of attribute to set
         -> String   -- ^ value of attribute
         -> IO ()
setXAttr path attr value = withCString path $
                           \x -> xAttrSet x attr value c_setxattr "setxattr" 0


lSetXAttr :: FilePath -> String -> String -> IO ()
lSetXAttr path attr value = withCString path $
                           \x -> xAttrSet x attr value c_lsetxattr "lsetxattr" 0

fdSetXAttr :: Fd -> String -> String -> IO ()
fdSetXAttr (Fd n) attr value = xAttrSet n attr value c_fsetxattr "fsetxattr" 0


-- | createXAttr is identical to setXAttr, but if the attribute
-- already exists it fails and sets errno to EEXIST.
createXAttr :: FilePath -> String -> String -> IO ()
createXAttr path attr value = withCString path $
                              \x -> xAttrSet x attr value
                                    c_setxattr
                                    "setxattr"
                                    #{const XATTR_CREATE}


lCreateXAttr :: FilePath -> String -> String -> IO ()
lCreateXAttr path attr value = withCString path $
                               \x -> xAttrSet x attr value
                                     c_lsetxattr 
                                     "lsetxattr"
                                     #{const XATTR_CREATE}

fdCreateXAttr :: Fd -> String -> String -> IO ()
fdCreateXAttr (Fd n) attr value = xAttrSet n attr value
                                  c_fsetxattr
                                  "fsetxattr"
                                  #{const XATTR_CREATE}

-- | replaceXAttr is identical to setXAttr, but if the attribute
-- does not exist it fails and sets errno to ENOATTR.
replaceXAttr :: FilePath -> String -> String -> IO ()
replaceXAttr path attr value = withCString path $
                               \x -> xAttrSet x attr value
                                     c_setxattr
                                     "setxattr"
                                     #{const XATTR_REPLACE}

lReplaceXAttr :: FilePath -> String -> String -> IO ()
lReplaceXAttr path attr value = withCString path $
                                \x -> xAttrSet x attr value
                                      c_lsetxattr
                                      "lsetxattr"
                                      #{const XATTR_REPLACE}

fdReplaceXAttr :: Fd -> String -> String -> IO ()
fdReplaceXAttr (Fd n) attr value = xAttrSet n attr value
                                   c_fsetxattr
                                   "fsetxattr"
                                   #{const XATTR_REPLACE}



xAttrGet f attr func name = withCString attr $
                            \cstr -> (do
                                       size <- throwErrnoIfMinus1 name $
                                               func f cstr nullPtr 0
                                       ptr <- mallocBytes (fromIntegral size)
                                       throwErrnoIfMinus1 name $
                                                          func f cstr ptr (fromIntegral size)
                                       str <- peekCStringLen (castPtr (ptr), (fromIntegral size))
                                       free ptr
                                       return str)

-- | getXAttr retrieves the value of an extended attribute 
getXAttr :: FilePath     -- ^ target file
         -> String       -- ^ name of the attribute
         -> IO (String)  -- ^ value of the attribute
getXAttr path attr = withCString path $
                     \x -> xAttrGet x attr c_getxattr "getxattr"

lGetXAttr :: FilePath -> String -> IO (String)
lGetXAttr path attr = withCString path $
                     \x -> xAttrGet x attr c_lgetxattr "lgetxattr"

fdGetXAttr :: Fd -> String -> IO (String)
fdGetXAttr (Fd n) attr = xAttrGet n attr c_fgetxattr "fgetxattr"




xAttrList f func name = do
  size <- throwErrnoIfMinus1 name (func f nullPtr 0)
  ptr <- mallocBytes (fromIntegral size)
  throwErrnoIfMinus1 name (func f ptr (fromIntegral size))
  str <- peekCStringLen (ptr, (fromIntegral size))
  free ptr
  return $ split str
    where split "" = []
          split xs = (fst c):(split $ tail $ snd c)
              where c = break (\x -> x == '\NUL') xs


-- | listXAttr retrieves the list of attribute names associated with
-- the given filepath.
listXAttr :: FilePath      -- ^ target file
          -> IO ([String]) -- ^ list of attribute names
listXAttr path = withCString path $
                 \a -> xAttrList a c_listxattr "listxattr"

lListXAttr :: FilePath -> IO ([String])
lListXAttr path = withCString path $
                  \a -> xAttrList a c_llistxattr "llistxattr"

fdListXAttr :: Fd -> IO ([String])
fdListXAttr (Fd n) = xAttrList n c_flistxattr "flistxattr"


xAttrRemove f attr func name = throwErrnoIfMinus1_ name $
                               withCString attr (func f)


-- | removeXAttr removes an extended attribute from the give filepath.
removeXAttr :: FilePath -- ^ target file
            -> String   -- ^ name of the attribute
            -> IO ()
removeXAttr path attr = withCString path $
                        \cstr -> xAttrRemove cstr attr c_removexattr "removexattr"


lRemoveXAttr :: FilePath -> String -> IO ()
lRemoveXAttr path attr = withCString path $
                        \cstr -> xAttrRemove cstr attr c_lremovexattr "lremovexattr"

fdRemoveXAttr :: Fd -> String -> IO ()
fdRemoveXAttr (Fd n) attr = xAttrRemove n attr c_fremovexattr "fremovexattr"


foreign import ccall unsafe "setxattr" c_setxattr :: CString -> CString -> Ptr () -> CSize -> CInt -> IO CInt
foreign import ccall unsafe "lsetxattr" c_lsetxattr :: CString -> CString -> Ptr () -> CSize -> CInt -> IO CInt
foreign import ccall unsafe "fsetxattr" c_fsetxattr :: CInt -> CString -> Ptr () -> CSize -> CInt -> IO CInt

foreign import ccall unsafe "getxattr" c_getxattr :: CString -> CString -> Ptr () -> CSize -> IO CSsize
foreign import ccall unsafe "lgetxattr" c_lgetxattr :: CString -> CString -> Ptr () -> CSize -> IO CSsize
foreign import ccall unsafe "fgetxattr" c_fgetxattr :: CInt -> CString -> Ptr () -> CSize -> IO CSsize

foreign import ccall unsafe "listxattr" c_listxattr :: CString -> CString -> CSize -> IO CSsize
foreign import ccall unsafe "llistxattr" c_llistxattr :: CString -> CString -> CSize -> IO CSsize
foreign import ccall unsafe "flistxattr" c_flistxattr :: CInt -> CString -> CSize -> IO CSsize

foreign import ccall unsafe "removexattr" c_removexattr :: CString -> CString -> IO CInt
foreign import ccall unsafe "lremovexattr" c_lremovexattr :: CString -> CString -> IO CInt
foreign import ccall unsafe "fremovexattr" c_fremovexattr :: CInt -> CString -> IO CInt