diff --git a/eved.cabal b/eved.cabal --- a/eved.cabal +++ b/eved.cabal @@ -1,5 +1,5 @@ name: eved -version: 0.0.1.1 +version: 0.0.2.0 synopsis: A value level web framework description: A value level web framework in the style of servant homepage: https://github.com/foxhound-systems/eved#readme @@ -19,6 +19,7 @@ Web.Eved.Auth Web.Eved.Client Web.Eved.ContentType + Web.Eved.Header Web.Eved.Internal Web.Eved.QueryParam Web.Eved.Server @@ -27,6 +28,7 @@ build-depends: base >= 4.7 && < 5 , aeson >=1.3.1.1 && <1.6 , bytestring >=0.10.8.2 && <0.11 + , case-insensitive >=1.2.0.20 && <1.3 , http-types >=0.12.2 && <0.13 , http-media >=0.7.1.3 && <0.9 , http-client >=0.5.14 && <0.7 diff --git a/src/Web/Eved/Auth.hs b/src/Web/Eved/Auth.hs --- a/src/Web/Eved/Auth.hs +++ b/src/Web/Eved/Auth.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} + module Web.Eved.Auth where @@ -27,11 +29,11 @@ data AuthResult a = AuthSuccess a - | AuthFailure + | AuthFailure Text | AuthNeeded data AuthScheme a = AuthScheme - { authenticateRequest :: Wai.Request -> AuthResult a + { authenticateRequest :: Wai.Request -> IO (AuthResult a) , addCredentials :: a -> HTTP.Request -> HTTP.Request } @@ -50,11 +52,11 @@ if T.toLower authType == "basic" then let (username, rest') = T.breakOn ":" $ T.strip rest password = T.drop 1 rest' - in AuthSuccess (BasicAuth username password) + in pure $ AuthSuccess (BasicAuth username password) else - AuthNeeded + pure AuthNeeded Nothing -> - AuthNeeded + pure AuthNeeded , addCredentials = \creds -> HTTP.applyBasicAuth (encodeUtf8 $ basicAuthUsername creds) @@ -68,14 +70,16 @@ instance EvedAuth (Server.EvedServerT m) where auth_ schemes next = Server.EvedServerT $ \nt path action req resp -> - case go req schemes of + go req schemes >>= \case AuthSuccess a -> Server.unEvedServerT next nt path (fmap ($ a) action) req resp _ -> resp $ Wai.responseLBS unauthorized401 [] "Unauthorized" where go request (s :| rest) = - case authenticateRequest s request of - AuthSuccess a -> AuthSuccess a - AuthFailure -> AuthFailure - AuthNeeded -> maybe AuthFailure (go request) (nonEmpty rest) + authenticateRequest s request >>= \case + AuthSuccess a -> pure $ AuthSuccess a + AuthFailure err -> pure $ AuthFailure err + AuthNeeded -> maybe (pure $ AuthFailure "No matching AuthScheme found") + (go request) + (nonEmpty rest) diff --git a/src/Web/Eved/Client.hs b/src/Web/Eved/Client.hs --- a/src/Web/Eved/Client.hs +++ b/src/Web/Eved/Client.hs @@ -6,6 +6,7 @@ where import Control.Monad.Reader +import qualified Data.CaseInsensitive as CI import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe) import Data.Text (Text) @@ -16,6 +17,7 @@ queryTextToQuery, queryToQueryText, renderQuery, renderStdMethod) import qualified Web.Eved.ContentType as CT +import qualified Web.Eved.Header as H import Web.Eved.Internal import qualified Web.Eved.QueryParam as QP import qualified Web.Eved.UrlElement as UE @@ -44,27 +46,35 @@ client l req :<|> client r req lit s next = EvedClient $ \req -> - client next req{ HttpClient.path = HttpClient.path req <> (encodeUtf8 $ HttpApiData.toUrlPiece s) <> "/"} + client next req{ HttpClient.path = HttpClient.path req <> encodeUtf8 (HttpApiData.toUrlPiece s) <> "/"} capture s el next = EvedClient $ \req a -> - client next req{ HttpClient.path = HttpClient.path req <> (encodeUtf8 $ UE.toUrlPiece el a) <> "/" } + client next req{ HttpClient.path = HttpClient.path req <> encodeUtf8 (UE.toUrlPiece el a) <> "/" } reqBody (ctype:|_) next = EvedClient $ \req a -> - client next req{ HttpClient.requestBody = HttpClient.RequestBodyLBS (CT.toContentType ctype a) - , HttpClient.requestHeaders = (CT.contentTypeHeader ctype):HttpClient.requestHeaders req + client next req{ HttpClient.requestBody = HttpClient.RequestBodyLBS (snd $ CT.toContentType ctype a) + , HttpClient.requestHeaders = CT.contentTypeHeader ctype:HttpClient.requestHeaders req } queryParam argName el next = EvedClient $ \req val -> client next req{HttpClient.queryString = let query = parseQuery $ HttpClient.queryString req queryText = queryToQueryText query - newArgs = fmap (\v -> (HttpApiData.toUrlPiece argName, Just v)) $ QP.toQueryParam el val + newArgs = (\v -> (HttpApiData.toUrlPiece argName, Just v)) <$> QP.toQueryParam el val in renderQuery False $ queryTextToQuery (newArgs <> queryText)} + + header headerName el next = EvedClient $ \req val -> + let headers = HttpClient.requestHeaders req + ciHeaderName = CI.mk (encodeUtf8 headerName) + newHeaders = maybe headers (\v -> (ciHeaderName, v):headers) (H.toHeaderValue el val) + in client next req{HttpClient.requestHeaders = newHeaders} + + verb method _status ctypes = EvedClient $ \req -> ClientM $ do let reqWithMethod = req{ HttpClient.method = renderStdMethod method - , HttpClient.requestHeaders = (CT.acceptHeader ctypes):(HttpClient.requestHeaders req) + , HttpClient.requestHeaders = CT.acceptHeader ctypes:HttpClient.requestHeaders req } manager <- ask resp <- liftIO $ HttpClient.httpLbs reqWithMethod manager - let mBodyParser = CT.chooseContentCType ctypes =<< (lookup hContentType $ HttpClient.responseHeaders resp) + let mBodyParser = CT.chooseContentCType ctypes mempty =<< lookup hContentType (HttpClient.responseHeaders resp) case mBodyParser of Just bodyParser -> case bodyParser (HttpClient.responseBody resp) of Right a -> pure a diff --git a/src/Web/Eved/ContentType.hs b/src/Web/Eved/ContentType.hs --- a/src/Web/Eved/ContentType.hs +++ b/src/Web/Eved/ContentType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Web.Eved.ContentType where @@ -15,18 +16,31 @@ import Network.HTTP.Types data ContentType a = ContentType - { toContentType :: a -> LBS.ByteString - , fromContentType :: LBS.ByteString -> Either Text a + { toContentType :: a -> (RequestHeaders, LBS.ByteString) + , fromContentType :: (RequestHeaders, LBS.ByteString) -> Either Text a , mediaTypes :: NonEmpty MediaType } json :: (FromJSON a, ToJSON a, Applicative f) => f (ContentType a) json = pure $ ContentType - { toContentType = encode - , fromContentType = first T.pack . eitherDecode + { toContentType = (mempty,) . encode + , fromContentType = first T.pack . eitherDecode . snd , mediaTypes = NE.fromList ["application" // "json"] } +data WithHeaders a = WithHeaders RequestHeaders a + +addHeaders :: RequestHeaders -> a -> WithHeaders a +addHeaders = WithHeaders + +withHeaders :: Functor f => f (ContentType a) -> f (ContentType (WithHeaders a)) +withHeaders = fmap $ \ctype -> + ContentType + { toContentType = \(WithHeaders rHeaders val) -> (rHeaders, snd $ toContentType ctype val) + , fromContentType = \(rHeaders, rBody) -> fmap (WithHeaders rHeaders) (fromContentType ctype (mempty, rBody)) + , mediaTypes = mediaTypes ctype + } + acceptHeader :: NonEmpty (ContentType a) -> Header acceptHeader ctypes = (hAccept, renderHeader $ NE.toList $ mediaTypes =<< ctypes) @@ -39,10 +53,10 @@ fmap (f ctype) (mediaTypes ctype) ) -chooseAcceptCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (MediaType, a -> LBS.ByteString) +chooseAcceptCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (MediaType, a -> (RequestHeaders, LBS.ByteString)) chooseAcceptCType ctypes = mapAcceptMedia $ collectMediaTypes (\ctype x -> (x, (x, toContentType ctype))) ctypes -chooseContentCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (LBS.ByteString -> Either Text a) -chooseContentCType ctypes = - mapContentMedia $ collectMediaTypes (\ctype x -> (x, fromContentType ctype)) ctypes +chooseContentCType :: NonEmpty (ContentType a) -> RequestHeaders -> BS.ByteString -> Maybe (LBS.ByteString -> Either Text a) +chooseContentCType ctypes rHeaders = + mapContentMedia $ collectMediaTypes (\ctype x -> (x, fromContentType ctype . (rHeaders,))) ctypes diff --git a/src/Web/Eved/Header.hs b/src/Web/Eved/Header.hs new file mode 100644 --- /dev/null +++ b/src/Web/Eved/Header.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Web.Eved.Header + where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Network.HTTP.Types as HTTP +import Web.HttpApiData (FromHttpApiData (parseHeader), + ToHttpApiData (toHeader)) + +data Header a = Header + { toHeaderValue :: a -> Maybe ByteString + , fromHeaderValue :: Maybe ByteString -> Either Text a + } + +auto :: (Applicative f, ToHttpApiData a, FromHttpApiData a) => f (Header a) +auto = pure $ Header + { toHeaderValue = Just . toHeader + , fromHeaderValue = Prelude.maybe (Left "No Header Found") parseHeader + } + +maybe :: Functor f => f (Header a) -> f (Header (Maybe a)) +maybe = fmap $ \h -> + Header + { fromHeaderValue = \case + Just v -> Just <$> fromHeaderValue h (Just v) + Nothing -> pure Nothing + , toHeaderValue = \case + Just a -> toHeaderValue h a + Nothing -> Nothing + } diff --git a/src/Web/Eved/Internal.hs b/src/Web/Eved/Internal.hs --- a/src/Web/Eved/Internal.hs +++ b/src/Web/Eved/Internal.hs @@ -11,6 +11,7 @@ import Data.Text (Text) import Network.HTTP.Types (Status, StdMethod (..), status200) import Web.Eved.ContentType (ContentType) +import Web.Eved.Header (Header) import Web.Eved.QueryParam (QueryParam) import Web.Eved.UrlElement (UrlElement) @@ -24,4 +25,5 @@ capture :: Text -> UrlElement a -> api b -> api (a -> b) reqBody :: NonEmpty (ContentType a) -> api b -> api (a -> b) queryParam :: Text -> QueryParam a -> api b -> api (a -> b) + header :: Text -> Header a -> api b -> api (a -> b) verb :: StdMethod -> Status -> NonEmpty (ContentType a) -> api (m a) diff --git a/src/Web/Eved/Options.hs b/src/Web/Eved/Options.hs --- a/src/Web/Eved/Options.hs +++ b/src/Web/Eved/Options.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,7 +21,7 @@ getOptionsResponse :: EvedOptions m a -> Request -> Response getOptionsResponse api req = - let methods = fmap renderStdMethod $ getAvailableMethods api (pathInfo req) + let methods = renderStdMethod <$> getAvailableMethods api (pathInfo req) headers = [ ("Allow", B.intercalate ", " $ "OPTIONS":methods) ] in responseBuilder status200 headers mempty @@ -35,20 +36,18 @@ left .<|> right = EvedOptions $ \path -> getAvailableMethods left path <> getAvailableMethods right path - lit t next = EvedOptions $ \path -> - case path of - p:rest | p == t -> getAvailableMethods next rest - _ -> mempty + lit t next = EvedOptions $ \case + p:rest | p == t -> getAvailableMethods next rest + _ -> mempty - capture _ _ next = EvedOptions $ \path -> - case path of - _:rest -> getAvailableMethods next rest - _ -> mempty + capture _ _ next = EvedOptions $ \case + _:rest -> getAvailableMethods next rest + _ -> mempty reqBody _ = passthrough queryParam _ _ = passthrough - verb method _ _ = EvedOptions $ \path -> - case path of - [] -> [method] - _ -> mempty + header _ _ = passthrough + verb method _ _ = EvedOptions $ \case + [] -> [method] + _ -> mempty diff --git a/src/Web/Eved/Server.hs b/src/Web/Eved/Server.hs --- a/src/Web/Eved/Server.hs +++ b/src/Web/Eved/Server.hs @@ -4,12 +4,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Web.Eved.Server where -import Control.Applicative ((<|>)) +import Control.Applicative ((<*)) import Control.Exception (Exception, SomeException (..), catch, handle, throwIO, try) import Control.Monad @@ -25,7 +26,9 @@ notFound404, queryToQueryText, renderStdMethod, unsupportedMediaType415) +import qualified Data.CaseInsensitive as CI import qualified Web.Eved.ContentType as CT +import qualified Web.Eved.Header as H import Web.Eved.Internal import qualified Web.Eved.QueryParam as QP import qualified Web.Eved.UrlElement as UE @@ -43,7 +46,6 @@ newtype EvedServerT m a = EvedServerT { unEvedServerT :: (forall a. m a -> IO a) -> [Text] -> RequestData a -> Application } - server :: (forall a. m a -> IO a) -> a -> EvedServerT m a -> Application server nt handlers api req resp = unEvedServerT api nt (pathInfo req) (PureRequestData handlers) req resp @@ -60,6 +62,7 @@ data RoutingError = PathError | CaptureError Text + | HeaderParseError Text | QueryParamParseError Text | NoContentMatchError | NoAcceptMatchError @@ -103,19 +106,19 @@ let mContentTypeBS = lookup hContentType $ requestHeaders req case mContentTypeBS of Just contentTypeBS -> - case CT.chooseContentCType ctypes contentTypeBS of + case CT.chooseContentCType ctypes mempty contentTypeBS of Just bodyParser -> unEvedServerT next nt path (addBodyParser bodyParser action) req Nothing -> \_ -> throwIO NoContentMatchError Nothing -> - unEvedServerT next nt path (addBodyParser (CT.fromContentType (NE.head ctypes)) action) req + unEvedServerT next nt path (addBodyParser (CT.fromContentType (NE.head ctypes) . (mempty,)) action) req where addBodyParser bodyParser action = case action of BodyRequestData fn -> BodyRequestData $ \bodyText -> fn bodyText <*> bodyParser bodyText - PureRequestData v -> BodyRequestData $ \bodyText -> v <$> bodyParser bodyText + PureRequestData v -> BodyRequestData (fmap v . bodyParser) queryParam s qp next = EvedServerT $ \nt path action req -> let queryText = queryToQueryText (queryString req) @@ -124,6 +127,13 @@ Right a -> unEvedServerT next nt path (fmap ($a) action) req Left err -> \_ -> throwIO $ QueryParamParseError err + header headerName h next = EvedServerT $ \nt path action req -> + let ciHeaderName = CI.mk (encodeUtf8 headerName) + mHeader = lookup ciHeaderName (requestHeaders req) + in case H.fromHeaderValue h mHeader of + Right a -> unEvedServerT next nt path (fmap ($ a) action) req + Left err -> \_ -> throwIO $ HeaderParseError err + verb method status ctypes = EvedServerT $ \nt path action req resp -> do unless (null path) $ throwIO PathError @@ -141,7 +151,7 @@ let ctype = NE.head ctypes in pure (NE.head $ CT.mediaTypes ctype, CT.toContentType ctype) - responseData <- + (rHeaders, rBody) <- renderContent <$> case action of BodyRequestData fn -> do reqBody <- lazyRequestBody req @@ -157,7 +167,7 @@ PureRequestData a -> nt a `catch` (\(SomeException e) -> throwIO $ UserApplicationError e) - resp $ responseLBS status [(hContentType, renderHeader ctype)] (renderContent responseData) + resp $ responseLBS status ((hContentType, renderHeader ctype):rHeaders) rBody serverErrorToResponse :: ServerError -> Response serverErrorToResponse err =