pi-hoole-0.2.0.0: app/web/Main.hs
-- pi-hoole: lightweight access-control for pijul
-- Copyright (C) 2018 Thomas Letan <contact@thomasletan.fr>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- 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.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 = do
cfg <- getConfiguration
web <- getWebSetting
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 . repositories $ cfg) action
then do res <- recordPijul (fromJust action)
respond $ responseLBS status200 [] (fromString res)
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) =
case cfg !? repo >>= (!? Anon) of
Just priv -> requires action `privilegeLe` priv
_ -> False
requestToPijul :: Request -> Maybe Pijul
requestToPijul req
| isGet req = let path = pathInfo req
in log path <|> patch path
| otherwise = Nothing
where
log :: [Text] -> Maybe Pijul
log = logAux ""
logAux :: FilePath -> [Text] -> Maybe Pijul
logAux path [".pijul", branch] = Pijul (Repo path) <$> (Log <$> parseBranch branch)
logAux path (x:rst) = logAux (path </> unpack x) rst
logAux _ _ = Nothing
parseBranch :: Text -> Maybe Branch
parseBranch branch = case unpack branch =~ changesRegex of
[[_, branch58]] -> Branch . decodeUtf8 <$> decodeBase58 bitcoinAlphabet (fromString branch58)
_ -> Nothing
changesRegex :: String
changesRegex = "changes\\.(.*)$"
patch :: [Text] -> Maybe Pijul
patch = patchAux ""
patchAux :: FilePath -> [Text] -> Maybe Pijul
patchAux path [".pijul", "patches", patch] = Pijul (Repo path) <$> (Patch <$> parsePatch patch)
patchAux path (x:rst) = patchAux (path </> unpack x) rst
patchAux _ _ = Nothing
parsePatch :: Text -> Maybe Text
parsePatch patch = case unpack patch =~ patchRegex of
[[_, patch]] -> Just $ pack patch
_ -> Nothing
patchRegex :: String
patchRegex = "(.*)\\.gz"
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