{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module IOHK.Cicero.API.Fact where

import Data.Coerce
import Data.Text
import Data.Aeson
import Data.Time.LocalTime
import Data.UUID
import Data.ByteString.Lazy
import Data.Binary.Builder
import Servant.API
import Servant.API.Generic
import Servant.API.NamedRoutes

import {-# SOURCE #-} IOHK.Cicero.API.Run (RunID)

newtype FactID = FactID { FactID -> UUID
uuid :: UUID } deriving newtype ([FactID] -> Encoding
[FactID] -> Value
FactID -> Encoding
FactID -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FactID] -> Encoding
$ctoEncodingList :: [FactID] -> Encoding
toJSONList :: [FactID] -> Value
$ctoJSONList :: [FactID] -> Value
toEncoding :: FactID -> Encoding
$ctoEncoding :: FactID -> Encoding
toJSON :: FactID -> Value
$ctoJSON :: FactID -> Value
ToJSON, Value -> Parser [FactID]
Value -> Parser FactID
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FactID]
$cparseJSONList :: Value -> Parser [FactID]
parseJSON :: Value -> Parser FactID
$cparseJSON :: Value -> Parser FactID
FromJSON, FactID -> ByteString
FactID -> Builder
FactID -> Text
forall a.
(a -> Text)
-> (a -> Builder)
-> (a -> ByteString)
-> (a -> Text)
-> ToHttpApiData a
toQueryParam :: FactID -> Text
$ctoQueryParam :: FactID -> Text
toHeader :: FactID -> ByteString
$ctoHeader :: FactID -> ByteString
toEncodedUrlPiece :: FactID -> Builder
$ctoEncodedUrlPiece :: FactID -> Builder
toUrlPiece :: FactID -> Text
$ctoUrlPiece :: FactID -> Text
ToHttpApiData, FactID -> FactID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FactID -> FactID -> Bool
$c/= :: FactID -> FactID -> Bool
== :: FactID -> FactID -> Bool
$c== :: FactID -> FactID -> Bool
Eq, Eq FactID
FactID -> FactID -> Bool
FactID -> FactID -> Ordering
FactID -> FactID -> FactID
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
min :: FactID -> FactID -> FactID
$cmin :: FactID -> FactID -> FactID
max :: FactID -> FactID -> FactID
$cmax :: FactID -> FactID -> FactID
>= :: FactID -> FactID -> Bool
$c>= :: FactID -> FactID -> Bool
> :: FactID -> FactID -> Bool
$c> :: FactID -> FactID -> Bool
<= :: FactID -> FactID -> Bool
$c<= :: FactID -> FactID -> Bool
< :: FactID -> FactID -> Bool
$c< :: FactID -> FactID -> Bool
compare :: FactID -> FactID -> Ordering
$ccompare :: FactID -> FactID -> Ordering
Ord)

factIdFromString :: String -> Maybe FactID
factIdFromString :: String -> Maybe FactID
factIdFromString = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe UUID
fromString

type API = NamedRoutes FactRoutes

-- | Fact routes in the Cicero API
data FactRoutes mode = FactRoutes
  { forall mode.
FactRoutes mode
-> mode
   :- (ReqBody '[OctetStream] CreateFactV1 :> Post '[JSON] FactV1)
create :: mode :- ReqBody '[OctetStream] CreateFactV1 :> Post '[JSON] FactV1
  , forall mode.
FactRoutes mode
-> mode
   :- (QueryParam' '[Required, Strict] "run" RunID
       :> Get '[JSON] [FactV1])
getAll :: mode :- QueryParam' '[Required, Strict] "run" RunID :> Get '[JSON] [FactV1]
  } deriving stock forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall mode x. Rep (FactRoutes mode) x -> FactRoutes mode
forall mode x. FactRoutes mode -> Rep (FactRoutes mode) x
$cto :: forall mode x. Rep (FactRoutes mode) x -> FactRoutes mode
$cfrom :: forall mode x. FactRoutes mode -> Rep (FactRoutes mode) x
Generic

data CreateFactV1 = CreateFact
  { -- | The data of the fact
    CreateFactV1 -> Value
fact :: !Value
  , -- | Binary blob attached to the fact
    CreateFactV1 -> Maybe ByteString
artifact :: !(Maybe ByteString)
  }

-- | This instance assumes that @'toEncoding' \@'Value'@ has no trailing whitespace!
instance MimeRender OctetStream CreateFactV1 where
  mimeRender :: Proxy OctetStream -> CreateFactV1 -> ByteString
mimeRender Proxy OctetStream
_ CreateFactV1
cf = Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ Builder
factBuilt forall a. Semigroup a => a -> a -> a
<> Builder
artifactBuilt
    where
      factBuilt :: Builder
factBuilt = forall tag. Encoding' tag -> Builder
fromEncoding forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
toEncoding CreateFactV1
cf.fact
      artifactBuilt :: Builder
artifactBuilt = case CreateFactV1
cf.artifact of
        Just ByteString
a -> ByteString -> Builder
fromLazyByteString ByteString
a
        Maybe ByteString
Nothing -> forall a. Monoid a => a
mempty

-- | A Cicero fact
data FactV1 = Fact
  { FactV1 -> FactID
id :: !FactID
  , FactV1 -> Maybe RunID
runId :: !(Maybe RunID)
  , FactV1 -> ZonedTime
createdAt :: !ZonedTime
  , FactV1 -> Value
value :: !Value
  , -- | The hash of the artifact, if any
    --
    -- This should be a proper hash type
    FactV1 -> Maybe Text
binaryHash :: !(Maybe Text)
  }

instance FromJSON FactV1 where
  parseJSON :: Value -> Parser FactV1
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"FactV1" \Object
o -> FactID -> Maybe RunID -> ZonedTime -> Value -> Maybe Text -> FactV1
Fact
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"run_id"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"created_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"binary_hash"

instance ToJSON FactV1 where
  toJSON :: FactV1 -> Value
toJSON FactV1
f = [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
      [ Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.id
      , Key
"created_at" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.createdAt
      , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.value
      ] forall a. [a] -> [a] -> [a]
++ [Pair]
runIdFields forall a. [a] -> [a] -> [a]
++ [Pair]
binaryHashFields
    where
      runIdFields :: [Pair]
runIdFields = case FactV1
f.runId of
        Just RunID
rid -> [ Key
"run_id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RunID
rid ]
        Maybe RunID
Nothing -> []
      binaryHashFields :: [Pair]
binaryHashFields = case FactV1
f.binaryHash of
        Just Text
hash -> [ Key
"binary_hash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
hash ]
        Maybe Text
Nothing -> []
  toEncoding :: FactV1 -> Encoding
toEncoding FactV1
f = Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$
      ( Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.id
     forall a. Semigroup a => a -> a -> a
<> Key
"created_at" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.createdAt
     forall a. Semigroup a => a -> a -> a
<> Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FactV1
f.value
      ) forall a. Semigroup a => a -> a -> a
<> Series
runIdFields forall a. Semigroup a => a -> a -> a
<> Series
binaryHashFields
    where
      runIdFields :: Series
runIdFields = case FactV1
f.runId of
        Just RunID
rid -> Key
"run_id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RunID
rid
        Maybe RunID
Nothing -> forall a. Monoid a => a
mempty
      binaryHashFields :: Series
binaryHashFields = case FactV1
f.binaryHash of
        Just Text
hash -> Key
"binary_hash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
hash
        Maybe Text
Nothing -> forall a. Monoid a => a
mempty