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 LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

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           ((=~))

main :: IO ()
main = getConfiguration >>= \case
  Just cfg -> run 8080 (piHooleWeb $ repositories cfg)
  Nothing -> putStrLn "Could not open or parse the configuration file"

  where piHooleWeb :: Map Repo (Map Role Privilege) -> Application
        piHooleWeb cfg req respond =
          let action = requestToPijul req in
          if maybe False (pijulToPrivileges cfg) action
          then do res <- recordPijul (fromJust action)
                  respond $ responseLBS status200 [] (fromString res)
          else do print req
                  respond $ responseLBS status404 [] "Sorry"

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