ViewName.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | Michelson view name.
module Morley.Michelson.Internal.ViewName
  ( module Morley.Michelson.Internal.ViewName
  ) where

import Control.Monad.Except (throwError)
import Data.Aeson (FromJSONKey(..), ToJSONKey(..))
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types qualified as AesonTypes
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.Data (Data)
import Data.Text qualified as Text
import Fmt (Buildable(..), Doc, pretty, (+|), (|+))
import Prettyprinter (dquotes)

import Morley.Michelson.Printer.Util
import Morley.Michelson.Text
import Morley.Util.Aeson
import Morley.Util.CLI

-- | Name of the view.
--
-- 1. It must not exceed 31 chars length;
-- 2. Must use [a-zA-Z0-9_.%@] charset.
newtype ViewName = UnsafeViewName { unViewName :: Text }
  deriving stock (Show, Eq, Ord, Data, Generic)
  deriving newtype (Buildable, NFData)

pattern ViewName :: Text -> ViewName
pattern ViewName name <- UnsafeViewName name
{-# COMPLETE ViewName #-}

deriveJSON morleyAesonOptions ''ViewName

instance HasCLReader ViewName where
  getReader = eitherReader (first pretty . mkViewName . toText)
  getMetavar = "VIEW NAME"

instance ToJSONKey ViewName where
  toJSONKey = AesonTypes.toJSONKeyText unViewName

instance FromJSONKey ViewName where
  fromJSONKey = AesonTypes.FromJSONKeyTextParser $ either (fail . pretty) pure . mkViewName

-- | Whether the given character is valid for a view.
isValidViewNameChar :: Char -> Bool
isValidViewNameChar = or
  [ isAsciiUpper
  , isAsciiLower
  , isDigit
  , (`elem` ['_', '.', '%', '@'])
  ]

-- | Maximum allowed name length for a view.
viewNameMaxLength :: Int
viewNameMaxLength = 31

data BadViewNameError
  = BadViewTooLong Int
  | BadViewIllegalChars Text
  deriving stock (Show, Eq, Ord, Data, Generic)
  deriving anyclass (NFData)

instance Buildable BadViewNameError where
  build = \case
    BadViewTooLong l ->
      "Bad view name length of " +| l |+ " characters, must not exceed \
      \" +| viewNameMaxLength |+ " characters length"
    BadViewIllegalChars txt ->
      "Invalid characters in the view \"" +| txt |+ ", allowed characters set \
      \is [a-zA-Z0-9_.%@]"

-- | Construct t'ViewName' performing all the checks.
mkViewName :: Text -> Either BadViewNameError ViewName
mkViewName txt = do
  unless (length txt <= viewNameMaxLength) $
    throwError (BadViewTooLong $ length txt)
  unless (Text.all isValidViewNameChar txt) $
    throwError (BadViewIllegalChars txt)
  return (UnsafeViewName txt)

renderViewName :: ViewName -> Doc
renderViewName = dquotes . build . unViewName

instance RenderDoc ViewName where
  renderDoc _ = renderViewName

-- | Valid view names form a subset of valid Michelson texts.
viewNameToMText :: ViewName -> MText
viewNameToMText = unsafe . mkMText . unViewName