module Colorless.Endpoint
( runColorless
, runColorlessSingleton
) where
import qualified Data.Map as Map
import qualified Data.HashMap.Lazy as HML
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Except
import Control.Concurrent.Async.Lifted ()
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Text (Text)
import Data.Map (Map)
import Colorless.Types
import Colorless.Server.Exchange
import Colorless.RuntimeThrower
runColorlessSingleton
:: MonadIO m
=> Version
-> (Request -> m (Either Response Response))
-> Value
-> m Value
runColorlessSingleton Version{major,minor} handleRequest = runColorless (Map.singleton major (minor, handleRequest))
runColorless
:: MonadIO m
=> Map Major (Minor, Request -> m (Either Response Response))
-> Value
-> m Value
runColorless handleRequestMap v = do
e <- runExceptT $ do
colorlessVersion <- getColorlessVersion v
assertColorlessVersionCompatiability colorlessVersion
apiVersion <- getApiVersion v
let apiMajor = major apiVersion
case Map.lookup apiMajor handleRequestMap of
Nothing -> case leastAndGreatest (Map.keys handleRequestMap) of
Nothing -> runtimeThrow RuntimeError'NoImplementation
Just (minMajor, maxMajor) ->
if minMajor > apiMajor
then runtimeThrow RuntimeError'ApiMajorVersionTooLow
else if maxMajor < apiMajor
then runtimeThrow RuntimeError'ApiMajorVersionTooHigh
else runtimeThrow RuntimeError'NoImplementation
Just (maxMinor, handleRequest) -> if minor apiVersion > maxMinor
then runtimeThrow RuntimeError'ApiMinorVersionTooHigh
else case parseRequest v of
Nothing -> runtimeThrow RuntimeError'UnparsableFormat
Just req -> toJSON <$> ExceptT (handleRequest req)
return $ either toJSON id e
leastAndGreatest :: Ord a => [a] -> Maybe (a,a)
leastAndGreatest [] = Nothing
leastAndGreatest xs = Just (minimum xs, maximum xs)
assertColorlessVersionCompatiability :: RuntimeThrower m => Version -> m ()
assertColorlessVersionCompatiability Version{major,minor}
| major > mustMajor = runtimeThrow RuntimeError'ColorlessMajorVersionTooHigh
| major < mustMajor = runtimeThrow RuntimeError'ColorlessMajorVersionTooLow
| minor > maxMinor = runtimeThrow RuntimeError'ColorlessMinorVersionTooHigh
| otherwise = return ()
where
mustMajor = 0
maxMinor = 0
getApiVersion :: RuntimeThrower m => Value -> m Version
getApiVersion = getVersion "version" RuntimeError'NoApiVersion
getColorlessVersion :: RuntimeThrower m => Value -> m Version
getColorlessVersion = getVersion "colorless" RuntimeError'NoColorlessVersion
getVersion :: RuntimeThrower m => Text -> RuntimeError -> Value -> m Version
getVersion name err (Object o) = case HML.lookup name o of
Just x -> maybe (runtimeThrow err) return (parseMaybe parseJSON x)
Nothing -> runtimeThrow err
getVersion _ err _ = runtimeThrow err
parseRequest :: Value -> Maybe Request
parseRequest = parseMaybe parseJSON