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.