-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module CryptoID
  ( module CryptoID
  , module CryptoID.Cached
  , module Data.CryptoID.Poly.ImplicitNamespace
  , module Data.UUID.Cryptographic.ImplicitNamespace
  , module System.FilePath.Cryptographic.ImplicitNamespace
  ) where


import Import.NoModel
import Model

import CryptoID.TH

import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt)
import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import CryptoID.Cached

import qualified Data.Text as Text

import qualified Data.CaseInsensitive as CI

import Data.Aeson (withText)
import Data.Aeson.Encoding (text)

import Text.Blaze (ToMarkup(..))


instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
  type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
  cryptoIDKey f = ask >>= f


-- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId
             , ''UserId
             , ''SheetId
             , ''SystemMessageId
             , ''SystemMessageTranslationId
             , ''StudyFeaturesId
             , ''ExamId
             , ''ExamOccurrenceId
             , ''ExamPartId
             , ''CourseId
             , ''CourseNewsId
             , ''CourseEventId
             , ''TutorialId
             , ''ExternalApiId
             , ''ExternalExamId
             , ''MaterialFileId
             , ''PrintJobId
             , ''QualificationId
             ]

decCryptoIDKeySize

-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "Submission" (CI FilePath)) where
  fromPathPiece (Text.unpack -> piece) = do
    piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
    return . CryptoID . CI.mk $ map CI.original piece'
  toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext

instance {-# OVERLAPS #-} ToJSON (E.CryptoID "Submission" (CI FilePath)) where
  toJSON = String . toPathPiece
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "Submission" (CI FilePath)) where
  toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "Submission" (CI FilePath)) where
  parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
  toMarkup = toMarkup . toPathPiece


-- CryptoIDNamespace (CI FilePath) UserId ~ "User"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where
  fromPathPiece (Text.unpack -> piece) = do
    piece' <- (stripPrefix `on` map CI.mk) "uwb" piece
    return . CryptoID . CI.mk $ map CI.original piece'
  toPathPiece = Text.pack . ("uwb" <>) . CI.foldedCase . ciphertext

instance {-# OVERLAPS #-} ToJSON (E.CryptoID "User" (CI FilePath)) where
  toJSON = String . toPathPiece
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "User" (CI FilePath)) where
  toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "User" (CI FilePath)) where
  parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where
  toMarkup = toMarkup . toPathPiece


-- CryptoIDNamespace (CI FilePath) PrinJobId ~ "PrintJob"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "PrintJob" (CI FilePath)) where
  fromPathPiece (Text.unpack -> piece) = do
    piece' <- (stripPrefix `on` map CI.mk) "uwl" piece
    return . CryptoID . CI.mk $ map CI.original piece'
  toPathPiece = Text.pack . ("uwl" <>) . CI.foldedCase . ciphertext
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "PrintJob" (CI FilePath)) where
  toJSON = String . toPathPiece
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where
  toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "PrintJob" (CI FilePath)) where
  parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoPrintJob") return . fromPathPiece
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoPrintJob") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "PrintJob" (CI FilePath)) where
  toMarkup = toMarkup . toPathPiece