{-# 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
             , ''AllocationId
             , ''CourseApplicationId
             , ''CourseId
             , ''CourseNewsId
             , ''CourseEventId
             , ''TutorialId
             , ''ExternalExamId
             , ''WorkflowInstanceId
             , ''WorkflowWorkflowId
             , ''MaterialFileId
             , ''AllocationMatchingId
             ]

type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"
type CryptoUUIDWorkflowStateIndex = CryptoUUID WorkflowStateIndex

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) WorkflowWorkflowId ~ "WorkflowWorkflow"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
  fromPathPiece (Text.unpack -> piece) = do
    piece' <- (stripPrefix `on` map CI.mk) "uww" piece
    return . CryptoID . CI.mk $ map CI.original piece'
  toPathPiece = Text.pack . ("uww" <>) . CI.foldedCase . ciphertext

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