{-# 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 {forall k (a :: k). Id a -> UUID
idUUID :: UUID}
  deriving (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
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, 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
Ord, 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
          forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
a
          forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
b
          forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
c
          forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
d

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

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

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

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

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

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

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

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

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

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

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

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