Add Chmod module

src/Streamly/Coreutils/Chmod/Posix.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE QuasiQuotes #-}
+-- |
+-- Module      : Streamly.Coreutils.Chmod.Posix
+-- Copyright   : (c) 2022 Composewell Technologies
+-- License     : BSD-3-Clause
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- change file mode bits.
+
+-- TODO: change this module to Chmod.Posix and later create a portable module.
+--
+-- Design notes:
+--
+-- On Posix systems:
+--
+-- Roles: User (Owner), group (only one), others
+-- Permissions: rwxX(ugo), s(go), t(o)
+--
+-- 1. write: create or delete a file in a directory. Modify contents of a file.
+-- 2. write: modify metadata of a directory or file.
+-- 3. execute: to list a directory's contents
+--
+-- On Windows:
+--
+-- Could not find any good docs by microsoft on a google search.
+-- Managing permissions: https://learn.microsoft.com/en-us/previous-versions/windows/it-pro/windows-server-2008-R2-and-2008/cc770962(v=ws.11)
+-- https://learn.microsoft.com/en-us/windows/security/identity-protection/access-control/access-control
+--
+-- Roles: User (Owner), group (many)
+-- Permissions: read, read+execute, modify (metadata, create/delete files in
+-- dirs), write (write to a file), list dir, full control
+-- Inheritance: permissions can be inherited from parent directories
+-- Advanced Permissions: ...
+--
+-- 1. write: create or delete a file in a directory. Modify contents of a file.
+-- 2. modify: modify metadata of a directory or file.
+-- 3. list dir: to list a directory's contents
+--
+-- Common abstraction for windows/posix:
+--
+-- Roles: User/Owner
+-- Permissions:
+--
+-- 1. write on Posix: write+modify on windows
+-- 2. execute on dir: "list dir" on windows
+--
+-- Other's default permissions are controlled by umask on Posix. When setting
+-- permissions we can ensure that other's permissions are less restrictive than
+-- the owner? But we cannot do the same on windows.
+
+module Streamly.Coreutils.Chmod.Posix
+    (
+    -- * Roles
+      Role (..)
+
+    -- * Permissions
+    , Permissions
+    , setReadable
+    , setWritable
+    , setExecutable
+    , reset
+
+    -- * Chmod
+    , chmodWith
+    , chmod
+    )
+where
+
+import Data.Bits ((.|.), Bits ((.&.), complement))
+import Streamly.Coreutils.StringQ
+import qualified System.Posix as Posix
+import GHC.IO.Unsafe (unsafePerformIO)
+
+modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode
+modifyBit False b m = m .&. complement b
+modifyBit True  b m = m .|. b
+
+chmodWith :: Role -> Permissions -> FilePath -> IO ()
+chmodWith utype (Permissions r w e) path = do
+    case utype of
+        Owner -> setOwnerPermissions
+        Group -> setGroupPermissions
+        Others -> setOthersPermissions
+
+    where
+
+    setOwnerPermissions = do
+        stat <- Posix.getFileStatus path
+        Posix.setFileMode
+            path
+            ( modifyBit e Posix.ownerExecuteMode
+            . modifyBit w Posix.ownerWriteMode
+            . modifyBit r Posix.ownerReadMode
+            . Posix.fileMode $ stat
+            )
+
+    setGroupPermissions = do
+        stat <- Posix.getFileStatus path
+        Posix.setFileMode
+            path
+            ( modifyBit e Posix.groupExecuteMode
+            . modifyBit w Posix.groupWriteMode
+            . modifyBit r Posix.groupReadMode
+            . Posix.fileMode $ stat
+            )
+
+    setOthersPermissions = do
+        stat <- Posix.getFileStatus path
+        Posix.setFileMode
+            path
+            ( modifyBit e Posix.otherExecuteMode
+            . modifyBit w Posix.otherWriteMode
+            . modifyBit r Posix.otherReadMode
+            . Posix.fileMode $ stat
+            )
+
+
+setMode :: Role -> Permissions -> Posix.FileMode -> Posix.FileMode
+setMode utype (Permissions r w e) mode =
+    case utype of
+        Owner -> setOwnerPermissions
+        Group -> setGroupPermissions
+        Others -> setOthersPermissions
+
+        where
+
+        setOwnerPermissions =
+            modifyBit e Posix.ownerExecuteMode
+                $ modifyBit w Posix.ownerWriteMode
+                $ modifyBit r Posix.ownerReadMode mode
+
+        setGroupPermissions =
+            modifyBit e Posix.groupExecuteMode
+                $ modifyBit w Posix.groupWriteMode
+                $ modifyBit r Posix.groupReadMode mode
+
+        setOthersPermissions =
+            modifyBit e Posix.otherExecuteMode
+                $ modifyBit w Posix.otherWriteMode
+                $ modifyBit r Posix.otherReadMode mode
+
+-- | Change the file permission modes for specified roles using the specified
+-- permission modifier functions.
+--
+-- You can use the @mode@ quasiquoter to build the mode conveniently, for
+-- example:
+--
+-- >> chmod [mode|a=rwx|] "a.txt"
+--
+chmod :: [(Role, Permissions -> Permissions)] -> FilePath -> IO ()
+-- To implement this, get the file mode. Transform the FileMode using the roles
+-- and permissions, and then use a single setFileMode call to set the mode in
+-- the end.
+chmod perms path = do
+    stat <- Posix.getFileStatus path
+    let fm = foldl tr (Posix.fileMode stat) perms
+    Posix.setFileMode path fm
+    return ()
+
+    where
+
+    tr mode (role, f) = unsafePerformIO $ do
+        stat <- Posix.getFileStatus path
+        let perm = case role of
+                    Owner ->  uPerm stat
+                    Group ->  gPerm stat
+                    Others -> oPerm stat
+            fperm = f perm
+        return $ setMode role fperm mode
+
+    -- current permissions
+    uPerm stat =
+        Permissions
+            (Posix.fileMode stat .&. Posix.ownerReadMode
+                == Posix.ownerReadMode)
+            (Posix.fileMode stat .&. Posix.ownerWriteMode
+                == Posix.ownerWriteMode)
+            (Posix.fileMode stat .&. Posix.ownerExecuteMode
+                == Posix.ownerExecuteMode)
+
+    gPerm stat =
+        Permissions
+            (Posix.fileMode stat .&. Posix.groupReadMode
+                == Posix.groupReadMode)
+            (Posix.fileMode stat .&. Posix.groupWriteMode
+                == Posix.groupWriteMode)
+            (Posix.fileMode stat .&. Posix.groupExecuteMode
+                == Posix.groupExecuteMode)
+
+    oPerm stat =
+        Permissions
+            (Posix.fileMode stat .&. Posix.otherReadMode
+                == Posix.otherReadMode)
+            (Posix.fileMode stat .&. Posix.otherWriteMode
+                == Posix.otherWriteMode)
+            (Posix.fileMode stat .&. Posix.otherExecuteMode
+                == Posix.otherExecuteMode)

src/Streamly/Coreutils/StringQ.hs

@@ -0,0 +1,184 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- Module      : Streamly.Coreutils.StringQ
+-- Copyright   : (c) 2022 Composewell Technologies
+-- License     : BSD-3-Clause
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- change file mode bits.
+
+-- XXX Rename to "Permissions" or "AccessControl"
+
+module Streamly.Coreutils.StringQ
+    (
+      Role(..)
+    , Permissions(..)
+    , setReadable
+    , setWritable
+    , setExecutable
+    , reset
+    )
+where
+
+import Control.Applicative (Alternative(..))
+import Control.Monad.Catch (MonadCatch)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Data.Char (chr)
+import Data.Data (Data)
+import Data.Default.Class (Default(..))
+import Language.Haskell.TH (Exp, Q, Pat)
+import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ, dataToPatQ)
+import Streamly.Internal.Data.Parser (Parser)
+
+import qualified Streamly.Internal.Data.Fold as Fold
+import qualified Streamly.Internal.Data.Parser as Parser
+import qualified Streamly.Internal.Data.Stream.IsStream as Stream
+import qualified Streamly.Internal.Unicode.Parser as Parser
+
+-------------------------------------------------------------------------------
+-- Permissions
+-------------------------------------------------------------------------------
+
+-- | Permissions for access control
+data Permissions = Permissions
+  { readable :: Bool
+  , writable :: Bool
+  , executable :: Bool
+  -- , searchable :: Bool -- for portability, keep it separate
+  } deriving (Eq, Ord, Read, Show, Data)
+
+{-
+defaultPermissions =
+    Permissions
+    { readable = False
+    , writable = False
+    , executable = False
+    }
+-}
+
+-- | Enable @read@ permission.
+setReadable :: Bool -> Permissions -> Permissions
+setReadable x perms = perms { readable = x }
+
+-- | Enable @write@ permission.
+setWritable :: Bool -> Permissions -> Permissions
+setWritable x perms = perms { writable = x }
+
+-- | Enable @execute@ permission.
+setExecutable :: Bool -> Permissions -> Permissions
+setExecutable x perms = perms { executable = x }
+
+-- | Disable all permissions.
+reset :: Permissions -> Permissions
+reset = setReadable False . setWritable False . setExecutable False
+
+-------------------------------------------------------------------------------
+-- Roles
+-------------------------------------------------------------------------------
+
+-- | Roles to whom access is granted.
+data Role =
+      Owner
+    | Group
+    | Others
+        deriving (Eq, Ord, Read, Show, Data)
+
+-------------------------------------------------------------------------------
+-- Mode parser
+-------------------------------------------------------------------------------
+
+{-
+strParser :: MonadCatch m => Parser Char m String
+strParser =
+    let ut = Parser.char 'u'
+            <|> Parser.char 'g'
+            <|> Parser.char 'o'
+            <|> Parser.char 'a'
+        op = Parser.char '='    -- supports only override permissions bits
+        p1 = Parser.char (chr 0)
+            <|> Parser.char 'r'
+            <|> Parser.char 'w'
+            <|> Parser.char 'x'
+        r  = ut *> op
+        r1 = ut *> op *> p1
+        r2 = ut *> op *> p1 *> p1
+        r3 = ut *> op *> p1 *> p1 *> p1
+        s =  r <|> r1 <|> r2 <|> r3
+      in Parser.some s Fold.toList
+
+expandVars :: String -> IO ()
+expandVars ln =
+    case Stream.parse strParser (Stream.fromList ln) of
+        Left _ -> fail "Parsing of perm quoted string failed."
+        Right _ -> return ()
+
+parseExpr :: MonadIO m => String -> m [(Role, Permissions)]
+parseExpr s = do
+    liftIO $ expandVars s
+    let ut = head s
+        bits = tail $ tail s
+    return $
+        case ut of
+            'u' -> UserTypePerm Owner $ setPermission bits
+            'g' -> UserTypePerm Group $ setPermission bits
+            'o' -> UserTypePerm Others $ setPermission bits
+            'a' -> UserTypePerm All $ setPermission bits
+            _ -> error "Invalid permissions"
+
+    where
+
+    setPermission bits =
+        case bits of
+            "rwx" -> Permissions True True True
+            "rw" -> Permissions True True False
+            "r" ->  Permissions True False False
+            "w" ->  Permissions False True False
+            "x" ->  Permissions False False True
+            "rx" ->  Permissions True False True
+            "wx" ->  Permissions False True True
+            _ ->  def
+
+quoteExprExp :: String -> Q Exp
+quoteExprExp s =  do
+    expr <- parseExpr s
+    dataToExpQ (const Nothing) expr
+
+quoteExprPat :: String -> Q Pat
+quoteExprPat s = do
+    expr <- parseExpr s
+    dataToPatQ (const Nothing) expr
+
+-- TODO: perms can have a single letter from the set ugo, in that case the
+-- existing permissions are copied from that role.
+
+-- When we get a "=" use 'reset', when we get a '+' use an operation with
+-- argument True, else use False.
+
+-- | The format of a symbolic mode is [roles][-+=][perms...], where roles is
+-- either zero or more letters from the set ugoa. perms is either zero or more
+-- letters from the set rwxXst. Multiple symbolic modes can be given, separated
+-- by commas.
+--
+-- Examples:
+--
+-- @
+-- -
+-- -rwx
+-- g-rx
+-- g-x+r
+-- go-x+rw
+-- go-x+rw,u+r
+-- @
+--
+-- If the role is omitted it is assumed to be 'a'.
+mode :: QuasiQuoter
+mode =
+    QuasiQuoter
+        { quoteExp = quoteExprExp
+        , quotePat = quoteExprPat
+        , quoteType = error "mode: quoteType not supported."
+        , quoteDec = error "mode: quoteDec not supported."
+        }
+-}