{-# 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 CryptoID.TH

import ClassyPrelude
import Model

import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace
import System.FilePath.Cryptographic.ImplicitNamespace

import qualified Data.Text as Text

-- import Data.UUID.Types
import Web.PathPieces

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

import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
import Data.Aeson.Encoding (text)


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
             , ''FileId
             , ''UserId
             , ''SheetId
             , ''SystemMessageId
             , ''SystemMessageTranslationId
             , ''StudyFeaturesId
             ]

instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (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 #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where
  toJSON = String . toPathPiece
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where
  toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where
  parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece