module Patrol.Type.EventId where

import qualified Control.Monad as Monad
import qualified Control.Monad.Catch as Catch
import qualified Control.Monad.IO.Class as IO
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import qualified Data.Typeable as Typeable
import qualified Data.UUID as Uuid
import qualified Data.UUID.V4 as Uuid
import qualified Patrol.Exception.Problem as Problem
import qualified Text.Printf as Printf

newtype EventId
  = EventId Uuid.UUID
  deriving (EventId -> EventId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventId -> EventId -> Bool
$c/= :: EventId -> EventId -> Bool
== :: EventId -> EventId -> Bool
$c== :: EventId -> EventId -> Bool
Eq, Int -> EventId -> ShowS
[EventId] -> ShowS
EventId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventId] -> ShowS
$cshowList :: [EventId] -> ShowS
show :: EventId -> String
$cshow :: EventId -> String
showsPrec :: Int -> EventId -> ShowS
$cshowsPrec :: Int -> EventId -> ShowS
Show)

instance Aeson.FromJSON EventId where
  parseJSON :: Value -> Parser EventId
parseJSON =
    let name :: String
name = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
Typeable.typeRep (forall {k} (t :: k). Proxy t
Typeable.Proxy :: Typeable.Proxy EventId)
     in forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
name forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"invalid " forall a. Semigroup a => a -> a -> a
<> String
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => Text -> m EventId
fromText

instance Aeson.ToJSON EventId where
  toJSON :: EventId -> Value
toJSON = forall a. ToJSON a => a -> Value
Aeson.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventId -> Text
intoText

empty :: EventId
empty :: EventId
empty = UUID -> EventId
fromUuid UUID
Uuid.nil

fromUuid :: Uuid.UUID -> EventId
fromUuid :: UUID -> EventId
fromUuid = UUID -> EventId
EventId

intoUuid :: EventId -> Uuid.UUID
intoUuid :: EventId -> UUID
intoUuid (EventId UUID
uuid) = UUID
uuid

random :: IO.MonadIO io => io EventId
random :: forall (io :: * -> *). MonadIO io => io EventId
random = forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> EventId
fromUuid IO UUID
Uuid.nextRandom

intoText :: EventId -> Text.Text
intoText :: EventId -> Text
intoText EventId
eventId =
  let (Word64
lo, Word64
hi) = UUID -> (Word64, Word64)
Uuid.toWords64 forall a b. (a -> b) -> a -> b
$ EventId -> UUID
intoUuid EventId
eventId
   in String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
Printf.printf String
"%016x%016x" Word64
lo Word64
hi

fromText :: Catch.MonadThrow m => Text.Text -> m EventId
fromText :: forall (m :: * -> *). MonadThrow m => Text -> m EventId
fromText Text
t1 = do
  let parse :: (Catch.MonadThrow n, Integral a) => Int -> Text.Text -> n (a, Text.Text)
      parse :: forall (n :: * -> *) a.
(MonadThrow n, Integral a) =>
Int -> Text -> n (a, Text)
parse Int
size Text
text = do
        let (Text
before, Text
after) = Int -> Text -> (Text, Text)
Text.splitAt Int
size Text
text
        case Text -> Int -> Ordering
Text.compareLength Text
before Int
size of
          Ordering
GT -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"impossible"
          Ordering
LT -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"not enough input"
          Ordering
EQ -> case forall a. Integral a => Reader a
Text.hexadecimal Text
before of
            Left String
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"invalid hexadecimal"
            Right (a
integral, Text
leftover) ->
              if Text -> Bool
Text.null Text
leftover
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
integral, Text
after)
                else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"invalid hexadecimal"
  (Word64
lo, Text
t2) <- forall (n :: * -> *) a.
(MonadThrow n, Integral a) =>
Int -> Text -> n (a, Text)
parse Int
16 Text
t1
  (Word64
hi, Text
t3) <- forall (n :: * -> *) a.
(MonadThrow n, Integral a) =>
Int -> Text -> n (a, Text)
parse Int
16 Text
t2
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (Text -> Bool
Text.null Text
t3) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"too much input"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> EventId
fromUuid forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
Uuid.fromWords64 Word64
lo Word64
hi