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
(EventId -> EventId -> Bool)
-> (EventId -> EventId -> Bool) -> Eq EventId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventId -> EventId -> Bool
== :: EventId -> EventId -> Bool
$c/= :: EventId -> EventId -> Bool
/= :: EventId -> EventId -> Bool
Eq, Int -> EventId -> ShowS
[EventId] -> ShowS
EventId -> String
(Int -> EventId -> ShowS)
-> (EventId -> String) -> ([EventId] -> ShowS) -> Show EventId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EventId -> ShowS
showsPrec :: Int -> EventId -> ShowS
$cshow :: EventId -> String
show :: EventId -> String
$cshowList :: [EventId] -> ShowS
showList :: [EventId] -> ShowS
Show)

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

instance Aeson.ToJSON EventId where
  toJSON :: EventId -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Text -> Value) -> (EventId -> Text) -> EventId -> Value
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 = IO EventId -> io EventId
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO EventId -> io EventId) -> IO EventId -> io EventId
forall a b. (a -> b) -> a -> b
$ (UUID -> EventId) -> IO UUID -> IO EventId
forall a b. (a -> b) -> IO a -> IO 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 (UUID -> (Word64, Word64)) -> UUID -> (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ EventId -> UUID
intoUuid EventId
eventId
   in String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Word64 -> Word64 -> String
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 -> Problem -> n (a, Text)
forall e a. (HasCallStack, Exception e) => e -> n a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text)
forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"impossible"
          Ordering
LT -> Problem -> n (a, Text)
forall e a. (HasCallStack, Exception e) => e -> n a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text)
forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"not enough input"
          Ordering
EQ -> case Reader a
forall a. Integral a => Reader a
Text.hexadecimal Text
before of
            Left String
_ -> Problem -> n (a, Text)
forall e a. (HasCallStack, Exception e) => e -> n a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text)
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 (a, Text) -> n (a, Text)
forall a. a -> n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
integral, Text
after)
                else Problem -> n (a, Text)
forall e a. (HasCallStack, Exception e) => e -> n a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Catch.throwM (Problem -> n (a, Text)) -> Problem -> n (a, Text)
forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"invalid hexadecimal"
  (Word64
lo, Text
t2) <- Int -> Text -> m (Word64, Text)
forall (n :: * -> *) a.
(MonadThrow n, Integral a) =>
Int -> Text -> n (a, Text)
parse Int
16 Text
t1
  (Word64
hi, Text
t3) <- Int -> Text -> m (Word64, Text)
forall (n :: * -> *) a.
(MonadThrow n, Integral a) =>
Int -> Text -> n (a, Text)
parse Int
16 Text
t2
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (Text -> Bool
Text.null Text
t3) (m () -> m ()) -> (Problem -> m ()) -> Problem -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Problem -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Catch.throwM (Problem -> m ()) -> Problem -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Problem
Problem.Problem String
"too much input"
  EventId -> m EventId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EventId -> m EventId) -> (UUID -> EventId) -> UUID -> m EventId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> EventId
fromUuid (UUID -> m EventId) -> UUID -> m EventId
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
Uuid.fromWords64 Word64
lo Word64
hi