{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module PiHoole
( Repo(..)
, Branch(..)
, Role(..)
, UserName(..)
, parseUserName
, GroupName(..)
, parseGroupName
, Configuration(..)
, Pijul(..)
, Action(..)
, parsePijul
, Privilege(..)
, privilegeLe
, requires
, checkPrivilege
, callPijul
, recordPijul
) where
import Control.Applicative ((<|>))
import Control.Monad (void)
import Data.Aeson (FromJSON (..), FromJSONKey (..),
ToJSON (..), ToJSONKey (..), Value (..),
decodeStrict)
import Data.Aeson.Types (FromJSONKeyFunction (..), Parser,
toJSONKeyText)
import Data.Map.Strict (Map, (!?))
import qualified Data.Map.Strict as M (foldlWithKey)
import Data.Maybe (maybe)
import Data.Set (Set)
import qualified Data.Set as S (empty, foldl, fromList, insert,
isSubsetOf, member, toList)
import Data.String (IsString (..))
import Data.Text (Text, append, pack, unpack)
import qualified Data.Text as T (drop, intercalate, take, uncons,
words)
import qualified Data.Text.Encoding as T (encodeUtf8)
import Data.Void (Void)
import GHC.Generics (Generic)
import System.Directory (getHomeDirectory)
import System.FilePath (isRelative)
import System.IO (hGetContents)
import System.Process (callProcess, createPipe, runProcess)
import Text.Megaparsec (Parsec, eof, many, manyTill, parseMaybe,
some, takeP)
import Text.Megaparsec.Char (anyChar, char, oneOf, space, space1,
string)
newtype Branch = Branch { unBranch :: Text}
deriving (Eq, Ord, Show, Generic, IsString, ToJSON, FromJSON)
newtype Repo = Repo FilePath
deriving (Eq, Ord, Show, Generic, IsString, ToJSON)
textToRepo :: String -> Parser Repo
textToRepo txt = if isRelative txt
then pure (Repo txt)
else fail "repo path has to be relative"
instance FromJSON Repo where
parseJSON (String txt) = textToRepo (unpack txt)
instance FromJSONKey Repo where
fromJSONKey = FromJSONKeyTextParser (textToRepo . unpack)
newtype UserName = UserName Text
deriving (Eq, Ord, Show, IsString)
aesonMaybe :: String -> Maybe a -> Parser a
aesonMaybe _ (Just x) = pure x
aesonMaybe error Nothing = fail error
parsePrefix :: Char -> Text -> Maybe Text
parsePrefix c txt = do
(c', rst) <- T.uncons txt
if c == c'
then pure rst
else Nothing
parseUserName :: Text -> Maybe UserName
parseUserName txt = UserName <$> parsePrefix '.' txt
instance FromJSON UserName where
parseJSON (String txt) =
aesonMaybe "username should be prefixed with '.'"
(parseUserName txt)
instance ToJSON UserName where
toJSON (UserName txt) = String $ "." `append` txt
newtype GroupName = GroupName Text
deriving (Eq, Ord, Show, IsString)
parseGroupName :: Text -> Maybe GroupName
parseGroupName txt = GroupName <$> parsePrefix '+' txt
instance FromJSON GroupName where
parseJSON (String txt) =
aesonMaybe "group should be prefixed with '+'"
(parseGroupName txt)
instance FromJSONKey GroupName where
fromJSONKey = FromJSONKeyTextParser $ \txt -> parseJSON (String txt)
instance ToJSON GroupName where
toJSON (GroupName txt) = String $ "+" `append` txt
data Role = User UserName
| Group GroupName
| Anon
deriving (Eq, Ord, Show)
roleToText :: Role -> Text
roleToText (User (UserName name)) = "." `append` name
roleToText (Group (GroupName name)) = "+" `append` name
roleToText Anon = "anon"
textToRole :: Text -> Parser Role
textToRole "anon" = pure Anon
textToRole txt = (User <$> parseJSON (String txt))
<|> (Group <$> parseJSON (String txt))
instance FromJSON Role where
parseJSON (String txt) = textToRole txt
instance FromJSONKey Role where
fromJSONKey = FromJSONKeyTextParser textToRole
instance ToJSON Role where
toJSON = toJSON . roleToText
instance ToJSONKey Role where
toJSONKey = toJSONKeyText roleToText
data Scope = All
| Only (Set Branch)
| None
deriving (Eq, Show)
data Privilege = Privilege { read :: Scope
, write :: Scope
}
deriving (Show)
readAllScope :: Parsec Void Text Scope
readAllScope = do
char '+'
char 'r'
pure All
branch :: Parsec Void Text Branch
branch = Branch . pack <$> some (oneOf ['a'..'z'])
branches :: Parsec Void Text (Set Branch)
branches = do
char '['
fst <- branch
rst <- many branches'
char ']'
pure (S.fromList (fst:rst))
where
branches' = do
char ','
space
branch
readScope :: Parsec Void Text Scope
readScope = do
char '+'
char 'r'
(Only <$> branches) <|> pure All
writeScope :: Parsec Void Text Scope
writeScope =
(do char '-'
char 'w'
pure None)
<|> (do char '+'
char 'w'
(Only <$> branches) <|> pure All)
scopeLe :: Scope -> Scope -> Bool
scopeLe None _ = True
scopeLe _ All = True
scopeLe (Only set1) (Only set2) = S.isSubsetOf set1 set2
scopeLe _ _ = False
privilegeLe :: Privilege -> Privilege -> Bool
privilegeLe (Privilege r1 w1) (Privilege r2 w2) =
r1 `scopeLe` r2
&& w1 `scopeLe` w2
textToPrivilege :: Text -> Parser Privilege
textToPrivilege txt = case T.words txt of
[p] -> case parseMaybe readScope p of
Just x -> pure $ Privilege x None
Nothing -> case parseMaybe writeScope p of
Just x -> pure $ Privilege x x
Nothing -> fail $ "Invalid privilege notation " ++ unpack p
[p1, p2] -> case (parseMaybe readScope p1, parseMaybe writeScope p2) of
(Just r, Just w) -> if scopeLe w r
then pure $ Privilege r w
else fail $ "write privilege " ++ unpack p2 ++ " is not less restrictive than read privilege " ++ unpack p1
(_, _) -> case (parseMaybe readScope p2, parseMaybe writeScope p1) of
(Just r, Just w) -> if scopeLe w r
then pure $ Privilege r w
else fail $ "write privilege " ++ unpack p1 ++ " is not less restrictive than read privilege " ++ unpack p2
(_, _) -> fail $ "cannot parse privileges " ++ unpack txt
instance ToJSON Privilege where
toJSON (Privilege r w) = toJSON $ priv "r" r `append` " " `append` priv "w" w
where priv :: Text -> Scope -> Text
priv t All = "+" `append` t
priv t None = "-" `append` t
priv t (Only br) = let str = T.intercalate "," (unBranch <$> S.toList br)
in "+" `append` t `append` "[" `append` str `append` "]"
data Pijul = Pijul Repo Action
deriving (Show)
data Action = Log Branch
| Apply Branch
| Patch Text
deriving (Show)
parsePijul :: Text -> Maybe Pijul
parsePijul = parseMaybe parser
where
parser :: Parsec Void Text Pijul
parser = do
string "pijul"
space
(do string "log"
space1
(rp, br) <- repoAndBranch
space1
string "--hash-only"
eof
pure $ Pijul rp (Log br))
<|> (do string "apply"
space1
(rp, br) <- repoAndBranch
eof
pure $ Pijul rp (Apply br))
<|> (do string "patch"
space1
rp <- repo
space
p <- patch
eof
pure $ Pijul rp (Patch p))
repo = do
string "--repository"
space1
rp <- manyTill anyChar space1
pure $ Repo rp
branch = do
string "--branch"
space1
string "\""
br <- manyTill anyChar (char '"')
pure $ Branch (pack br)
repoAndBranch = do
r <- repo
space
b <- branch
pure (r, b)
patch = do
string "--bin"
space1
takeP Nothing 88
instance FromJSON Privilege where
parseJSON (String str) = textToPrivilege str
data Configuration = Configuration { groups :: Map GroupName (Set UserName)
, repositories :: Map Repo (Map Role Privilege)
}
deriving (Show, Generic)
instance FromJSON Configuration
belongsTo :: Map GroupName (Set UserName) -> UserName -> Set GroupName
belongsTo conf name = M.foldlWithKey aux S.empty conf
where aux set group users = if name `S.member` users
then S.insert group set
else set
requires :: Action -> Privilege
requires (Log branch) = Privilege (Only $ S.fromList [ branch ]) None
requires (Patch _) = Privilege (Only $ S.fromList []) None
requires (Apply branch) = Privilege None (Only $ S.fromList [ branch ])
checkPrivilege :: UserName -> Pijul -> Configuration -> Bool
checkPrivilege user (Pijul repo action) conf =
maybe False
(\rules -> check rules (User user) || S.foldl (aux rules) False grps)
(repos !? repo)
where
needed = requires action
repos = repositories conf
grps = belongsTo (groups conf) user
check rules role = maybe False (needed `privilegeLe`) (rules !? role)
aux _ True _ = True
aux rules False grp = check rules (Group grp)
callPijul :: Pijul -> IO ()
callPijul pijul = callProcess "pijul" $ pijulArgs pijul
recordPijul :: Pijul -> IO String
recordPijul pijul = do
(rd, wd) <- createPipe
home <- getHomeDirectory
runProcess "pijul" (pijulArgs pijul) (Just home) Nothing Nothing (Just wd) Nothing
hGetContents rd
pijulArgs :: Pijul -> [String]
pijulArgs (Pijul (Repo repo) action) =
[ actionVerb action
, "--repository"
, repo
] ++ actionArgs action
where
actionVerb :: Action -> String
actionVerb (Log _) = "log"
actionVerb (Patch _) = "patch"
actionVerb (Apply _) = "apply"
actionArgs :: Action -> [String]
actionArgs (Log (Branch branch)) = [ "--branch"
, unpack branch
, "--hash-only"
]
actionArgs (Patch hash) = [ "--bin"
, unpack hash
]
actionArgs (Apply (Branch branch)) = [ "--branch"
, unpack branch
]