add better server error messages, cbor vs raw hex

agora-scripts/Data/Cache/Cached.hs

@@ -6,7 +6,8 @@
 -}
 module Data.Cache.Cached (
   cached,
-  cachedFor,
+  cachedM,
+  cachedForM,
 ) where
 
 import Control.Monad.IO.Class (MonadIO (liftIO))
@@ -20,7 +21,14 @@ import System.Clock (TimeSpec)
    Uses a HashMap under the hood.
 -}
 cached :: (Monad m, MonadIO m, Hashable k, Ord k) => (k -> v) -> IO (k -> m v)
-cached = cachedFor Nothing
+cached f = cachedForM Nothing (pure . f)
+
+{- | 'cachedFor' but items last forever.
+
+   Uses a HashMap under the hood.
+-}
+cachedM :: (Monad m, MonadIO m, Hashable k, Ord k) => (k -> m v) -> IO (k -> m v)
+cachedM = cachedForM Nothing
 
 {- | Create a cached version of a function tainting result with MonadIO context.
 
@@ -28,13 +36,13 @@ cached = cachedFor Nothing
 
    Uses a HashMap under the hood.
 -}
-cachedFor :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> v) -> IO (k -> m v)
-cachedFor t f =
+cachedForM :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> m v) -> IO (k -> m v)
+cachedForM t f =
   Cache.newCache t <&> \cache k -> do
     res <- liftIO $ Cache.lookup cache k
     case res of
       Nothing -> do
-        let v = f k
+        v <- f k
         liftIO $ Cache.insert cache k v
         pure v
       Just v -> do

agora-scripts/Main.hs

@@ -15,7 +15,7 @@ import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolF
 import Agora.Proposal (Proposal)
 import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
 import Agora.SafeMoney (GTTag)
-import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo)
+import Agora.ScriptInfo (ScriptInfo, mkPolicyInfo, mkValidatorInfo)
 import Agora.Stake (Stake)
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 import Agora.Treasury (treasuryValidator)
@@ -119,14 +119,14 @@ data ScriptParams where
      @since 0.2.0
 -}
 data AgoraScripts = AgoraScripts
-  { governorPolicyInfo :: PolicyInfo
-  , governorValidatorInfo :: ValidatorInfo
-  , stakePolicyInfo :: PolicyInfo
-  , stakeValidatorInfo :: ValidatorInfo
-  , proposalPolicyInfo :: PolicyInfo
-  , proposalValidatorInfo :: ValidatorInfo
-  , treasuryValidatorInfo :: ValidatorInfo
-  , authorityTokenPolicyInfo :: PolicyInfo
+  { governorPolicyInfo :: ScriptInfo
+  , governorValidatorInfo :: ScriptInfo
+  , stakePolicyInfo :: ScriptInfo
+  , stakeValidatorInfo :: ScriptInfo
+  , proposalPolicyInfo :: ScriptInfo
+  , proposalValidatorInfo :: ScriptInfo
+  , treasuryValidatorInfo :: ScriptInfo
+  , authorityTokenPolicyInfo :: ScriptInfo
   }
   deriving anyclass
     ( -- | @since 0.2.0

agora-scripts/ScriptExport/API.hs

@@ -11,7 +11,7 @@ module ScriptExport.API (
 
 import Codec.Serialise.Orphans ()
 import Data.Aeson qualified as Aeson
-import Data.Cache.Cached (cachedFor)
+import Data.Cache.Cached (cachedForM)
 import Data.Function ((&))
 import Data.Proxy (Proxy (Proxy))
 import Data.Text (Text)
@@ -35,8 +35,11 @@ import Text.Printf (printf)
      @since 0.2.0
 -}
 type API =
-  "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value
-    :<|> "info" :> Get '[JSON] ServerInfo
+  "query-script"
+    :> ReqBody '[JSON] ScriptQuery
+    :> Post '[JSON] Aeson.Value
+    :<|> "info"
+    :> Get '[JSON] ServerInfo
 
 {- | Information about the server.
 
@@ -86,7 +89,7 @@ runServer revision builders options = do
       corsMiddleware = cors . const $ Just corsPolicy
 
   -- Scripts stay cached for five minutes
-  query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` builders)
+  query <- cachedForM (Just $ TimeSpec 300 0) (`runQuery` builders)
 
   let serverInfo =
         ServerInfo

agora-scripts/ScriptExport/Types.hs

@@ -14,6 +14,7 @@ module ScriptExport.Types (
 ) where
 
 import Data.Aeson qualified as Aeson
+import Data.ByteString.Lazy.Char8 qualified as LBS
 import Data.Coerce (coerce)
 import Data.Default.Class (Default (def))
 import Data.Hashable (Hashable)
@@ -21,6 +22,7 @@ import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import GHC.Generics qualified as GHC
+import Servant qualified
 
 {- | Query data for getting script info.
 
@@ -55,16 +57,20 @@ data ScriptQuery = ScriptQuery
 
      @since 0.2.0
 -}
-runQuery :: ScriptQuery -> Builders -> Aeson.Value
+runQuery :: ScriptQuery -> Builders -> Servant.Handler Aeson.Value
 runQuery s =
-  maybe Aeson.Null ($ s.paramsPayload) . Map.lookup s.name . getBuilders
+  maybe
+    (Servant.throwError Servant.err404 {Servant.errBody = "Builder not found"})
+    ($ s.paramsPayload)
+    . Map.lookup s.name
+    . getBuilders
 
 {- | Represents a list of named pure functions.
 
      @since 0.2.0
 -}
 newtype Builders = Builders
-  { getBuilders :: Map Text (Aeson.Value -> Aeson.Value)
+  { getBuilders :: Map Text (Aeson.Value -> Servant.Handler Aeson.Value)
   }
 
 -- | @since 0.2.0
@@ -84,7 +90,19 @@ insertBuilder ::
   Builders
 insertBuilder k = coerce . Map.insert k . throughJSON
   where
-    throughJSON f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON
+    throughJSON ::
+      forall p s.
+      (Aeson.FromJSON p, Aeson.ToJSON s) =>
+      (p -> s) ->
+      (Aeson.Value -> Servant.Handler Aeson.Value)
+    throughJSON f v =
+      case Aeson.fromJSON v of
+        Aeson.Error e ->
+          Servant.throwError $
+            Servant.err400
+              { Servant.errBody = LBS.pack e
+              }
+        Aeson.Success v' -> pure . Aeson.toJSON $ f v'
 
 {- | Get a list of the available builders.
 

agora.cabal

@@ -91,7 +91,9 @@ common deps
     , ansi-terminal
     , base                   >=4.14 && <5
     , base-compat
+    , base16
     , bytestring
+    , cardano-binary
     , cardano-prelude
     , containers
     , data-default

agora/Agora/Aeson/Orphans.hs

@@ -20,6 +20,7 @@ import Data.Text.Encoding qualified as T
 
 import PlutusLedgerApi.V1 qualified as Plutus
 import PlutusLedgerApi.V1.Bytes qualified as Plutus
+import PlutusLedgerApi.V1.Scripts qualified as Plutus
 import PlutusLedgerApi.V1.Value qualified as Plutus
 
 --------------------------------------------------------------------------------
@@ -109,6 +110,15 @@ deriving via
   instance
     (Aeson.FromJSON Plutus.ValidatorHash)
 
+deriving via
+  (AsBase16Bytes Plutus.ScriptHash)
+  instance
+    (Aeson.ToJSON Plutus.ScriptHash)
+deriving via
+  (AsBase16Bytes Plutus.ScriptHash)
+  instance
+    (Aeson.FromJSON Plutus.ScriptHash)
+
 deriving via
   (AsBase16Bytes Plutus.BuiltinByteString)
   instance

agora/Agora/ScriptInfo.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 {- |
 Module     : Agora.ScriptInfo
 Maintainer : emi@haskell.fyi
@@ -7,8 +9,6 @@ Exportable script bundles for off-chain consumption.
 -}
 module Agora.ScriptInfo (
   -- * Types
-  PolicyInfo (..),
-  ValidatorInfo (..),
   ScriptInfo (..),
 
   -- * Introduction functions
@@ -17,100 +17,71 @@ module Agora.ScriptInfo (
 ) where
 
 import Agora.Aeson.Orphans ()
+import Cardano.Binary qualified as CBOR
+import Codec.Serialise qualified as Codec
 import Data.Aeson qualified as Aeson
+import Data.ByteString.Base16 qualified as Base16
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Short qualified as SBS
+import Data.Text (Text)
 import GHC.Generics qualified as GHC
-import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
+import Plutarch.Api.V1 (PMintingPolicy, PValidator, mkMintingPolicy, mkValidator, scriptHash)
 import PlutusLedgerApi.V1 (
-  BuiltinByteString,
-  CurrencySymbol,
-  MintingPolicy,
+  MintingPolicy (getMintingPolicy),
   Script,
-  Validator,
-  ValidatorHash,
+  Validator (getValidator),
  )
-
--- | Bundle containing a 'Script' and its hash.
-data ScriptInfo = ScriptInfo
-  { script :: Script
-  -- ^ The validator script.
-  , hash :: BuiltinByteString
-  -- ^ Hash of the script.
-  }
-  deriving stock (Show, Eq, GHC.Generic)
-  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+import PlutusLedgerApi.V1.Scripts (ScriptHash)
 
 {- | Bundle containing a 'Validator' and its hash.
 
-     @since 0.1.0
+     @since 0.2.0
 -}
-data ValidatorInfo = ValidatorInfo
-  { script :: Validator
-  -- ^ The validator script.
-  , hash :: ValidatorHash
+data ScriptInfo = ScriptInfo
+  { cborHex :: Text
+  -- ^ The validator script encoded as cbor hex.
+  , rawHex :: Text
+  -- ^ The validator script encoded as raw hex.
+  , hash :: ScriptHash
   -- ^ Hash of the validator.
   }
   deriving stock
-    ( -- | @since 0.1.0
+    ( -- | @since 0.2.0
       Show
-    , -- | @since 0.1.0
+    , -- | @since 0.2.0
       Eq
-    , -- | @since 0.1.0
+    , -- | @since 0.2.0
       GHC.Generic
     )
   deriving anyclass
-    ( -- | @since 0.1.0
+    ( -- | @since 0.2.0
       Aeson.ToJSON
-    , -- | @since 0.1.0
+    , -- | @since 0.2.0
       Aeson.FromJSON
     )
 
-{- | Create a 'ValidatorInfo' given a Plutarch term.
+mkScriptInfo :: Script -> ScriptInfo
+mkScriptInfo script =
+  let scriptRaw = LBS.toStrict $ Codec.serialise script
+      scriptCBOR = CBOR.serialize' $ SBS.toShort scriptRaw
+   in ScriptInfo
+        { cborHex = Base16.encodeBase16 scriptCBOR
+        , rawHex = Base16.encodeBase16 scriptRaw
+        , hash = scriptHash script
+        }
 
-     @since 0.1.0
+{- | Create a 'ScriptInfo' given a Plutarch term of a policy.
+
+     @since 0.2.0
 -}
-mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
-mkValidatorInfo term =
-  ValidatorInfo
-    { script = validator
-    , hash = validatorHash validator
-    }
-  where
-    validator = mkValidator term
-
-{- | Bundle containing a 'MintingPolicy' and its symbol.
-
-     @since 0.1.0
--}
-data PolicyInfo = PolicyInfo
-  { policy :: MintingPolicy
-  -- ^ The minting policy.
-  , currencySymbol :: CurrencySymbol
-  -- ^ The symbol given by the minting policy.
-  }
-  deriving stock
-    ( -- | @since 0.1.0
-      Show
-    , -- | @since 0.1.0
-      Eq
-    , -- | @since 0.1.0
-      GHC.Generic
-    )
-  deriving anyclass
-    ( -- | @since 0.1.0
-      Aeson.ToJSON
-    , -- | @since 0.1.0
-      Aeson.FromJSON
-    )
-
-{- | Create a 'PolicyInfo' given a Plutarch term.
-
-     @since 0.1.0
--}
-mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
+mkPolicyInfo :: ClosedTerm PMintingPolicy -> ScriptInfo
 mkPolicyInfo term =
-  PolicyInfo
-    { policy = policy
-    , currencySymbol = mintingPolicySymbol policy
-    }
-  where
-    policy = mkMintingPolicy term
+  mkScriptInfo (getMintingPolicy $ mkMintingPolicy term)
+
+{- | Create a 'ScriptInfo' given a Plutarch term of a validator.
+
+     @since 0.2.0
+-}
+mkValidatorInfo :: ClosedTerm PValidator -> ScriptInfo
+mkValidatorInfo term =
+  mkScriptInfo (getValidator $ mkValidator term)