{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-|
Module: Model.Types.Security
Description: Types for authentication and authorisation
-}

module Model.Types.Security
  ( module Model.Types.Security
  ) where

import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, Proxy(..))

import Utils

import Data.Aeson
import Data.Aeson.TH
import Model.Types.TH.JSON
import Data.Universe
import Data.Universe.Instances.Reverse ()
import Data.Proxy
import Data.Data (Data)

import Control.Lens

import qualified Data.Set as Set

import qualified Data.Text as Text

import qualified Data.HashMap.Strict as HashMap

import qualified Data.Aeson.Types as Aeson

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()

import Data.Set.Instances ()
import Data.NonNull.Instances ()
import Data.Universe.Instances.Reverse.MonoTraversable ()

import Model.Types.TH.PathPiece
import Database.Persist.Sql

import Servant.Docs (ToSample(..), samples)
import Utils.Lens.TH

import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.Binary.Instances.UnorderedContainers ()


data AuthenticationMode = AuthLDAP
                        | AuthPWHash { authPWHash :: Text }
  deriving (Eq, Ord, Read, Show, Generic)

instance Hashable AuthenticationMode
instance NFData AuthenticationMode

deriveJSON defaultOptions
  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  , sumEncoding = UntaggedValue
  } ''AuthenticationMode

derivePersistFieldJSON ''AuthenticationMode


data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
  = AuthAdmin
  | AuthLecturer
  | AuthCorrector
  | AuthExamCorrector
  | AuthTutor
  | AuthTutorControl
  | AuthExamOffice
  | AuthSystemExamOffice
  | AuthEvaluation
  | AuthAllocationAdmin  
  | AuthAllocationRegistered
  | AuthCourseRegistered
  | AuthTutorialRegistered
  | AuthExamRegistered
  | AuthExamOccurrenceRegistered
  | AuthExamOccurrenceRegistration
  | AuthExamResult
  | AuthParticipant
  | AuthApplicant
  | AuthStudent
  | AuthTime
  | AuthStaffTime
  | AuthAllocationTime
  | AuthCourseTime
  | AuthExamTime
  | AuthMaterials
  | AuthOwner
  | AuthPersonalisedSheetFiles
  | AuthRated
  | AuthUserSubmissions
  | AuthCorrectorSubmissions
  | AuthCorrectionAnonymous
  | AuthSubmissionGroup
  | AuthCapacity
  | AuthRegisterGroup
  | AuthEmpty
  | AuthSelf
  | AuthIsLDAP
  | AuthIsPWHash
  | AuthAuthentication
  | AuthNoEscalation
  | AuthRead
  | AuthWrite
  | AuthToken
  | AuthDeprecated
  | AuthDevelopment
  | AuthFree
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
  deriving anyclass (Universe, Finite, Hashable, NFData)

nullaryPathPiece ''AuthTag $ camelToPathPiece' 1
pathPieceJSON ''AuthTag
pathPieceJSONKey ''AuthTag
pathPieceBinary ''AuthTag


newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
  deriving (Read, Show, Generic)
  deriving newtype (Eq, Ord)

instance Default AuthTagActive where
  def = AuthTagActive $ \case
    AuthAdmin -> False
    _ -> True

instance ToJSON AuthTagActive where
  toJSON v = toJSON . HashMap.fromList $ map (toPathPiece &&& authTagIsActive v) universeF

instance FromJSON AuthTagActive where
  parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap Text Bool)
    fmap toAuthTagActive . flip ifoldMapM o' $ \k v -> maybeT mempty $ do
      k' <- hoistMaybe $ fromPathPiece k
      return $ HashMap.singleton k' v
    where toAuthTagActive o = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n o

instance Hashable AuthTagActive where
  hashWithSalt s = foldl' hashWithSalt s . authTagIsActive

instance Binary AuthTagActive where
  put v = Binary.put . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
  get = Binary.get <&> \hm -> AuthTagActive (\n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm)

derivePersistFieldJSON ''AuthTagActive

getSessionActiveAuthTags :: MonadHandler m => m AuthTagActive
getSessionActiveAuthTags = fromMaybe def <$> lookupSessionJson SessionActiveAuthTags

newtype ReducedActiveAuthTags = ReducedActiveAuthTags (HashMap AuthTag Bool)
  deriving newtype (Monoid, Semigroup)

instance ToJSON ReducedActiveAuthTags where
  toJSON (ReducedActiveAuthTags a) = toJSON $ HashMap.fromList [ (toPathPiece k, v) | (k, v) <- HashMap.toList a ]
  
instance FromJSON ReducedActiveAuthTags where
  parseJSON = Aeson.withObject "ReducedActiveAuthTags" $ \o -> do
    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap Text Bool)
    fmap ReducedActiveAuthTags . flip ifoldMap o' $ \k v -> maybeT mempty $ do
      k' <- hoistMaybe $ fromPathPiece k
      return $ HashMap.singleton k' v

_ReducedActiveAuthTags :: Iso' AuthTagActive ReducedActiveAuthTags
_ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags
  where
    toReducedActiveAuthTags a = ReducedActiveAuthTags . flip foldMap universeF $ \n -> if
      | authTagIsActive a n /= authTagIsActive def n -> HashMap.singleton n $ authTagIsActive a n
      | otherwise -> mempty
    fromReducedActiveAuthTags (ReducedActiveAuthTags hm) = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm


data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
  deriving anyclass (Hashable, Binary, NFData)

makeLenses_ ''PredLiteral
makePrisms ''PredLiteral

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "tag" "variable"
  } ''PredLiteral

instance PathPiece a => PathPiece (PredLiteral a) where
  toPathPiece PLVariable{..} = toPathPiece plVar
  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar

  fromPathPiece t = PLVariable <$> fromPathPiece t
                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)


newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
  deriving anyclass (Binary, Hashable, NFData)

makeLenses_ ''PredDNF

parsePredDNF :: forall a. (Ord a, PathPiece a) => PredDNF a -> [Text] -> Either Text (PredDNF a)
parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms start)
  where
    partition' :: Set (Set (PredLiteral a)) -> Text -> Either Text (Set (Set (PredLiteral a)))
    partition' prev t
      | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
        = if
           | oany (authTags `Set.isSubsetOf`) prev
             -> Right prev
           | otherwise
             -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev
      | otherwise
        = Left t


$(return [])

instance ToJSON a => ToJSON (PredDNF a) where
  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)

instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
  toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms
  fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words

type AuthLiteral = PredLiteral AuthTag

type AuthDNF = PredDNF AuthTag

defaultAuthDNF :: AuthDNF
defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken


dnfAssumeValue :: forall a. Ord a => a -> Bool -> PredDNF a -> Maybe (PredDNF a)
-- ^ `Nothing` corresponds to @⊤@
dnfAssumeValue var val
  = fmap (PredDNF . Set.fromList) . sequence
  . foldMapOf (_dnfTerms . folded) (pure @[] . fromNullable . Set.filter (not . agrees) . toNullable)
  . over _dnfTerms (Set.filter $ none disagrees . toNullable)
  where
    agrees, disagrees :: PredLiteral a -> Bool
    agrees    PLVariable{..} = plVar == var && val
    agrees    PLNegated{..}  = plVar == var && not val
    disagrees PLNegated{..}  = plVar == var && val
    disagrees PLVariable{..} = plVar == var && not val

predDNFFalse :: PredDNF a
predDNFFalse = PredDNF Set.empty

predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a
predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton

predDNFVar, predDNFNeg :: Ord a => a -> PredDNF a
predDNFVar = predDNFSingleton . PLVariable
predDNFNeg = predDNFSingleton . PLNegated

infixr 3 `predDNFAnd`
infixr 2 `predDNFOr`

predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a
predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do
  aConj <- Set.toList a
  bConj <- Set.toList b
  return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj
predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b

predDNFEntail :: forall a. Ord a => PredDNF a -> PredDNF a
-- ^ Conversion to “DNF up to entailment”:
--
-- > (A_1 && A_2 && ...) OR B OR ... -> (A_1 && A_2 && ...) OR' B OR' ...
--
-- > A OR' B := ((A |- B) ==> A) && (A || B)
predDNFEntail = over _dnfTerms $ ofoldl' entail Set.empty
  where entail :: Set (NonNull (Set (PredLiteral a))) -> NonNull (Set (PredLiteral a)) -> Set (NonNull (Set (PredLiteral a)))
        entail prev t
          | oany (t `isSubsetOf`) prev = prev
          | otherwise = Set.insert t $ Set.filter (not . (`isSubsetOf` t)) prev
          where isSubsetOf = Set.isSubsetOf `on` toNullable
        


data UserGroupName
  = UserGroupMetrics
  | UserGroupExternalApis
  | UserGroupCrontab
  | UserGroupCustom { userGroupCustomName :: CI Text }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Hashable, NFData)

instance PathPiece UserGroupName where
  toPathPiece UserGroupMetrics = "metrics"
  toPathPiece UserGroupExternalApis = "external-apis"
  toPathPiece UserGroupCrontab = "crontab"
  toPathPiece (UserGroupCustom t) = CI.original t
  fromPathPiece t = Just $ if
    | "external-apis" `ciEq` t -> UserGroupExternalApis
    | "metrics" `ciEq` t       -> UserGroupMetrics
    | "crontab" `ciEq` t       -> UserGroupCrontab
    | otherwise                -> UserGroupCustom $ CI.mk t
    where
      ciEq :: Text -> Text -> Bool
      ciEq = (==) `on` CI.mk

pathPieceJSON ''UserGroupName
derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
makeLenses_ ''UserGroupName

instance ToSample UserGroupName where
  toSamples _ = builtins ++ samples custom
    where builtins = ("Built in group", ) <$>
            [ UserGroupMetrics
            , UserGroupExternalApis
            ]
          custom = UserGroupCustom . CI.mk . ("Group " <>) . tshow <$> [1..]
