{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}

module Hercules.API.Id
  ( Id (..),
    idText,
    uncheckedCast,
  )
where

import Control.DeepSeq (NFData)
import Control.Lens ((?~))
import Data.Aeson
import Data.Aeson.Types (toJSONKeyText)
import Data.Function ((&))
import Data.Hashable (Hashable (..))
import Data.Swagger
  ( NamedSchema (NamedSchema),
    ParamSchema,
    SwaggerType (SwaggerString),
    ToParamSchema (..),
    ToSchema (..),
    format,
    paramSchemaToSchema,
    type_,
  )
import Data.Text (Text)
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import GHC.Generics (Generic)
import Web.HttpApiData
import Prelude

newtype Id (a :: k) = Id {Id a -> UUID
idUUID :: UUID}
  deriving ((forall x. Id a -> Rep (Id a) x)
-> (forall x. Rep (Id a) x -> Id a) -> Generic (Id a)
forall x. Rep (Id a) x -> Id a
forall x. Id a -> Rep (Id a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (a :: k) x. Rep (Id a) x -> Id a
forall k (a :: k) x. Id a -> Rep (Id a) x
$cto :: forall k (a :: k) x. Rep (Id a) x -> Id a
$cfrom :: forall k (a :: k) x. Id a -> Rep (Id a) x
Generic, Id a -> Id a -> Bool
(Id a -> Id a -> Bool) -> (Id a -> Id a -> Bool) -> Eq (Id a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). Id a -> Id a -> Bool
/= :: Id a -> Id a -> Bool
$c/= :: forall k (a :: k). Id a -> Id a -> Bool
== :: Id a -> Id a -> Bool
$c== :: forall k (a :: k). Id a -> Id a -> Bool
Eq, Eq (Id a)
Eq (Id a)
-> (Id a -> Id a -> Ordering)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Id a)
-> (Id a -> Id a -> Id a)
-> Ord (Id a)
Id a -> Id a -> Bool
Id a -> Id a -> Ordering
Id a -> Id a -> Id a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (a :: k). Eq (Id a)
forall k (a :: k). Id a -> Id a -> Bool
forall k (a :: k). Id a -> Id a -> Ordering
forall k (a :: k). Id a -> Id a -> Id a
min :: Id a -> Id a -> Id a
$cmin :: forall k (a :: k). Id a -> Id a -> Id a
max :: Id a -> Id a -> Id a
$cmax :: forall k (a :: k). Id a -> Id a -> Id a
>= :: Id a -> Id a -> Bool
$c>= :: forall k (a :: k). Id a -> Id a -> Bool
> :: Id a -> Id a -> Bool
$c> :: forall k (a :: k). Id a -> Id a -> Bool
<= :: Id a -> Id a -> Bool
$c<= :: forall k (a :: k). Id a -> Id a -> Bool
< :: Id a -> Id a -> Bool
$c< :: forall k (a :: k). Id a -> Id a -> Bool
compare :: Id a -> Id a -> Ordering
$ccompare :: forall k (a :: k). Id a -> Id a -> Ordering
$cp1Ord :: forall k (a :: k). Eq (Id a)
Ord, Id a -> ()
(Id a -> ()) -> NFData (Id a)
forall a. (a -> ()) -> NFData a
forall k (a :: k). Id a -> ()
rnf :: Id a -> ()
$crnf :: forall k (a :: k). Id a -> ()
NFData)

instance Hashable (Id a) where
  hashWithSalt :: Int -> Id a -> Int
hashWithSalt Int
s (Id UUID
uuid) =
    let (Word32
a, Word32
b, Word32
c, Word32
d) = UUID -> (Word32, Word32, Word32, Word32)
UUID.toWords UUID
uuid
     in Int
s
          Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
a
          Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
b
          Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
c
          Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
d

idText :: Id a -> Text
idText :: Id a -> Text
idText = UUID -> Text
UUID.toText (UUID -> Text) -> (Id a -> UUID) -> Id a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> UUID
forall k (a :: k). Id a -> UUID
idUUID

uncheckedCast :: Id a -> Id b
uncheckedCast :: Id a -> Id b
uncheckedCast (Id UUID
s) = UUID -> Id b
forall k (a :: k). UUID -> Id a
Id UUID
s

instance Show (Id a) where
  showsPrec :: Int -> Id a -> ShowS
showsPrec Int
n = Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n (Text -> ShowS) -> (Id a -> Text) -> Id a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> Text
forall k (a :: k). Id a -> Text
idText

instance ToJSON (Id a) where
  toEncoding :: Id a -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding) -> (Id a -> Text) -> Id a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> Text
forall k (a :: k). Id a -> Text
idText

  toJSON :: Id a -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Id a -> Text) -> Id a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> Text
forall k (a :: k). Id a -> Text
idText

instance FromJSON (Id a) where
  parseJSON :: Value -> Parser (Id a)
parseJSON = (UUID -> Id a) -> Parser UUID -> Parser (Id a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> Id a
forall k (a :: k). UUID -> Id a
Id (Parser UUID -> Parser (Id a))
-> (Value -> Parser UUID) -> Value -> Parser (Id a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser UUID
forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToJSONKey (Id a) where
  toJSONKey :: ToJSONKeyFunction (Id a)
toJSONKey = (Id a -> Text) -> ToJSONKeyFunction (Id a)
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText Id a -> Text
forall k (a :: k). Id a -> Text
idText

instance FromJSONKey (Id a) where
  fromJSONKey :: FromJSONKeyFunction (Id a)
fromJSONKey = (Text -> Parser (Id a)) -> FromJSONKeyFunction (Id a)
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser (Id a)) -> FromJSONKeyFunction (Id a))
-> (Text -> Parser (Id a)) -> FromJSONKeyFunction (Id a)
forall a b. (a -> b) -> a -> b
$ \Text
text ->
    case Text -> Maybe UUID
UUID.fromText Text
text of
      Just UUID
x -> Id a -> Parser (Id a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id a -> Parser (Id a)) -> Id a -> Parser (Id a)
forall a b. (a -> b) -> a -> b
$ UUID -> Id a
forall k (a :: k). UUID -> Id a
Id UUID
x
      Maybe UUID
Nothing -> String -> Parser (Id a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected UUID"

instance ToHttpApiData (Id a) where
  toUrlPiece :: Id a -> Text
toUrlPiece = Id a -> Text
forall k (a :: k). Id a -> Text
idText

instance FromHttpApiData (Id a) where
  parseUrlPiece :: Text -> Either Text (Id a)
parseUrlPiece = (UUID -> Id a) -> Either Text UUID -> Either Text (Id a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> Id a
forall k (a :: k). UUID -> Id a
Id (Either Text UUID -> Either Text (Id a))
-> (Text -> Either Text UUID) -> Text -> Either Text (Id a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text UUID
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece

instance ToSchema (Id a) where
  declareNamedSchema :: Proxy (Id a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> (Proxy (Id a) -> NamedSchema)
-> Proxy (Id a)
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Schema -> NamedSchema)
-> (Proxy (Id a) -> Schema) -> Proxy (Id a) -> NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (Id a) -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema

instance ToParamSchema (Id a) where
  toParamSchema :: Proxy (Id a) -> ParamSchema t
toParamSchema Proxy (Id a)
_ =
    (forall a. Monoid a => a
forall (t :: SwaggerKind *). ParamSchema t
mempty :: ParamSchema t)
      ParamSchema t -> (ParamSchema t -> ParamSchema t) -> ParamSchema t
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType t) -> Identity (Maybe (SwaggerType t)))
-> ParamSchema t -> Identity (ParamSchema t)
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType t) -> Identity (Maybe (SwaggerType t)))
 -> ParamSchema t -> Identity (ParamSchema t))
-> SwaggerType t -> ParamSchema t -> ParamSchema t
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType t
forall (t :: SwaggerKind *). SwaggerType t
SwaggerString
      ParamSchema t -> (ParamSchema t -> ParamSchema t) -> ParamSchema t
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> ParamSchema t -> Identity (ParamSchema t)
forall s a. HasFormat s a => Lens' s a
format ((Maybe Text -> Identity (Maybe Text))
 -> ParamSchema t -> Identity (ParamSchema t))
-> Text -> ParamSchema t -> ParamSchema t
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"uuid"