{-# LANGUAGE GeneralizedNewtypeDeriving
           , UndecidableInstances
  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)

module Model.Types
  ( module Model.Types
  , module Numeric.Natural
  , module Mail
  , module Utils.DateTime
  , module Data.UUID.Types
  ) where

import ClassyPrelude
import Utils
import Control.Lens hiding (universe)
import Utils.Lens.TH

import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Fixed
import Data.Monoid (Sum(..))
import Data.Maybe (fromJust)
import Data.Universe
import Data.Universe.Helpers
import Data.Universe.TH
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID

import Data.NonNull.Instances ()

import Data.Default

import Text.Read (readMaybe)

import Database.Persist.TH hiding (derivePersistFieldJSON)
import Model.Types.JSON
import Database.Persist.Class
import Database.Persist.Sql

import Web.HttpApiData
import Web.PathPieces

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lens as Text

import qualified Data.HashMap.Strict as HashMap

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

import Yesod.Core.Dispatch (PathPiece(..))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)

import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Typeable (Typeable)

import Data.Universe.Instances.Reverse ()

import qualified Yesod.Auth.Util.PasswordStore as PWStore

import Mail (MailLanguages(..))
import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))

import Numeric.Natural
import Data.Word.Word24 (Word24)
import Data.Bits
import Data.Ix
import Data.List (genericIndex, elemIndex)
import System.Random (Random(..))
import Data.Data (Data)

import Model.Types.Wordlist
import Data.Text.Metrics (damerauLevenshtein)

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


instance PathPiece UUID where
  fromPathPiece = UUID.fromString . unpack
  toPathPiece = pack . UUID.toString

instance {-# OVERLAPS #-} PathMultiPiece FilePath where
  fromPathMultiPiece = Just . unpack . intercalate "/"
  toPathMultiPiece = Text.splitOn "/" . pack


type Count  = Sum Integer
type Points = Centi

toPoints :: Integral a => a -> Points -- deprecated
toPoints = fromIntegral

pToI :: Points -> Integer -- deprecated
pToI = fromPoints

fromPoints :: Integral a => Points -> a -- deprecated
fromPoints = round

instance DisplayAble Points

instance DisplayAble a => DisplayAble (Sum a) where
  display (Sum x) = display x

data SheetGrading
  = Points     { maxPoints :: Points }
  | PassPoints { maxPoints, passingPoints :: Points }
  | PassBinary -- non-zero means passed
  deriving (Eq, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel
  , sumEncoding = TaggedObject "type" "data"
  } ''SheetGrading
derivePersistFieldJSON ''SheetGrading

makeLenses_ ''SheetGrading

_passingBound :: Fold SheetGrading (Either () Points)
_passingBound = folding passPts
  where
    passPts :: SheetGrading -> Maybe (Either () Points)
    passPts (Points{}) = Nothing
    passPts (PassPoints{passingPoints}) = Just $ Right passingPoints
    passPts (PassBinary) = Just $ Left ()

gradingPassed :: SheetGrading -> Points -> Maybe Bool
gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
    where pBinary _ = pts /= 0
          pPoints b = pts >= b


data SheetGradeSummary = SheetGradeSummary
  { numSheets       :: Count       -- Total number of sheets, includes all
  , numSheetsPasses :: Count       -- Number of sheets required to pass FKA: numGradePasses
  , numSheetsPoints :: Count       -- Number of sheets having points    FKA: sumGradePointsd
  , sumSheetsPoints :: Sum Points  -- Total of all points in all sheets
  -- Marking dependend
  , numMarked       :: Count       -- Number of already marked sheets
  , numMarkedPasses :: Count       -- Number of already marked sheets with passes
  , numMarkedPoints :: Count       -- Number of already marked sheets with points
  , sumMarkedPoints :: Sum Points  -- Achieveable points within marked sheets
  --
  , achievedPasses :: Count        -- Achieved passes (within marked sheets)
  , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
  } deriving (Generic, Read, Show, Eq)

instance Monoid SheetGradeSummary where
  mempty  = memptydefault
  mappend = mappenddefault

instance Semigroup SheetGradeSummary where
  (<>) = mappend -- TODO: remove for GHC > 8.4.x

makeLenses_ ''SheetGradeSummary

sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
sheetGradeSum gr Nothing  = mempty
  { numSheets = 1
  , numSheetsPasses = bool  mempty   1 $ has _passingBound gr
  , numSheetsPoints = bool  mempty   1 $ has _maxPoints    gr
  , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
  }
sheetGradeSum gr (Just p) =
  let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
  in  unmarked
        { numMarked       = numSheets
        , numMarkedPasses = numSheetsPasses
        , numMarkedPoints = numSheetsPoints
        , sumMarkedPoints = sumSheetsPoints
        , achievedPasses  = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p
        , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
        }


data SheetType
  = NotGraded
  | Normal        { grading :: SheetGrading }
  | Bonus         { grading :: SheetGrading }
  | Informational { grading :: SheetGrading }
  deriving (Eq, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , fieldLabelModifier = camelToPathPiece
  , sumEncoding = TaggedObject "type" "data"
  } ''SheetType
derivePersistFieldJSON ''SheetType

data SheetTypeSummary = SheetTypeSummary
  { normalSummary
  , bonusSummary
  , informationalSummary :: SheetGradeSummary
  , numNotGraded :: Count
  } deriving (Generic, Read, Show, Eq)

instance Monoid SheetTypeSummary where
  mempty  = memptydefault
  mappend = mappenddefault

instance Semigroup SheetTypeSummary where
  (<>) = mappend -- TODO: remove for GHC > 8.4.x

makeLenses_ ''SheetTypeSummary

sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }

data SheetGroup
  = Arbitrary { maxParticipants :: Natural }
  | RegisteredGroups
  | NoGroups
  deriving (Show, Read, Eq, Generic)
deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON ''SheetGroup

makeLenses_ ''SheetGroup

data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
derivePersistField "SheetFileType"

instance Universe SheetFileType where universe = universeDef
instance Finite SheetFileType

instance PathPiece SheetFileType where
  toPathPiece SheetExercise = "file"
  toPathPiece SheetHint     = "hint"
  toPathPiece SheetSolution = "solution"
  toPathPiece SheetMarking  = "marking"
  fromPathPiece = finiteFromPathPiece

-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
  display SheetExercise = "Aufgabenstellung"
  display SheetHint     = "Hinweise"
  display SheetSolution = "Musterlösung"
  display SheetMarking  = "Korrekturhinweise"

-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
-- partitionFileType' = groupMap

partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs

data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)

instance Universe SubmissionFileType where universe = universeDef
instance Finite SubmissionFileType

submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
submissionFileTypeIsUpdate SubmissionOriginal  = False
submissionFileTypeIsUpdate SubmissionCorrected = True

isUpdateSubmissionFileType :: Bool -> SubmissionFileType
isUpdateSubmissionFileType False = SubmissionOriginal
isUpdateSubmissionFileType True  = SubmissionCorrected

instance PathPiece SubmissionFileType where
  toPathPiece SubmissionOriginal  = "original"
  toPathPiece SubmissionCorrected = "corrected"
  fromPathPiece = finiteFromPathPiece

instance DisplayAble SubmissionFileType where
  display SubmissionOriginal  = "Abgabe"
  display SubmissionCorrected = "Korrektur"

{-
data DA = forall a . (DisplayAble a) => DA a

instance DisplayAble DA where
  display (DA x) = display x
-}


data UploadMode = NoUpload | Upload { unpackZips :: Bool }
  deriving (Show, Read, Eq, Ord, Generic)

deriveFinite ''UploadMode

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , fieldLabelModifier = camelToPathPiece
  , sumEncoding = TaggedObject "mode" "settings"
  }''UploadMode
derivePersistFieldJSON ''UploadMode

instance PathPiece UploadMode where
  toPathPiece = \case
    NoUpload     -> "no-upload"
    Upload True  -> "unpack"
    Upload False -> "no-unpack"
  fromPathPiece = finiteFromPathPiece

data SubmissionMode = SubmissionMode
  { submissionModeCorrector :: Bool
  , submissionModeUser :: Maybe UploadMode
  }
  deriving (Show, Read, Eq, Ord, Generic)

deriveFinite ''SubmissionMode

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode

finitePathPiece ''SubmissionMode
  [ "no-submissions"
  , "no-upload"
  , "no-unpack"
  , "unpack"
  , "correctors"
  , "correctors+no-upload"
  , "correctors+no-unpack"
  , "correctors+unpack"
  ]

data SubmissionModeDescr = SubmissionModeNone
                         | SubmissionModeCorrector
                         | SubmissionModeUser
                         | SubmissionModeBoth
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr

finitePathPiece ''SubmissionModeDescr
  [ "no-submissions"
  , "correctors"
  , "users"
  , "correctors+users"
  ]

classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth


data ExamStatus = Attended | NoShow | Voided
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
derivePersistField "ExamStatus"

-- | Specify a corrector's workload
data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
    = Load { byTutorial :: Maybe Bool  -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
           }
  deriving (Show, Read, Eq, Ord, Generic)

deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load

instance Hashable Load

instance Semigroup Load where
  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
    where
      byTut''
        | Nothing <- byTut  = byTut'
        | Nothing <- byTut' = byTut
        | Just a <- byTut
        , Just b <- byTut'  = Just $ a || b

instance Monoid Load where
  mempty = Load Nothing 0
  mappend = (<>)

{- Use (is _ByTutorial) instead of this unneeded definition:
  isByTutorial :: Load -> Bool
  isByTutorial (ByTutorial {}) = True
  isByTutorial _               = False
-}

data Season = Summer | Winter
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)

instance Binary Season

seasonToChar :: Season -> Char
seasonToChar Summer = 'S'
seasonToChar Winter = 'W'

seasonFromChar :: Char -> Either Text Season
seasonFromChar c
  | c ~= 'S'  = Right Summer
  | c ~= 'W'  = Right Winter
  | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
  where
    (~=) = (==) `on` CI.mk

instance DisplayAble Season

data TermIdentifier = TermIdentifier
  { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
  , season :: Season
  } deriving (Show, Read, Eq, Ord, Generic, Typeable)

instance Binary TermIdentifier

instance Enum TermIdentifier where
  -- ^ Do not use for conversion – Enumeration only
  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
  fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season

-- Conversion TermId <-> TermIdentifier::
-- from_TermId_to_TermIdentifier = unTermKey
-- from_TermIdentifier_to_TermId = TermKey

shortened :: Iso' Integer Integer
shortened = iso shorten expand
  where
    century = ($currentYear `div` 100) * 100
    expand year
      | 0 <= year
      , year < 100 = let
          options = [ expanded | offset <- [-1, 0, 1]
                               , let century' = century + offset * 100
                                     expanded = century' + year
                               , $currentYear - 50 <= expanded
                               , expanded < $currentYear + 50
                               ]
          in case options of
               [unique] -> unique
               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
      | otherwise = year
    shorten year
      | $currentYear - 50 <= year
      , year < $currentYear + 50 = year `mod` 100
      | otherwise = year

termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)

-- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier
termFromText t
  | (s:ys) <- Text.unpack t
  , Just (review shortened -> year) <- readMaybe ys
  , Right season <- seasonFromChar s
  = Right TermIdentifier{..}
  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number

termToRational :: TermIdentifier -> Rational
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
  where
    seasonOffset
      | Summer <- season = 0
      | Winter <- season = 0.5

termFromRational :: Rational -> TermIdentifier
termFromRational n = TermIdentifier{..}
  where
    year = floor n
    remainder = n - (fromInteger $ floor n)
    season
      | remainder == 0 = Summer
      | otherwise      = Winter

instance PersistField TermIdentifier where
  toPersistValue = PersistRational . termToRational
  fromPersistValue (PersistRational t) = Right $ termFromRational t
  fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x

instance PersistFieldSql TermIdentifier where
  sqlType _ = SqlNumeric 5 1

instance ToHttpApiData TermIdentifier where
  toUrlPiece = termToText

instance FromHttpApiData TermIdentifier where
  parseUrlPiece = termFromText

instance PathPiece TermIdentifier where
  fromPathPiece = either (const Nothing) Just . termFromText
  toPathPiece = termToText

instance ToJSON TermIdentifier where
  toJSON = Aeson.String . termToText

instance FromJSON TermIdentifier where
  parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText

{- Must be defined in a later module:
    termField :: Field (HandlerT UniWorX IO) TermIdentifier
    termField = checkMMap (return . termFromText) termToText textField
   See Handler.Utils.Form.termsField and termActiveField
-}


withinTerm :: Day -> TermIdentifier -> Bool
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
  where
    timeYear = fst3 $ toGregorian time
    termYear = year term


data StudyFieldType = FieldPrimary | FieldSecondary
  deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
derivePersistField "StudyFieldType"

instance PersistField UUID where
  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x

instance PersistFieldSql UUID where
  sqlType _ = SqlOther "uuid"

instance DisplayAble StudyFieldType

data Theme
  = ThemeDefault
  | ThemeLavender
  | ThemeNeutralBlue
  | ThemeAberdeenReds
  | ThemeMossGreen
  | ThemeSkyLove
  deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Theme"
  } ''Theme

instance Universe Theme where universe = universeDef
instance Finite Theme

nullaryPathPiece ''Theme (camelToPathPiece' 1)

$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user

derivePersistField "Theme"


newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
  deriving (Show, Read, Eq)

instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
    fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
    toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName


data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Corrector"
  } ''CorrectorState

instance Universe CorrectorState
instance Finite CorrectorState

instance Hashable CorrectorState

nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)

derivePersistField "CorrectorState"


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


derivePersistFieldJSON ''Value


-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
--
-- Could maybe be replaced with `Structure Notification` in the long term
data NotificationTrigger = NTSubmissionRatedGraded
                         | NTSubmissionRated
                         | NTSheetActive
                         | NTSheetSoonInactive
                         | NTSheetInactive
                         | NTCorrectionsAssigned
                         | NTCorrectionsNotDistributed
                         | NTUserRightsUpdate
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)

instance Universe NotificationTrigger
instance Finite NotificationTrigger

instance Hashable NotificationTrigger

deriveJSON defaultOptions
  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  } ''NotificationTrigger

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

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


newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
  deriving (Generic, Typeable)
  deriving newtype (Eq, Ord, Read, Show)

instance Default NotificationSettings where
  def = NotificationSettings $ \case
    NTSubmissionRatedGraded -> True
    NTSubmissionRated -> False
    NTSheetActive -> True
    NTSheetSoonInactive -> False
    NTSheetInactive -> True
    NTCorrectionsAssigned -> True
    NTCorrectionsNotDistributed -> True
    NTUserRightsUpdate -> True

instance ToJSON NotificationSettings where
  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

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

derivePersistFieldJSON ''NotificationSettings


instance ToBackendKey SqlBackend record => Hashable (Key record) where
  hashWithSalt s key = s `hashWithSalt` fromSqlKey key

derivePersistFieldJSON ''MailLanguages


type PseudonymWord   = CI Text

newtype Pseudonym = Pseudonym Word24
  deriving (Eq, Ord, Read, Show, Generic, Data)
  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)


instance PersistField Pseudonym where
  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
  fromPersistValue v = do
    w <- fromPersistValue v :: Either Text Word32
    if
      | 0 <= w
      , w <= fromIntegral (maxBound :: Pseudonym)
        -> return $ fromIntegral w
      | otherwise
        -> Left "Pseudonym out of range"

instance PersistFieldSql Pseudonym where
  sqlType _ = SqlInt32

instance Random Pseudonym where
  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
  random = randomR (minBound, maxBound)

instance FromJSON Pseudonym where
  parseJSON v@(Aeson.Number _) = do
    w <- parseJSON v :: Aeson.Parser Word32
    if
      | 0 <= w
      , w <= fromIntegral (maxBound :: Pseudonym)
        -> return $ fromIntegral w
      | otherwise
        -> fail "Pseudonym out auf range"
  parseJSON (Aeson.String t)
    = case t ^? _PseudonymText of
        Just p -> return p
        Nothing -> fail "Could not parse pseudonym"
  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
    ws' <- toList . map CI.mk <$> mapM parseJSON ws
    case ws' ^? _PseudonymWords of
      Just p -> return p
      Nothing -> fail "Could not parse pseudonym words"

instance ToJSON Pseudonym where
  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])

pseudonymWordlist :: [PseudonymWord]
pseudonymCharacters :: Set (CI Char)
(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")

_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
_PseudonymWords = prism' pToWords pFromWords
  where
    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
    pFromWords [w1, w2]
      | Just i1 <- elemIndex w1 pseudonymWordlist
      , Just i2 <- elemIndex w2 pseudonymWordlist
      , i1 <= maxWord, i2 <= maxWord
      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
    pFromWords _ = Nothing

    pToWords :: Pseudonym -> [PseudonymWord]
    pToWords (Pseudonym p)
      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
        , genericIndex pseudonymWordlist $ p .&. maxWord
        ]

    maxWord :: Num a => a
    maxWord = 0b111111111111

_PseudonymText :: Prism' Text Pseudonym
_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
  where
    tFromWords :: Text -> Maybe [PseudonymWord]
    tFromWords input
      | [result] <- input ^.. pseudonymFragments
      = Just result
      | otherwise
      = Nothing

    tToWords :: [PseudonymWord] -> Text
    tToWords = Text.unwords . map CI.original

pseudonymWords :: Fold Text PseudonymWord
pseudonymWords = folding
  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
  where
    distance = damerauLevenshtein `on` CI.foldedCase
    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
    distanceCutoff = 2

pseudonymFragments :: Fold Text [PseudonymWord]
pseudonymFragments = folding
  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)


data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
  = AuthAdmin
  | AuthToken
  | AuthLecturer
  | AuthCorrector
  | AuthRegistered
  | AuthParticipant
  | AuthTime
  | AuthMaterials
  | AuthOwner
  | AuthRated
  | AuthUserSubmissions
  | AuthCorrectorSubmissions
  | AuthCapacity
  | AuthEmpty
  | AuthSelf
  | AuthAuthentication
  | AuthNoEscalation
  | AuthRead
  | AuthWrite
  | 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 = 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 = ObjectWithSingleField
  , unwrapUnaryRecords = True
  } ''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


data LecturerType = CourseLecturer | CourseAssistant
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)

instance Universe LecturerType
instance Finite LecturerType

nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
deriveJSON  defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''LecturerType
derivePersistFieldJSON ''LecturerType

instance Hashable LecturerType


-- Type synonyms

type Email           = Text

type SchoolName      = CI Text
type SchoolShorthand = CI Text
type CourseName      = CI Text
type CourseShorthand = CI Text
type SheetName       = CI Text
type MaterialName    = CI Text
type UserEmail       = CI Email

type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId      = UUID
type TokenId         = UUID
type TermCandidateIncidence = UUID
