pi-hoole 0.1.0.0 → 0.2.0.0
raw patch · 6 files changed
+333/−55 lines, 6 filesdep +blaze-htmldep +shakespearedep ~directory
Dependencies added: blaze-html, shakespeare
Dependency ranges changed: directory
Files
- ChangeLog.md +5/−1
- README.md +20/−0
- app/shell/Main.hs +25/−13
- app/web/Main.hs +184/−31
- pi-hoole.cabal +7/−5
- src/PiHoole.hs +92/−5
ChangeLog.md view
@@ -1,3 +1,7 @@ # Changelog for pi-hoole -## Unreleased changes+## pijul-0.2.0.0++* `pi-hoole-shell`: When users connect to the host using SSH, but without any+ command, they will get a summary of their rights+* `pi-hoole-web`: Add a web page to list clonable pijul repositories with HTTP
README.md view
@@ -164,6 +164,26 @@ } ``` +For `pi-hoole-web` to work correcty, it needs an additional configuration file,+assumed to be at `${XDG_CONFIG_DIRECTORY}/pi-hoole/web.yaml`. This file is+currently very simple, it contains only three fields:++* `title`: The title of the summary page+* `baseUrl`: The base URL used to clone the repositories+* `example`: Should be one of the public repositories++Here is an example:++```+title: "my repositories"+baseUrl: "https://my.repo.com"+example: "pi-hoole"+```++If you add a file called `description` in the `.pijul` directory of your public+repositories, its content will be used by `pi-hoole-web` when it gives a summary+of the public repositories.+ ## Limitations ### Private Branches
app/shell/Main.hs view
@@ -19,8 +19,9 @@ module Main where +import Control.Monad (void) import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M (fromList)+import qualified Data.Map.Strict as M (fromList, traverseWithKey) import Data.Set (Set) import qualified Data.Set as S (fromList) import Data.Text (Text, append, pack, unpack)@@ -34,14 +35,17 @@ ------------------------------------------------------------------------------- main :: IO ()-main = getArgs >>= \case- [ "--license" ] ->- putStrLn license- [ user, "" ] ->- putStrLn $ "connected as " ++ user- [ user, cmd ] ->- getConfiguration >>= \case- Just cfg ->+main = getConfiguration >>= \case+ Just cfg -> getArgs >>= \case+ [ "--license" ] ->+ putStrLn license+ [ user, "" ] ->+ case parseUserName (pack user) of+ Just user@(UserName username) -> do+ putStrLn $ "Connected as " ++ unpack username ++ "\n"+ printPrivileges (hasPrivileges (User user) cfg)+ putStrLn ""+ [ user, cmd ] -> case (parseUserName (pack user), parsePijul (pack cmd)) of (Just user, Just cmd) -> pijulProxy cfg user cmd@@ -49,13 +53,21 @@ putStrLn $ user ++ " is not a valid role" (_, Nothing) -> putStrLn $ cmd ++ " is not a valid pijul command"- Nothing ->- putStrLn "could not parse the configuration file"- _ ->- putStrLn "incorrect shell command"+ _ ->+ putStrLn "incorrect shell command"+ Nothing ->+ putStrLn "could not parse the configuration file"++ ------------------------------------------------------------------------------- -------------------------------------------------------------------------------+printPrivileges :: Map Repo Privilege -> IO ()+printPrivileges map = void $ M.traverseWithKey printPrivilege map+ where+ printPrivilege (Repo repo) priv =+ putStrLn $ "- " ++ repo ++ ": " ++ unpack (privilegeToText priv)+ getConfiguration :: IO (Maybe Configuration) getConfiguration = getXdgDirectory XdgConfig "pi-hoole/config.yaml" >>= decodeFile
app/web/Main.hs view
@@ -14,46 +14,68 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. +{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module Main where -import Control.Applicative ((<|>))-import Data.ByteString.Base58 (bitcoinAlphabet, decodeBase58)-import Data.Map.Strict (Map, (!?))-import Data.Maybe (fromJust, maybe)-import Data.String (fromString)-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding (decodeUtf8)-import Data.Yaml (decodeFile)-import Network.HTTP.Types.Method (methodGet)-import Network.HTTP.Types.Status (status200, status404)-import Network.Wai (Application, Request, pathInfo,- requestMethod, responseLBS)-import Network.Wai.Handler.Warp (run)-import PiHoole (Action (Log, Patch), Branch (..),- Configuration (repositories),- Pijul (..), Privilege, Repo (..),- Role (Anon), privilegeLe,- recordPijul, requires)-import System.Directory (XdgDirectory (..), getXdgDirectory)-import System.FilePath (FilePath, (</>))-import Text.Regex.PCRE ((=~))+import Control.Applicative ((<|>))+import Data.Aeson (FromJSON)+import Data.ByteString.Base58 (bitcoinAlphabet, decodeBase58)+import Data.ByteString.Lazy (ByteString)+import Data.Map.Strict (Map, (!?))+import qualified Data.Map.Strict as M (empty, foldlWithKey,+ toList, traverseWithKey)+import Data.Maybe (fromJust, fromMaybe, maybe)+import Data.String (IsString, fromString)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.Lazy as TL (unpack)+import Data.Yaml (decodeFile)+import GHC.Generics (Generic)+import Network.HTTP.Types.Method (methodGet)+import Network.HTTP.Types.Status (status200, status404)+import Network.Wai (Application, Request, pathInfo,+ requestMethod, responseLBS)+import Network.Wai.Handler.Warp (run)+import PiHoole (Action (Log, Patch),+ Branch (..),+ Configuration (repositories),+ Pijul (..), Privilege,+ Repo (..), Role (Anon),+ fetchDescription, hasPrivileges,+ privilegeLe, recordPijul,+ requires)+import System.Directory (XdgDirectory (..),+ getXdgDirectory)+import System.FilePath (FilePath, (</>))+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Cassius (cassius, renderCss)+import Text.Hamlet (HtmlUrl, hamlet)+import Text.Regex.PCRE ((=~)) main :: IO ()-main = getConfiguration >>= \case- Just cfg -> run 8080 (piHooleWeb $ repositories cfg)- Nothing -> putStrLn "Could not open or parse the configuration file"+main = do+ cfg <- getConfiguration+ web <- getWebSetting - where piHooleWeb :: Map Repo (Map Role Privilege) -> Application- piHooleWeb cfg req respond =+ case (cfg, web) of+ (Just cfg, Just web) -> run 8080 (piHooleWeb web cfg)+ (Nothing, _) -> putStrLn "Could not open or parse pi-hoole configuration file"+ (_, Nothing) -> putStrLn "Could not open or parse pi-hoole-web configuration file"++ where piHooleWeb :: WebSetting -> Configuration -> Application+ piHooleWeb web cfg req respond = let action = requestToPijul req in- if maybe False (pijulToPrivileges cfg) action+ if maybe False (pijulToPrivileges . repositories $ cfg) action then do res <- recordPijul (fromJust action) respond $ responseLBS status200 [] (fromString res)- else do print req- respond $ responseLBS status404 [] "Sorry"+ else do+ page <- mapM (render web cfg) (requestToRoute req)+ respond $ maybe (responseLBS status404 [] "Sorry") (responseLBS status200 []) page pijulToPrivileges :: Map Repo (Map Role Privilege) -> Pijul -> Bool pijulToPrivileges cfg (Pijul repo action) =@@ -99,8 +121,139 @@ patchRegex :: String patchRegex = "(.*)\\.gz" - isGet :: Request -> Bool- isGet = (== methodGet) . requestMethod+isGet :: Request -> Bool+isGet = (== methodGet) . requestMethod getConfiguration :: IO (Maybe Configuration) getConfiguration = getXdgDirectory XdgConfig "pi-hoole/config.yaml" >>= decodeFile++data Route = Home+ | Css++requestToRoute :: Request -> Maybe Route+requestToRoute req+ | isGet req = parseRequest (pathInfo req)+ | otherwise = Nothing+ where+ parseRequest [] = Just Home+ parseRequest ["style.css"] = Just Css+ parseRequest _ = Nothing++render :: WebSetting -> Configuration -> Route -> IO ByteString+render web conf Home = do+ repos <- M.traverseWithKey (\repo _ -> fetchDescription repo) (hasPrivileges Anon conf)++ pure . renderHtml $ renderHome web repos route+render _ _ Css = pure . fromString . TL.unpack $ renderCss $ [cassius|+html, body+ width: 100%+ height: 100%+ font-family: Arial+ color: #2e2e2e++a+ color: black++header, main+ width: 90%+ max-width: 800px+ margin: auto++main+ table+ margin-top: 3em+ margin-bottom: 3em+ border-spacing: 0+ max-width: 100%+ thead+ color: black++ td+ font-weight: bold+ border-bottom: 2px solid #f0f0f0+ text-align: center+ padding-top: 0.2em+ padding-bottom: 0.2em++ td+ padding-right: 2em+ padding-left: 2em++footer+ text-align: center+ font-size: 0.8em+|] route++renderHome :: WebSetting -> Map Repo (Maybe String) -> HtmlUrl Route+renderHome web repos = layout web [hamlet|+<table>+ <thead>+ <tr>+ <td>+ Name+ <td>+ Description+ <tbody>+ $forall (Repo repo, description) <- M.toList repos+ ^{renderRepo repo description}++ <p>+ You can clone these repositories, using the following command:++ <pre>+ <code>+ pijul clone #{baseUrl web </> "<Name>"}++ <p>+ For instance, you can clone <code>#{example web}</code>:++ <pre>+ <code>+ pijul clone #{baseUrl web </> example web}+|]+ where+ renderRepo :: FilePath -> Maybe String -> HtmlUrl Route+ renderRepo name description = [hamlet|+<tr>+ <td>+ #{name}+ <td>+ #{fromMaybe "" description}+|]++layout :: WebSetting -> HtmlUrl Route -> HtmlUrl Route+layout web content = [hamlet|+<html lang="en">+ <head>+ <meta charset="utf-8">+ <link href="@{Css}" rel="stylesheet">+ <title>+ #{title web}+ <body>+ <header>+ <h1>+ <a href="@{Home}">+ #{title web}+ <main>+ ^{content}++ <footer>+ <p>+ Powered by+ <a href="https://lthms.xyz/blog/pi-hoole"><code>pi-hoole</code></a>.+|]++route :: Route -> [(Text, Text)] -> Text+route Home _ = ""+route Css _ = "style.css"++data WebSetting = WebSetting { title :: Text+ , baseUrl :: FilePath+ , example :: FilePath+ }+ deriving (Generic)++instance FromJSON WebSetting++getWebSetting :: IO (Maybe WebSetting)+getWebSetting = getXdgDirectory XdgConfig "pi-hoole/web.yaml" >>= decodeFile
pi-hoole.cabal view
@@ -1,5 +1,5 @@ name: pi-hoole-version: 0.1.0.0+version: 0.2.0.0 synopsis: Lightweight access control solution for the pijul vcs description: Please see the introductory post at <https://lthms.xyz/blog/pi-hoole> category: Security@@ -21,7 +21,7 @@ build-depends: aeson >=1.0 && <1.4 , base >=4.7 && <5.0 , containers >=0.5.9 && <0.6- , directory >=1.2 && <1.4+ , directory >=1.2.3 && <1.4 , filepath >=1.4 && <1.5 , megaparsec >=5.0 && <6.6 , process >=1.0 && <1.7@@ -35,7 +35,7 @@ build-depends: aeson >=1.0 && <1.4 , base >=4.7 && <5 , containers >=0.5.9 && <0.6- , directory >=1.2 && <1.4+ , directory >=1.2.3 && <1.4 , filepath >=1.4 && <1.5 , optparse-generic >=1.0 && <1.4 , pi-hoole@@ -52,7 +52,7 @@ build-depends: aeson >=1.0 && <1.4 , base >=4.7 && <5 , containers >=0.5.9 && <0.6- , directory >=1.2 && <1.4+ , directory >=1.2.3 && <1.4 , filepath >=1.4 && <1.5 , megaparsec >=5.0 && <6.6 , pi-hoole@@ -69,7 +69,7 @@ , base58-bytestring >=0.1 && <0.2 , bytestring >=0.10 && <0.11 , containers >=0.5.9 && <0.6- , directory >=1.2 && <1.4+ , directory >=1.2.3 && <1.4 , filepath >=1.4 && <1.5 , http-types >=0.9 && <0.13 , pi-hoole@@ -78,6 +78,8 @@ , wai >=3.0 && <3.3 , warp >=3.0 && <3.3 , yaml >=0.8 && <0.9+ , shakespeare >=2.0 && <2.1+ , blaze-html >=0.9 && <0.10 default-language: Haskell2010 test-suite pi-hoole-test
src/PiHoole.hs view
@@ -20,6 +20,7 @@ module PiHoole ( Repo(..)+ , fetchDescription , Branch(..) , Role(..) , UserName(..)@@ -31,8 +32,11 @@ , Action(..) , parsePijul , Privilege(..)+ , privilegeToText , privilegeLe+ , privilegeGt , requires+ , hasPrivileges , checkPrivilege , callPijul , recordPijul@@ -46,11 +50,11 @@ 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 qualified Data.Map.Strict as M (empty, foldlWithKey, insert)+import Data.Maybe (fromMaybe, maybe) import Data.Set (Set) import qualified Data.Set as S (empty, foldl, fromList, insert,- isSubsetOf, member, toList)+ isSubsetOf, member, toList, union) import Data.String (IsString (..)) import Data.Text (Text, append, pack, unpack) import qualified Data.Text as T (drop, intercalate, take, uncons,@@ -58,8 +62,8 @@ 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.Directory (doesFileExist, getHomeDirectory)+import System.FilePath (isRelative, (</>)) import System.IO (hGetContents) import System.Process (callProcess, createPipe, runProcess) import Text.Megaparsec (Parsec, eof, many, manyTill, parseMaybe,@@ -158,11 +162,26 @@ | None deriving (Eq, Show) +instance Monoid Scope where+ mempty = None++ mappend All _ = All+ mappend _ All = All+ mappend (Only s1) (Only s2) = Only (S.union s1 s2)+ mappend x None = x+ mappend None y = y+ data Privilege = Privilege { read :: Scope , write :: Scope } deriving (Show) +instance Monoid Privilege where+ mempty = Privilege None None++ mappend (Privilege rd wr) (Privilege rd' wr') = Privilege (rd `mappend` rd')+ (wr `mappend` wr')+ readAllScope :: Parsec Void Text Scope readAllScope = do char '+'@@ -212,6 +231,23 @@ r1 `scopeLe` r2 && w1 `scopeLe` w2 ++privilegeGt :: Privilege -> Privilege -> Bool+privilegeGt x y = not $ privilegeLe x y++scopeToText :: Text -> Scope -> Text+scopeToText letter All = "+" `append` letter+scopeToText letter (Only brs) =+ "+" `append` letter `append` "[" `append` branches `append` "]"+ where+ branches = T.intercalate "," (unBranch <$> S.toList brs)+scopeToText letter None = "-" `append` letter++privilegeToText :: Privilege -> Text+privilegeToText (Privilege None _) = ""+privilegeToText (Privilege rd None) = scopeToText "r" rd+privilegeToText (Privilege rd wr) = scopeToText "r" rd `append` " " `append` scopeToText "w" wr+ textToPrivilege :: Text -> Parser Privilege textToPrivilege txt = case T.words txt of [p] -> case parseMaybe readScope p of@@ -323,6 +359,43 @@ requires (Patch _) = Privilege (Only $ S.fromList []) None requires (Apply branch) = Privilege None (Only $ S.fromList [ branch ]) +hasPrivileges :: Role -> Configuration -> Map Repo Privilege+hasPrivileges (User user) conf = M.foldlWithKey aux M.empty repos+ where+ grps = belongsTo (groups conf) user+ repos = repositories conf++ aux map repo rules = insertPriv repo (computePrivilege user grps rules) map+hasPrivileges role conf = M.foldlWithKey aux M.empty repos+ where+ repos = repositories conf+ aux map repo rules = insertPriv repo (rules !? role `orElse` mempty) map++insertPriv :: Repo -> Privilege -> Map Repo Privilege -> Map Repo Privilege+insertPriv repo priv map = if priv `privilegeGt` mempty+ then M.insert repo priv map+ else map++hasPrivilege :: Role -> Repo -> Configuration -> Privilege+hasPrivilege (User user) repo conf = maybe mempty (gatherPrivilege user) (repos !? repo)+ where+ repos = repositories conf+ grps = groups conf++ gatherPrivilege user = computePrivilege user (belongsTo grps user)+hasPrivilege g@(Group _) repo conf = fromMaybe mempty $ repos !? repo >>= (!? g)+ where+ repos = repositories conf+hasPrivilege Anon repo conf = fromMaybe mempty $ repos !? repo >>= (!? Anon)+ where+ repos = repositories conf++computePrivilege :: UserName -> Set GroupName -> Map Role Privilege -> Privilege+computePrivilege user grps rules = userRight rules user `mappend` groupsRight rules grps+ where+ userRight rules user = rules !? User user `orElse` mempty+ groupsRight rules = foldMap (\g -> rules !? Group g `orElse` mempty)+ checkPrivilege :: UserName -> Pijul -> Configuration -> Bool checkPrivilege user (Pijul repo action) conf = maybe False@@ -372,3 +445,17 @@ actionArgs (Apply (Branch branch)) = [ "--branch" , unpack branch ]++orElse :: Maybe a -> a -> a+orElse = flip fromMaybe++fetchDescription :: Repo -> IO (Maybe String)+fetchDescription (Repo path) = do+ home <- getHomeDirectory+ let descr_file = home </> path </> ".pijul" </> "description"++ exist <- doesFileExist descr_file++ if exist+ then Just <$> readFile descr_file+ else pure Nothing