{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}

module Spm.Api
  ( SpmStyle(..), _SpmWords, _SpmConsonants
  , SpmMailbox, SpmDomain
  , SpmLocal(..), SpmExtension(..)
  , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
  , _SpmMappingText, _SpmMappingStateReject
  , spmMappingAncestors
  , 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)


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)

_SpmMappingText :: Iso' SpmMapping Text
_SpmMappingText = iso toText fromText
  where
    toText :: SpmMapping -> Text
    toText SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
                         <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension

    fromText :: Text -> SpmMapping
    fromText t = case ts ^? _Snoc of
        Nothing -> SpmMapping{ spmMappingLocal = Nothing, spmMappingExtension = Nothing }
        Just (tInit, tLast) -> SpmMapping
          { spmMappingLocal = fmap (SpmLocal . CI.mk) . assertNonEmpty $ Text.intercalate extSep tInit
          , spmMappingExtension = fmap (SpmExtension . CI.mk) $ assertNonEmpty tLast
          }
      where
        extSep = "+"

        ts = Text.splitOn extSep t

        assertNonEmpty :: Text -> Maybe Text
        assertNonEmpty t' | Text.null t' = Nothing
                          | otherwise = Just t'

instance FromHttpApiData SpmMapping where
  parseUrlPiece = Right . review _SpmMappingText
instance ToHttpApiData SpmMapping where
  toUrlPiece = view _SpmMappingText

spmMappingAncestors :: SpmMapping -> [SpmMapping]
spmMappingAncestors spmMapping = case nextMapping of
    Nothing -> []
    Just next -> next : spmMappingAncestors next
  where
    nextMapping = case spmMapping of
      SpmMapping{ spmMappingLocal, spmMappingExtension = Just _ } -> Just SpmMapping{spmMappingLocal, spmMappingExtension = Nothing}
      SpmMapping{ spmMappingLocal = Just _ } -> Just SpmMapping{spmMappingLocal = Nothing, spmMappingExtension = Nothing}
      SpmMapping{} -> Nothing

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
         :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent
         :<|> "mappings" :> Capture "mapping" SpmMapping :> DeleteNoContent

spmApi :: Proxy SpmApi
spmApi = Proxy