--  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 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

-- TODO: There is an issue here. The command `pijul patch` does not have an
-- argument to specify the branch from which a patch is initially fetched; as a
-- consequence, having read access to a repo, even for another branch where the
-- patch is not applied, is enough.  For this reason, if a user who obtains a
-- hash for a patch of a branch they cannot access can fetch the patch. That is,
-- a patch is as private as its hash. Private branches will eventually be
-- supported in a better manner, but for now, private branches should mean
-- separated repositories.
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
                                         ]