From 5e3fdb826ac3b371a43bbef3356f78f767b0c6e7 Mon Sep 17 00:00:00 2001 From: Julien Moutinho <julm+symantic-http@autogeree.net> Date: Mon, 11 Mar 2019 13:32:51 +0000 Subject: [PATCH] Improve ServerResponse --- Symantic/HTTP/API.hs | 1 + Symantic/HTTP/Client.hs | 4 +- Symantic/HTTP/Client/Connection.hs | 8 +- Symantic/HTTP/MIME.hs | 2 +- Symantic/HTTP/Server.hs | 120 +++++++++++++++++++---------- test/Hspec/API.hs | 71 ++++++++--------- test/Hspec/Client.hs | 62 ++++++++------- test/Hspec/Server/Error.hs | 8 +- 8 files changed, 157 insertions(+), 119 deletions(-) diff --git a/Symantic/HTTP/API.hs b/Symantic/HTTP/API.hs index 8473697..aa2fc13 100644 --- a/Symantic/HTTP/API.hs +++ b/Symantic/HTTP/API.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StrictData #-} diff --git a/Symantic/HTTP/Client.hs b/Symantic/HTTP/Client.hs index 497d6f2..9f50212 100644 --- a/Symantic/HTTP/Client.hs +++ b/Symantic/HTTP/Client.hs @@ -113,8 +113,8 @@ instance HTTP_Body Client where } instance HTTP_Response Client where type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a) - type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest - type Response Client = ClientRequest + type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest + type Response Client = ClientRequest response :: forall a ts repr. ResponseConstraint repr a ts => diff --git a/Symantic/HTTP/Client/Connection.hs b/Symantic/HTTP/Client/Connection.hs index 0603b93..6ffd265 100644 --- a/Symantic/HTTP/Client/Connection.hs +++ b/Symantic/HTTP/Client/Connection.hs @@ -86,8 +86,12 @@ clientConnection req = do runClientConnection :: ClientEnv -> ClientConnection a -> IO (Either ClientError a) runClientConnection env (ClientConnection c) = E.runExceptT $ R.runReaderT c env -runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse) -runClientRequest env = runClientConnection env . doClientRequest +runClient :: + MimeTypes ts (MimeDecodable a) => + ClientEnv -> + (Proxy ts -> Proxy a -> ClientRequest) -> + IO (Either ClientError a) +runClient env = runClientConnection env . clientConnection -- ** Type 'ClientEnv' data ClientEnv diff --git a/Symantic/HTTP/MIME.hs b/Symantic/HTTP/MIME.hs index e90a1c4..4e0529f 100644 --- a/Symantic/HTTP/MIME.hs +++ b/Symantic/HTTP/MIME.hs @@ -84,7 +84,7 @@ instance MediaTypeFor PlainText where -- * Type 'MimeType' -- | Existentially wraps a type-level type 't' -- with a proof it respects 'Constraint' 'c'. --- Usally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@. +-- Usyally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@. data MimeType c where MimeType :: (c t, MediaTypeFor t) => Proxy t -> MimeType c mimeType :: forall t c. MediaTypeFor t => c t => MimeType c diff --git a/Symantic/HTTP/Server.hs b/Symantic/HTTP/Server.hs index c369097..c6dccdf 100644 --- a/Symantic/HTTP/Server.hs +++ b/Symantic/HTTP/Server.hs @@ -4,19 +4,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Symantic.HTTP.Server where import Control.Arrow (first) -import Control.Monad (Monad(..), unless, sequence, guard) +import Control.Applicative (Applicative(..)) +import Control.Monad (Monad(..), unless, sequence, guard, (=<<)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.), id) -import Data.Functor (Functor, (<$>)) +import Data.Functor (Functor(..), (<$>)) import Data.Int (Int) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Data.Text (Text) @@ -24,7 +28,10 @@ import Prelude ((+)) import System.IO (IO) import Text.Show (Show(..)) import qualified Control.Monad.Classes as MC -import qualified Control.Monad.Trans.State as S +import qualified Control.Monad.Trans.Cont as C +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Strict as W import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS64 import qualified Data.ByteString.Lazy as BSL @@ -58,7 +65,7 @@ newtype Server f k = Server { unServer :: (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error - (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 error + (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 or 403 error (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error (ServerCheckT [ServerErrorPath] -- 1st check, 404 error IO)))))))) @@ -68,7 +75,7 @@ newtype Server f k = Server { unServer :: -- | @'server' api handlers@ returns a 'Wai.Application' -- ready to be given to @Warp.run 80@. server :: - Server handlers ServerResponse -> + Server handlers (Response Server) -> handlers -> Wai.Application server (Server api) handlers rq re = do @@ -107,9 +114,8 @@ server (Server api) handlers rq re = do Right lrBody -> case lrBody of Left err -> respondError status400 [] err - Right (a2k, _st) -> - let ServerResponse app = a2k handlers in - app rq re + Right (app, _st) -> + app handlers rq re where respondError :: Show err => @@ -186,7 +192,7 @@ instance Cat Server where -- would do the right thing. But to my mind, -- with the very few priorities of checks currently needed, -- this is not worth the cognitive pain to design it. - -- A copy/paste/adapt will do for now. + -- Some copying/pasting/adapting will do for now. Server x <.> Server y = Server $ S.StateT $ \st -> do xPath <- liftIO $ runServerChecks x st @@ -643,27 +649,46 @@ instance HTTP_Body Server where Left err -> Left $ Fail st [ServerErrorBody err] Right a -> Right ($ ServerBodyArg a) --- ** Type 'ServerResponse' -newtype ServerResponse = ServerResponse - ( -- the request made to the server - Wai.Request -> - -- the continuation for the server to respond - (Wai.Response -> IO Wai.ResponseReceived) -> - IO Wai.ResponseReceived - ) -instance Show ServerResponse where - show _ = "ServerResponse" +-- * Type 'ServerResponse' +-- | A continuation for |server|'s users to respond. +-- +-- This newtype has two uses : +-- * Carrying the 'ts' type variable to 'server'. +-- * Providing a 'return' for the simple response case +-- of 'status200' and no extra headers. +newtype ServerResponse (ts::[*]) m a + = ServerResponse + { unServerResponse :: + R.ReaderT Wai.Request + (W.WriterT HTTP.ResponseHeaders + (W.WriterT HTTP.Status + (C.ContT Wai.Response m))) a + } + deriving (Functor, Applicative, Monad) +instance MonadTrans (ServerResponse ts) where + lift = ServerResponse . lift . lift . lift . lift +type instance MC.CanDo (ServerResponse ts m) (MC.EffReader Wai.Request) = 'True +type instance MC.CanDo (ServerResponse ts m) (MC.EffWriter HTTP.ResponseHeaders) = 'True +type instance MC.CanDo (ServerResponse ts m) (MC.EffWriter HTTP.Status) = 'True +type instance MC.CanDo (ServerResponse ts IO) (MC.EffExec IO) = 'True --- *** Type 'ServerRespond' -newtype ServerRespond a (ts::[*]) = ServerRespond - (HTTP.Status -> - HTTP.ResponseHeaders -> - a -> Wai.Response) +instance MC.MonadReaderN 'MC.Zero Wai.Request (ServerResponse ts m) where + askN px = ServerResponse $ MC.askN px +instance MC.MonadWriterN 'MC.Zero HTTP.ResponseHeaders (ServerResponse ts m) where + tellN px = ServerResponse . lift . MC.tellN px +instance MC.MonadWriterN 'MC.Zero HTTP.Status (ServerResponse ts m) where + tellN px = ServerResponse . lift . lift . MC.tellN px +instance MC.MonadExecN 'MC.Zero IO (ServerResponse ts IO) where + execN _px = ServerResponse . lift . lift . lift . lift instance HTTP_Response Server where type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a) - type ResponseArgs Server a ts = ServerRespond a ts -> ServerResponse - type Response Server = ServerResponse + type ResponseArgs Server a ts = ServerResponse ts IO a + -- | The continuation for 'response' to respond. + type Response Server = + Wai.Request -> + (Wai.Response -> IO Wai.ResponseReceived) -> + IO Wai.ResponseReceived response :: forall a ts repr. ResponseConstraint repr a ts => @@ -698,23 +723,15 @@ instance HTTP_Response Server where case matchAccept @ts @(MimeEncodable a) h of Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))] Just mt -> return mt - {- - case Media.parseAccept h of - Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaType expAccept) (Just (Left h))] - Just gotAccept - | mediaType expAccept`Media.matches`gotAccept -> return expAccept - -- FIXME: return gotAccept, maybe with GADTs - | otherwise -> MC.throw $ Fail st - [ServerErrorAccept (mediaType expAccept) (Just (Right gotAccept))] - -} - -- Respond - return ($ ServerRespond $ \s hs a -> - Wai.responseLBS s - ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs) - (if reqMethod == HTTP.methodHead - then "" - else mimeEncode reqAccept a)) + return $ \(ServerResponse k) rq re -> re =<< do + C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) -> + return $ -- IO + Wai.responseLBS sta + ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs) + (if reqMethod == HTTP.methodHead + then "" + else mimeEncode reqAccept a) -- * Status status200 :: HTTP.Status @@ -735,3 +752,22 @@ status415 :: HTTP.Status status415 = HTTP.mkStatus 415 "Unsupported Media Type" status500 :: HTTP.Status status500 = HTTP.mkStatus 500 "Server Error" + +-- | Return worse 'HTTP.Status'. +instance Semigroup HTTP.Status where + x <> y = + if rank (HTTP.statusCode x) < rank (HTTP.statusCode y) + then x + else y + where + rank :: Int -> Int + rank 404 = 0 -- Not Found + rank 405 = 1 -- Method Not Allowed + rank 401 = 2 -- Unauthorized + rank 415 = 3 -- Unsupported Media Type + rank 406 = 4 -- Not Acceptable + rank 400 = 5 -- Bad Request + rank _ = 6 +instance Monoid HTTP.Status where + mempty = status200 + mappend = (<>) diff --git a/test/Hspec/API.hs b/test/Hspec/API.hs index 0837294..762928e 100644 --- a/test/Hspec/API.hs +++ b/test/Hspec/API.hs @@ -6,6 +6,7 @@ module Hspec.API where import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Bool import Data.Either (Either(..)) import Data.Function (($), (.)) @@ -19,6 +20,7 @@ import Prelude (error, (+), (*)) import System.IO (IO) import Text.Read (readMaybe) import Text.Show (Show(..)) +import qualified Control.Monad.Trans.Cont as C import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -29,15 +31,18 @@ import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Media as Media import qualified Network.HTTP.Types as HTTP import qualified Network.URI as URI +import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Test.Hspec.Wai as Wai import qualified Web.HttpApiData as Web +import qualified Control.Monad.Classes as MC import Test.Hspec import Test.Tasty import Test.Tasty.Hspec import Symantic.HTTP +import Symantic.HTTP.Utils (liftIO) -- * Type 'API0' data API0 @@ -75,7 +80,7 @@ api1 <!> "succ" </> capture @Int "n" <.> get @Int @'[PlainText] - <!> "info" </> ( head @TL.Text @'[PlainText] + <!> "info" </> ( post @TL.Text @'[PlainText] <!> get @TL.Text @'[PlainText] ) @@ -104,35 +109,30 @@ srv1 = server api1 $ route_succ :!: route_info where - route_time tz (ServerRespond respond) = - ServerResponse $ \_req res -> do - time <- Time.utcToZonedTime tz <$> Time.getCurrentTime - res $ respond status200 [] $ - TL.pack $ show time <> "\n" + route_time tz = do + i <- route_succ 0 + time <- liftIO $ Time.utcToZonedTime tz <$> Time.getCurrentTime + return $ TL.pack $ show (i, time) <> "\n" - route_date (ServerRespond respond) = - ServerResponse $ \_req res -> do - date <- Time.utctDay <$> Time.getCurrentTime - res $ respond status200 [] $ - TL.pack $ show date <> "\n" + route_date = do + date <- liftIO $ Time.utctDay <$> Time.getCurrentTime + -- C.shiftT $ \k -> return $ Wai.responseLBS status400 [] "" + MC.tell status200 + return $ TL.pack $ show date <> "\n" - route_echo path (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] $ TL.pack $ show path <> "\n" + route_echo path = return $ TL.pack $ show path <> "\n" - route_succ n (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] $ n+1 + route_succ n = return $ n+1 - route_info = route_head :!: route_get + route_info = route_post :!: route_get where - route_head (ServerRespond respond) = - ServerResponse $ \req res -> do - res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n" + route_post = do + req :: Wai.Request <- MC.ask + return $ TL.pack $ show req <> "\n" - route_get (ServerRespond respond) = - ServerResponse $ \req res -> do - res $ respond status200 [] $ TL.pack $ show req <> "\n" + route_get = do + req :: Wai.Request <- MC.ask + return $ TL.pack $ show req <> "\n" warp1 :: IO () warp1 = Warp.run 8080 srv1 @@ -153,22 +153,17 @@ srv2 = server api2 $ :!: route_auth :!: route_date where - route_time (ServerRespond respond) = - ServerResponse $ \_req res -> do - time <- Time.getCurrentTime - res $ respond status200 [] $ - TL.pack $ show time <> "\n" + route_time = do + date <- route_date + time <- liftIO $ Time.getCurrentTime + return $ TL.pack $ show date <> "\n" <> show time <> "\n" - route_date (ServerRespond respond) = - ServerResponse $ \_req res -> do - date <- Time.utctDay <$> Time.getCurrentTime - res $ respond status200 [] $ - TL.pack $ show date <> "\n" + route_date = do + date <- liftIO $ Time.utctDay <$> Time.getCurrentTime + return $ TL.pack $ show date <> "\n" - route_auth User (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] $ - TL.pack $ show User <> "\n" + route_auth User = do + return $ TL.pack $ show User <> "\n" warp2 :: IO () warp2 = Warp.run 8080 srv2 diff --git a/test/Hspec/Client.hs b/test/Hspec/Client.hs index 8f3e439..1dd89f3 100644 --- a/test/Hspec/Client.hs +++ b/test/Hspec/Client.hs @@ -14,6 +14,7 @@ import Data.Functor ((<$>)) import Data.Int (Int) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..), fromJust) +import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String) import Data.Text (Text) @@ -51,26 +52,23 @@ srv = server api $ route_auth :!: route_body where - route_auth User{} (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] () - route_body (ServerBodyArg a) (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] () + route_auth User{} = return () + route_body (ServerBodyArg a) = return () cli_auth :!: cli_body = client api -alice, carol :: User -alice = User "Alice" "pass" 19 -carol = User "Carol" "pass" 31 +alice, bob :: User +alice = User "Alice" "pass" True 19 +bob = User "Bob" "pass" False 31 -- * Type "User" data User = User { user_name :: Text , user_pass :: Text + , user_auth :: Bool , user_age :: Int } deriving (Eq, Show) instance ServerBasicAuth User where @@ -79,7 +77,10 @@ instance ServerBasicAuth User where case Map.lookup user users of Nothing -> BasicAuth_NoSuchUser Just u@User{..} - | user_pass == pass -> BasicAuth_Authorized u + | user_pass == pass -> + if user_auth + then BasicAuth_Authorized u + else BasicAuth_Unauthorized | otherwise -> BasicAuth_BadPassword users :: Map Text User @@ -87,7 +88,7 @@ users = Map.fromList $ (\u -> (user_name u, u)) <$> [ alice - , carol + , bob ] {- @@ -105,16 +106,21 @@ hspec = testSpecs $ describe "Client" $ beforeAll (runTestServer srv) $ afterAll killTestServer $ do describe "BasicAuth" $ do - it "can authenticate" $ \TestServer{..} -> do - runClient (clientConnection $ - cli_auth (user_name alice) (user_pass alice)) + it "can allow user (200)" $ \TestServer{..} -> do + runClient env (cli_auth (user_name alice) (user_pass alice)) `shouldReturn` Right () - {- - it "can deny access" $ \(_,baseURI) -> do - Left (ClientError_FailureResponse _ r) <- - runClient (clientConnection $ client api "user" "pass") - responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" - -} + it "can deny user (401)" $ \TestServer{..} -> do + Left (ClientError_FailureResponse r) <- + runClient env $ cli_auth "no-user" (user_pass alice) + clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized" + it "can deny pass (401)" $ \TestServer{..} -> do + Left (ClientError_FailureResponse r) <- + runClient env $ cli_auth (user_name alice) "no-pass" + clientResStatus r `shouldBe` HTTP.Status 401 "Unauthorized" + it "can deny auth (403)" $ \TestServer{..} -> do + Left (ClientError_FailureResponse r) <- + runClient env $ cli_auth (user_name bob) (user_pass bob) + clientResStatus r `shouldBe` HTTP.Status 403 "Forbidden" {- import Control.Arrow (left) @@ -172,8 +178,8 @@ instance Arbitrary Person where alice :: Person alice = Person "Alice" 42 -carol :: Person -carol = Person "Carol" 17 +bob :: Person +bob = Person "Carol" 17 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] @@ -239,7 +245,7 @@ getRoot server :: Application server = serve api ( - return carol + return bob :<|> return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) @@ -329,7 +335,7 @@ runClient x baseUrl' = runClientM x $ mkClientEnv manager' baseUrl' sucessSpec :: Spec sucessSpec = beforeAll (runTestServer server) $ afterAll killTestServer $ do it "Servant.API.Get root" $ \(_, baseUrl) -> do - left show <$> runClient getRoot baseUrl `shouldReturn` Right carol + left show <$> runClient getRoot baseUrl `shouldReturn` Right bob it "Servant.API.Get" $ \(_, baseUrl) -> do left show <$> runClient getGet baseUrl `shouldReturn` Right alice @@ -558,9 +564,9 @@ pathGen = fmap NonEmpty path -- * Type 'TestServer' data TestServer = TestServer - { thread :: ThreadId - , socket :: Net.Socket - , runClient :: forall a. ClientConnection a -> IO (Either ClientError a) + { thread :: ThreadId + , socket :: Net.Socket + , env :: ClientEnv } runTestServer :: Wai.Application -> IO TestServer @@ -573,7 +579,7 @@ runTestServer waiApp = do socket waiApp manager <- Client.newManager Client.defaultManagerSettings return $ TestServer - { runClient=runClientConnection $ clientEnv manager baseURI + { env = clientEnv manager baseURI , .. } killTestServer :: TestServer -> IO () diff --git a/test/Hspec/Server/Error.hs b/test/Hspec/Server/Error.hs index fd164ec..10a21b6 100644 --- a/test/Hspec/Server/Error.hs +++ b/test/Hspec/Server/Error.hs @@ -59,12 +59,8 @@ instance ServerBasicAuth UnauthorizedUser where srv = server api $ route_good :!: route_unauthorized where - route_good i params User (ServerBodyArg b) (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] (i+b) - route_unauthorized UnauthorizedUser (ServerRespond respond) = - ServerResponse $ \_req res -> do - res $ respond status200 [] 0 + route_good i params User (ServerBodyArg b) = return (i+b) + route_unauthorized UnauthorizedUser = return 0 warp :: IO () warp = Warp.run 8080 srv -- 2.47.2