{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

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

import Import.NoModel

import Data.Set (Set)

import qualified Data.Text as Text

import qualified Data.HashMap.Strict as HashMap

import qualified Data.Aeson.Types as Aeson

import qualified Data.Binary as Binary


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

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
  | AuthTutor
  | AuthCourseRegistered
  | AuthTutorialRegistered
  | AuthExamRegistered
  | AuthParticipant
  | AuthTime
  | AuthMaterials
  | AuthOwner
  | AuthRated
  | AuthUserSubmissions
  | AuthCorrectorSubmissions
  | AuthCapacity
  | AuthRegisterGroup
  | AuthEmpty
  | AuthSelf
  | AuthAuthentication
  | AuthNoEscalation
  | AuthRead
  | AuthWrite
  | AuthToken
  | AuthDeprecated
  | AuthDevelopment
  | AuthFree
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe AuthTag
instance Finite AuthTag
instance Hashable AuthTag

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''AuthTag

nullaryPathPiece ''AuthTag (camelToPathPiece' 1)

instance ToJSONKey AuthTag where
  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t

instance FromJSONKey AuthTag where
  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String

instance Binary 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 (id &&& authTagIsActive v) universeF

instance FromJSON AuthTagActive where
  parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
    return . AuthTagActive $ \n -> case HashMap.lookup n o' of
      Nothing -> authTagIsActive def n
      Just b  -> b

derivePersistFieldJSON ''AuthTagActive


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

instance Hashable a => Hashable (PredLiteral a)
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "val" "var"
  } ''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)

instance Binary a => Binary (PredLiteral a)


newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (Semigroup, Monoid)

$(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, Binary a) => Binary (PredDNF a) where
  get = PredDNF <$> Binary.get
  put = Binary.put . dnfTerms

type AuthLiteral = PredLiteral AuthTag

type AuthDNF = PredDNF AuthTag
