{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}

module Spm.Api
  ( SpmStyle(..), _SpmWords, _SpmConsonants
  , SpmMailbox, SpmDomain
  , SpmLocal(..), SpmExtension(..)
  , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
  , _SpmMappingStateReject
  , SpmApi, spmApi
  ) where

import Prelude

import Servant.API

import Data.Proxy (Proxy(..))

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

import GHC.Generics (Generic)
import Type.Reflection (Typeable)

import Control.Lens

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

import Crypto.JOSE.JWK (JWKSet)
import Crypto.JWT (SignedJWT)
import Crypto.JWT.Instances ()

import Data.UUID (UUID)
import Data.UUID.Instances ()

import qualified Data.Aeson as JSON
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Casing

import Data.Aeson (ToJSON, FromJSON)

import Control.Monad
import Control.Applicative


data SpmStyle = SpmWords | SpmConsonants
  deriving (Eq, Ord, Read, Show, Bounded, Enum)
makePrisms ''SpmStyle

instance ToHttpApiData SpmStyle where
  toUrlPiece = \case
    SpmWords -> "words"
    SpmConsonants -> "consonants"
instance FromHttpApiData SpmStyle where
  parseUrlPiece t@(CI.mk -> t')
    | t' == "words" = Right SpmWords
    | t' == "consonants" = Right SpmConsonants
    | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’"


newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (MimeRender PlainText)
makeWrapped ''SpmMailbox

instance MimeRender JSON SpmMailbox where
  mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ]

newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text }
  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (MimeRender PlainText)
makeWrapped ''SpmDomain

instance MimeRender JSON SpmDomain where
  mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ]

newtype SpmLocal = SpmLocal
  { unSpmLocal :: CI Text
  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
    deriving newtype (ToJSON, FromJSON)
makeWrapped ''SpmLocal
newtype SpmExtension = SpmExtension
  { unSpmExtension :: CI Text
  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
    deriving newtype (ToJSON, FromJSON)
makeWrapped ''SpmExtension

data SpmMappingState = Valid | Reject
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance MimeRender PlainText SpmMappingState where
  mimeRender p = mimeRender @_ @Text p . \case
    Valid -> "valid"
    Reject -> "reject"
instance MimeUnrender PlainText SpmMappingState where
  mimeUnrender p bs = mimeUnrender @_ @Text p bs >>= \(CI.mk . Text.strip -> t) -> if
    | t == "valid" -> Right Valid
    | t == "reject" -> Right Reject
    | otherwise -> Left "Could not parse SpmMappingState"
_SpmMappingStateReject :: Iso' SpmMappingState Bool
_SpmMappingStateReject = iso toReject fromReject
  where toReject Valid  = False
        toReject Reject = True
        fromReject True  = Reject
        fromReject False = Valid

data SpmMappingListingItem = SpmMappingListingItem
  { smlMapping :: SpmMapping
  , smlState :: SpmMappingState
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: [SpmMappingListingItem] }
  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)

data SpmMapping = SpmMapping
  { spmMappingLocal :: Maybe SpmLocal
  , spmMappingExtension :: Maybe SpmExtension
  } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
instance FromHttpApiData SpmMapping where
  parseUrlPiece t
    | [ fmap (SpmLocal . CI.mk) . assertNonEmpty -> spmMappingLocal
      , fmap (SpmExtension . CI.mk) . assertNonEmpty -> spmMappingExtension
      ] <- Text.splitOn "+" t
    , Just () <- void spmMappingLocal <|> void spmMappingExtension
    = Right SpmMapping{..}
    | otherwise = Left "Could not parse SpmMapping"
    where assertNonEmpty :: Text -> Maybe Text
          assertNonEmpty t' | Text.null t' = Nothing
                            | otherwise = Just t'
instance ToHttpApiData SpmMapping where
  toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
                           <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension

deriveJSON (aesonPrefix trainCase) ''SpmMapping
makePrisms ''SpmMappingState
deriveJSON JSON.defaultOptions
  { JSON.constructorTagModifier = trainCase
  } ''SpmMappingState
deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem

instance ToJSON SpmMappingListing where
  toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]


type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
         :<|> "domain" :> Get '[PlainText, JSON] SpmDomain
         :<|> "jwks.json" :> Get '[JSON] JWKSet
         :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
         :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT
         :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent
         :<|> "mappings" :> Get '[JSON] SpmMappingListing
         :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
         :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent

spmApi :: Proxy SpmApi
spmApi = Proxy