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

module CryptoID
  ( module CryptoID
  , 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 qualified Data.Text as Text

import qualified Data.CaseInsensitive as CI

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

import Text.Blaze (ToMarkup(..))

import qualified Data.CryptoID.Class.ImplicitNamespace as I


encrypt :: forall plaintext ciphertext m.
           ( I.HasCryptoID ciphertext plaintext m
           , KnownSymbol (CryptoIDNamespace ciphertext plaintext)
           , MonadHandler m
           , Typeable ciphertext
           , PathPiece plaintext
           )
        => plaintext -> m (I.CryptoID ciphertext plaintext)
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain

decrypt :: forall plaintext ciphertext m.
           ( I.HasCryptoID ciphertext plaintext m
           , MonadHandler m
           , Typeable plaintext
           , PathPiece ciphertext
           )
        => I.CryptoID ciphertext plaintext -> m plaintext
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher


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
             ]

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