Skip to content

Commit

Permalink
Add Quasiquote support
Browse files Browse the repository at this point in the history
  • Loading branch information
rnjtranjan committed Jul 27, 2022
1 parent 61ed504 commit 6afa4c2
Show file tree
Hide file tree
Showing 3 changed files with 165 additions and 23 deletions.
51 changes: 28 additions & 23 deletions src/Streamly/Coreutils/Chmod.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE QuasiQuotes #-}
-- |
-- Module : Streamly.Coreutils.Chmod
-- Copyright : (c) 2022 Composewell Technologies
Expand All @@ -9,38 +10,29 @@
-- change file mode bits.

module Streamly.Coreutils.Chmod
( chmod
( chmod
)
where

import Data.Bits ((.|.), Bits ((.&.), complement))
import Data.Default.Class (Default(..))

import Streamly.Coreutils.StringQ
import qualified System.Posix as Posix

data UserType = Owner | Group | Others deriving (Eq, Ord, Read, Show)

data Permissions = Permissions
{ readable :: Bool
, writable :: Bool
, executable :: Bool
} deriving (Eq, Ord, Read, Show)

instance Default Permissions where
def = Permissions
{ readable = False
, writable = False
, executable = False
}

modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode
modifyBit False b m = m .&. complement b
modifyBit True b m = m .|. b

chmod :: UserType -> Permissions -> FilePath -> IO ()
chmod utype (Permissions r w e) path = do
chmodWith :: UserType -> Permissions -> FilePath -> IO ()
chmodWith utype (Permissions r w e) path = do
case utype of
Owner -> do
Owner -> setOwnerPermissions
Group -> setGroupPermissions
Others -> setOthersPermissions
All -> setAllPermissions

where

setOwnerPermissions = do
stat <- Posix.getFileStatus path
Posix.setFileMode
path
Expand All @@ -49,7 +41,8 @@ chmod utype (Permissions r w e) path = do
. modifyBit r Posix.ownerReadMode
. Posix.fileMode $ stat
)
Group -> do

setGroupPermissions = do
stat <- Posix.getFileStatus path
Posix.setFileMode
path
Expand All @@ -58,7 +51,8 @@ chmod utype (Permissions r w e) path = do
. modifyBit r Posix.groupReadMode
. Posix.fileMode $ stat
)
Others -> do

setOthersPermissions = do
stat <- Posix.getFileStatus path
Posix.setFileMode
path
Expand All @@ -67,3 +61,14 @@ chmod utype (Permissions r w e) path = do
. modifyBit r Posix.otherReadMode
. Posix.fileMode $ stat
)

setAllPermissions = do
setOwnerPermissions
setGroupPermissions
setOthersPermissions

-- | Supports only override permissions bits
-- >> chmod [perm|a=rwx|] "a.txt"
--
chmod :: UserTypePerm -> FilePath -> IO ()
chmod pat = chmodWith (utype pat) (permssions pat)
133 changes: 133 additions & 0 deletions src/Streamly/Coreutils/StringQ.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,133 @@
{-# 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.

module Streamly.Coreutils.StringQ
(
perm
, UserType(..)
, Permissions(..)
, UserTypePerm(..)
)
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, Typeable)
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.Char.Parser as Parser

strParser :: MonadCatch m => Parser m Char 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 ()

data Permissions = Permissions
{ readable :: Bool
, writable :: Bool
, executable :: Bool
} deriving (Eq, Ord, Read, Show, Typeable, Data)

data UserType =
Owner
| Group
| Others
| All
deriving (Eq, Ord, Read, Show, Typeable, Data)

data UserTypePerm =
UserTypePerm
{ utype :: UserType
, permssions :: Permissions
} deriving (Eq, Ord, Read, Show, Typeable, Data)

instance Default Permissions where
def = Permissions
{ readable = False
, writable = False
, executable = False
}

parseExpr :: MonadIO m => String -> m UserTypePerm
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

perm :: QuasiQuoter
perm =
QuasiQuoter
{ quoteExp = quoteExprExp
, quotePat = quoteExprPat
, quoteType = notSupported
, quoteDec = notSupported
}

where

notSupported = error "perm: Not supported."
4 changes: 4 additions & 0 deletions streamly-coreutils.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -105,11 +105,15 @@ library
, unix >= 2.7.0 && < 2.8
, directory >= 1.2.2 && < 1.4
, filepath >= 1.4 && < 1.5
, data-default-class >= 0.1 && < 0.2
, template-haskell >= 2.10.0 && < 2.19.0

hs-source-dirs: src
exposed-modules:
Streamly.Coreutils
, Streamly.Coreutils.Chmod
, Streamly.Coreutils.Common
, Streamly.Coreutils.StringQ
, Streamly.Coreutils.Cp
, Streamly.Coreutils.Directory
, Streamly.Coreutils.Dirname
Expand Down

0 comments on commit 6afa4c2

Please sign in to comment.