--  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(..)
  , fetchDescription
  , Branch(..)
  , Role(..)
  , UserName(..)
  , parseUserName
  , GroupName(..)
  , parseGroupName
  , Configuration(..)
  , Pijul(..)
  , Action(..)
  , parsePijul
  , Privilege(..)
  , privilegeToText
  , privilegeLe
  , privilegeGt
  , requires
  , hasPrivileges
  , 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 (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, union)
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     (doesFileExist, 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)

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


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

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
        (\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
                                         ]

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