eved (empty) → 0.0.1.0
raw patch · 13 files changed
+785/−0 lines, 13 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, http-api-data, http-client, http-media, http-types, mtl, text, wai
Files
- LICENSE +30/−0
- README.md +67/−0
- Setup.hs +2/−0
- eved.cabal +42/−0
- src/Web/Eved.hs +104/−0
- src/Web/Eved/Auth.hs +81/−0
- src/Web/Eved/Client.hs +73/−0
- src/Web/Eved/ContentType.hs +48/−0
- src/Web/Eved/Internal.hs +27/−0
- src/Web/Eved/Options.hs +54/−0
- src/Web/Eved/QueryParam.hs +56/−0
- src/Web/Eved/Server.hs +179/−0
- src/Web/Eved/UrlElement.hs +22/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ben Levy (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,67 @@+# Eved - A Value Level Servant Replacement++Eved is an API definition eDSL in the spirit of [Servant](https://hackage.haskell.org/package/servant). +The main difference from Servant is that Eved is a value level API, whereas Servant relies very heavily on fancy type level programming. ++Eved is highly extensible (both in terms of implementations and new terms) thanks to its utilization of the so called `final tagless` encoding.++## Example++### Api Definition++```haskell+import Data.Text (Text)+import Web.Eved+import qualified Web.Eved.ContentType as CT+import qualified Web.Eved.QueryParam as QP+import qualified Web.Eved.UrlElement as UE++type Api m =+ (Integer -> Integer -> m Integer)+ :<|> (Text -> Integer -> m Integer)+ :<|> (Text -> Integer -> m Integer)++api :: Eved api m => api (Api m)+api =+ (lit "v1" .</> capture "captureNum" UE.integer .</> queryParam "arg1" QP.integer .</> get [CT.json @Integer])+ .<|> (lit "v1" .</> capture "captureText" UE.text .</> reqBody [CT.json @Integer] .</> post [CT.json @Integer])+ .<|> (lit "v2" .</> capture "captureText" UE.text .</> queryParam "arg1" QP.integer .</> get [CT.json @Integer])+```++### Client++```haskell+import Web.Eved.Client++v1CaptureNum :<|> v1CaptureText :<|> v2CaptureText = getClient api "http://localhost:3000"+```++### Server++```haskell+import Control.Monad.IO.Class+import Control.Monad.Reader+import Web.Eved.Server+import Web.Scotty++serve :: IO ()+serve = scotty 3000 $ scottyServer api (`runReaderT` (Env 100)) (pure handlers)++data Env = Env+ { envSecret :: Integer+ }++handlers :: (MonadIO m, MonadReader Env m) => Api m+handlers = (\a b -> pure $ a + b)+ :<|> (\_ i -> fmap ((+) i) (asks envSecret))+ :<|> (\_ i -> pure i)++```++## Prior Art++TODO++## How to extend the language++TODO
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ eved.cabal view
@@ -0,0 +1,42 @@+name: eved+version: 0.0.1.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+license: BSD3+license-file: LICENSE+author: Ben Levy +maintainer: ben@foxhound.systems +copyright: 2021 Ben Levy +category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Web.Eved+ Web.Eved.Auth+ Web.Eved.Client+ Web.Eved.ContentType+ Web.Eved.Internal+ Web.Eved.QueryParam+ Web.Eved.Server+ Web.Eved.Options+ Web.Eved.UrlElement+ build-depends: base >= 4.7 && < 5+ , aeson >=1.3.1.1 && <1.6+ , bytestring >=0.10.8.2 && <0.11+ , http-types >=0.12.2 && <0.13+ , http-media >=0.7.1.3 && <0.9+ , http-client >=0.5.14 && <0.7+ , http-api-data >=0.3.8.1 && <0.5+ , mtl >=2.2.2 && <2.3+ , text >=1.2.3.1 && <1.3+ , wai >=3.2.1.2 && <3.3++ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/foxhound-systems/eved
+ src/Web/Eved.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Web.Eved+ ( I.Eved+ , (I.:<|>)(..)+ , (.</>)+ , (.<|>)+ , lit+ , capture+ , reqBody+ , queryParam+ , verb+ , get+ , post+ , put+ , patch+ , delete+ , runClientIO+ , runClient+ , noContext+ , withContext+ , ClientM+ , EvedServerT+ , server+ )+ where++import Control.Applicative (liftA2)+import Control.Monad.Reader (Reader, runReader)+import Data.Function ((&))+import Data.Functor.Identity (Identity (..))+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Network.HTTP.Types (Status, StdMethod (..), status200)+import Web.Eved.Client+import qualified Web.Eved.ContentType as CT+import qualified Web.Eved.Internal as I+import qualified Web.Eved.QueryParam as QP+import Web.Eved.Server+import qualified Web.Eved.UrlElement as UE+++-- |Unwrap an api that requires no context.+-- If none of the combinators that were used required any context use this function+-- to unwrap the api+noContext :: I.Eved api m => Identity (api a) -> api a+noContext = runIdentity++withContext :: I.Eved api m => ctx -> (ctx -> api a) -> api a+withContext = (&)++-- |Combine two sub-api's by trying the left api first and then the right api second.+(.<|>) :: (I.Eved api m, Applicative f) => f (api a) -> f (api b) -> f (api (a I.:<|> b))+(.<|>) =+ liftA2 (I..<|>)++-- |Add a Literal string to the path of the api+lit :: (I.Eved api m, Applicative f) => Text -> f (api a) -> f (api a)+lit l = fmap (I.lit l)++-- |Add a url capture with a given name and UrlElement decoder/encoder+capture :: (I.Eved api m, Applicative f) => Text -> f (UE.UrlElement a) -> f (api b) -> f (api (a -> b))+capture t u next = I.capture t <$> u <*> next++-- |Add a request body parser for the given content types+-- The Content-Type header will be examined to assist in content negotiation.+reqBody :: (I.Eved api m, Applicative f) => NonEmpty (f (CT.ContentType a)) -> f (api b) -> f (api (a -> b))+reqBody ctyps next = I.reqBody <$> sequenceA ctyps <*> next++-- |A single query param that is required to exist. If the argument is not required use QP.maybe+queryParam :: (I.Eved api m, Applicative f) => Text -> f (QP.QueryParam a) -> f (api b) -> f (api (a -> b))+queryParam t q next = I.queryParam t <$> q <*> next++-- |A list of query params with the same name (may return an empty list if the param is not specified ever)+queryParams :: (I.Eved api m, Applicative f) => Text -> f (QP.QueryParam a) -> f (api b) -> f (api ([a] -> b))+queryParams t q next = I.queryParam t <$> QP.list q <*> next++-- |The leaf node of most routes, this will specify the HTTP Verb and Status along with a list of ContentType encoder/decoders.+-- The Allow header in the request will be examined to determine a suitable response Content-Type+verb :: (I.Eved api m, Applicative f) => StdMethod -> Status -> NonEmpty (f (CT.ContentType a)) -> f (api (m a))+verb m s ctyps = fmap (I.verb m s) (sequenceA ctyps)++get, post, put, patch, delete :: (I.Eved api m, Applicative f) => NonEmpty (f (CT.ContentType a)) -> f (api (m a))+-- | HTTP GET -- see verb for more info+get = verb GET status200+-- | HTTP POST -- see verb for more info+post = verb POST status200+-- | HTTP PUT -- see verb for more info+put = verb PUT status200+-- | HTTP PATCH -- see verb for more info+patch = verb PATCH status200+-- | HTTP DELETE -- see verb for more info+delete = verb DELETE status200++-- |A Segment seperator to be used between path segments akin to / in a url+-- e.g. lit "hello" .</> capture "name" UE.text .</> get [CT.json @Text]+(.</>) :: (Applicative f, I.Eved api m) => (f (api a) -> f (api b)) -> f (api a) -> f (api b)+(.</>) = ($)+infixr 5 .</>+
+ src/Web/Eved/Auth.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Web.Eved.Auth+ where++import qualified Data.ByteString as BS+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Types (hAuthorization, unauthorized401)+import qualified Network.Wai as Wai+import qualified Web.Eved.Client as Client+import Web.Eved.Internal+import qualified Web.Eved.Server as Server++auth :: (Eved api m, EvedAuth api, Applicative f)+ => NonEmpty (f (AuthScheme a)) -> f (api b) -> f (api (a -> b))+auth schemes next = auth_ <$> sequenceA schemes <*> next+++class EvedAuth api where+ auth_ :: NonEmpty (AuthScheme a) -> api b -> api (a -> b)++data AuthResult a+ = AuthSuccess a+ | AuthFailure+ | AuthNeeded++data AuthScheme a = AuthScheme+ { authenticateRequest :: Wai.Request -> AuthResult a+ , addCredentials :: a -> HTTP.Request -> HTTP.Request+ }++data BasicAuth = BasicAuth+ { basicAuthUsername :: Text+ , basicAuthPassword :: Text+ }++basicAuth :: AuthScheme BasicAuth+basicAuth = AuthScheme+ { authenticateRequest = \req ->+ case lookup hAuthorization $ Wai.requestHeaders req of+ Just authHeader ->+ let (authType, rest) = T.breakOn " " $ decodeUtf8 authHeader+ in+ if T.toLower authType == "basic" then+ let (username, rest') = T.breakOn ":" $ T.strip rest+ password = T.drop 1 rest'+ in AuthSuccess (BasicAuth username password)+ else+ AuthNeeded+ Nothing ->+ AuthNeeded+ , addCredentials = \creds ->+ HTTP.applyBasicAuth+ (encodeUtf8 $ basicAuthUsername creds)+ (encodeUtf8 $ basicAuthPassword creds)+ }+++instance EvedAuth Client.EvedClient where+ auth_ (scheme :| _) next = Client.EvedClient $ \req a ->+ Client.client next $ addCredentials scheme a req++instance EvedAuth (Server.EvedServerT m) where+ auth_ schemes next = Server.EvedServerT $ \nt path action req resp ->+ case go req schemes of+ 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)
+ src/Web/Eved/Client.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Eved.Client+ where++import Control.Monad.Reader+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Network.HTTP.Client as HttpClient+import Network.HTTP.Types (hContentType, parseQuery,+ queryTextToQuery, queryToQueryText,+ renderQuery, renderStdMethod)+import qualified Web.Eved.ContentType as CT+import Web.Eved.Internal+import qualified Web.Eved.QueryParam as QP+import qualified Web.Eved.UrlElement as UE+import qualified Web.HttpApiData as HttpApiData++newtype ClientM a = ClientM { unClientM :: ReaderT HttpClient.Manager IO a }++runClientIO :: ClientM a -> IO a+runClientIO m = do+ HttpClient.newManager HttpClient.defaultManagerSettings+ >>= runReaderT (runClient m)++runClient :: (MonadIO m, MonadReader env m, HttpClient.HasHttpManager env) => ClientM a -> m a+runClient (ClientM m) =+ asks HttpClient.getHttpManager >>= (liftIO . runReaderT m)++newtype EvedClient a = EvedClient+ { client :: HttpClient.Request -> a+ }++getClient :: EvedClient a -> Text -> a+getClient (EvedClient f) = f . HttpClient.parseRequest_ . T.unpack++instance Eved EvedClient ClientM where+ l .<|> r = EvedClient $ \req ->+ client l req :<|> client r req++ lit s next = EvedClient $ \req ->+ 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) <> "/" }+ 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+ }+ 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+ in renderQuery False $ queryTextToQuery (newArgs <> queryText)}++ verb method _status ctypes = EvedClient $ \req -> ClientM $ do+ let reqWithMethod = req{ HttpClient.method = renderStdMethod method+ , 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)+ case mBodyParser of+ Just bodyParser -> case bodyParser (HttpClient.responseBody resp) of+ Right a -> pure a+ Left _ -> error "Unimplemented: Content-Type matched but parse failed"+ Nothing -> error "Unimplemented: No Matching Content-Type"+
+ src/Web/Eved/ContentType.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Eved.ContentType+ where++import Control.Monad+import Data.Aeson+import Data.Bifunctor (first)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Media+import Network.HTTP.Types++data ContentType a = ContentType+ { toContentType :: a -> LBS.ByteString+ , fromContentType :: 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+ , mediaTypes = NE.fromList ["application" // "json"]+ }++acceptHeader :: NonEmpty (ContentType a) -> Header+acceptHeader ctypes = (hAccept, renderHeader $ NE.toList $ mediaTypes =<< ctypes)++contentTypeHeader :: ContentType a -> Header+contentTypeHeader ctype = (hContentType, renderHeader $ NE.head $ mediaTypes ctype)++collectMediaTypes :: (ContentType a -> MediaType -> b) -> NonEmpty (ContentType a) -> [b]+collectMediaTypes f ctypes =+ NE.toList $ ctypes >>= (\ctype ->+ fmap (f ctype) (mediaTypes ctype)+ )++chooseAcceptCType :: NonEmpty (ContentType a) -> BS.ByteString -> Maybe (MediaType, a -> 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
+ src/Web/Eved/Internal.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Web.Eved.Internal+ where++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Network.HTTP.Types (Status, StdMethod (..), status200)+import Web.Eved.ContentType (ContentType)+import Web.Eved.QueryParam (QueryParam)+import Web.Eved.UrlElement (UrlElement)++data (:<|>) a b = a :<|> b+infixl 4 :<|>++class Eved api m | api -> m where+ (.<|>) :: api a -> api b -> api (a :<|> b)++ lit :: Text -> api a -> api a+ 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)+ verb :: StdMethod -> Status -> NonEmpty (ContentType a) -> api (m a)
+ src/Web/Eved/Options.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Eved.Options+ where++import qualified Data.ByteString as B+import Data.Coerce (coerce)+import Data.Text (Text)+import Network.HTTP.Types+import Network.Wai+import Web.Eved.Internal++provideOptions :: EvedOptions m a -> Middleware+provideOptions api app req respond+ | requestMethod req == "OPTIONS" = respond (getOptionsResponse api req)+ | otherwise = app req respond++getOptionsResponse :: EvedOptions m a -> Request -> Response+getOptionsResponse api req =+ let methods = fmap renderStdMethod $ getAvailableMethods api (pathInfo req)+ headers = [ ("Allow", B.intercalate ", " $ "OPTIONS":methods) ]+ in responseBuilder status200 headers mempty++newtype EvedOptions (m :: * -> *) a = EvedOptions+ { getAvailableMethods :: [Text] -> [StdMethod]+ }++passthrough :: EvedOptions m a -> EvedOptions m b+passthrough = coerce++instance Eved (EvedOptions m) m where+ 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++ capture _ _ next = EvedOptions $ \path ->+ case path of+ _:rest -> getAvailableMethods next rest+ _ -> mempty++ reqBody _ = passthrough+ queryParam _ _ = passthrough+ verb method _ _ = EvedOptions $ \path ->+ case path of+ [] -> [method]+ _ -> mempty+
+ src/Web/Eved/QueryParam.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Eved.QueryParam+ where++import Data.Text (Text)+import qualified Web.HttpApiData as HttpApiData++data QueryParam a = QueryParam+ { fromQueryParam :: [Text] -> Either Text a+ , toQueryParam :: a -> [Text]+ }++auto :: (Applicative f, HttpApiData.FromHttpApiData a, HttpApiData.ToHttpApiData a) => f (QueryParam a)+auto = pure $ QueryParam+ { fromQueryParam = \case+ [] -> Left "Value not found"+ x:_ -> HttpApiData.parseQueryParam x+ , toQueryParam = pure . HttpApiData.toQueryParam+ }++list :: Functor f => f (QueryParam a) -> f (QueryParam [a])+list = fmap $ \qp ->+ QueryParam+ { fromQueryParam = traverse (fromQueryParam qp . pure)+ , toQueryParam = (=<<) (toQueryParam qp)+ }++defaulted :: Functor f => a -> f (QueryParam a) -> f (QueryParam a)+defaulted defaultValue = fmap $ \qp ->+ QueryParam+ { fromQueryParam = \xs ->+ if null xs+ then pure defaultValue+ else fromQueryParam qp xs+ , toQueryParam = toQueryParam qp+ }++maybe :: Functor f => f (QueryParam a) -> f (QueryParam (Maybe a))+maybe = fmap $ \qp ->+ QueryParam+ { fromQueryParam = \xs ->+ if null xs+ then pure Nothing+ else Just <$> fromQueryParam qp xs+ , toQueryParam = \case+ Just a -> toQueryParam qp a+ Nothing -> []+ }++integer :: Applicative f => f (QueryParam Integer)+integer = auto++text :: Applicative f => f (QueryParam Text)+text = auto+
+ src/Web/Eved/Server.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module Web.Eved.Server+ where++import Control.Applicative ((<|>))+import Control.Exception (Exception, SomeException (..), catch,+ handle, throwIO, try)+import Control.Monad+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Media (renderHeader)+import Network.HTTP.Types (Header, Status, badRequest400, hAccept,+ hContentType, internalServerError500,+ methodNotAllowed405, notAcceptable406,+ notFound404, queryToQueryText,+ renderStdMethod, unsupportedMediaType415)++import qualified Web.Eved.ContentType as CT+import Web.Eved.Internal+import qualified Web.Eved.QueryParam as QP+import qualified Web.Eved.UrlElement as UE+++import Network.Wai (Application, Response, lazyRequestBody,+ pathInfo, queryString, requestHeaders,+ requestMethod, responseLBS)++data RequestData a+ = BodyRequestData (LBS.ByteString -> Either Text a)+ | PureRequestData a+ deriving Functor++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+ `catch` (\case+ PathError -> resp $ responseLBS notFound404 [] "Not Found"+ CaptureError err -> resp $ responseLBS badRequest400 [] (LBS.fromStrict $ encodeUtf8 err)+ QueryParamParseError err -> resp $ responseLBS badRequest400 [] (LBS.fromStrict $ encodeUtf8 err)+ NoContentMatchError -> resp $ responseLBS unsupportedMediaType415 [] "Unsupported Media Type"+ NoAcceptMatchError -> resp $ responseLBS notAcceptable406 [] "Not Acceptable"+ NoMethodMatchError -> resp $ responseLBS methodNotAllowed405 [] "Method Not Allowed")+ `catch` (resp . serverErrorToResponse)+ `catch` (\(UserApplicationError err) -> resp $ serverErrorToResponse $ defaultErrorHandler err)++data RoutingError+ = PathError+ | CaptureError Text+ | QueryParamParseError Text+ | NoContentMatchError+ | NoAcceptMatchError+ | NoMethodMatchError+ deriving (Show, Eq, Ord)++newtype UserApplicationError a = UserApplicationError a+ deriving Show++instance Exception RoutingError+instance Exception a => Exception (UserApplicationError a)++instance Eved (EvedServerT m) m where+ a .<|> b = EvedServerT $ \nt path requestData req resp -> do+ let applicationA = unEvedServerT a nt path (fmap (\(l :<|> _) -> l) requestData)+ applicationB = unEvedServerT b nt path (fmap (\(_ :<|> r) -> r) requestData)+ eApplicationAResult <- try @RoutingError $ applicationA req resp+ case eApplicationAResult of+ Right a -> pure a+ Left errA -> do+ eApplicationBResult <- try @RoutingError $ applicationB req resp+ case eApplicationBResult of+ Right b -> pure b+ Left errB -> if errA > errB then throwIO errA else throwIO errB++ lit s next = EvedServerT $ \nt path action ->+ case path of+ x:rest | x == s -> unEvedServerT next nt rest action+ _ -> \_ _ -> throwIO PathError++ capture _s el next = EvedServerT $ \nt path action ->+ case path of+ x:rest ->+ case UE.fromUrlPiece el x of+ Right arg ->+ unEvedServerT next nt rest $ fmap ($ arg) action+ Left err -> \_ _ -> throwIO $ CaptureError err+ _ -> \_ _ -> throwIO PathError++ reqBody ctypes next = EvedServerT $ \nt path action req -> do+ let mContentTypeBS = lookup hContentType $ requestHeaders req+ case mContentTypeBS of+ Just contentTypeBS ->+ case CT.chooseContentCType ctypes 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++ where+ addBodyParser bodyParser action =+ case action of+ BodyRequestData fn -> BodyRequestData $ \bodyText -> fn bodyText <*> bodyParser bodyText+ PureRequestData v -> BodyRequestData $ \bodyText -> v <$> bodyParser bodyText++ queryParam s qp next = EvedServerT $ \nt path action req ->+ let queryText = queryToQueryText (queryString req)+ params = fromMaybe "true" . snd <$> filter (\(k, _) -> k == s) queryText+ in case QP.fromQueryParam qp params of+ Right a -> unEvedServerT next nt path (fmap ($a) action) req+ Left err -> \_ -> throwIO $ QueryParamParseError err++ verb method status ctypes = EvedServerT $ \nt path action req resp -> do+ unless (null path) $+ throwIO PathError++ unless (renderStdMethod method == requestMethod req) $+ throwIO NoMethodMatchError++ (ctype, renderContent) <-+ case lookup hAccept $ requestHeaders req of+ Just acceptBS ->+ case CT.chooseAcceptCType ctypes acceptBS of+ Just (ctype, renderContent) -> pure (ctype, renderContent)+ Nothing -> throwIO NoAcceptMatchError+ Nothing ->+ let ctype = NE.head ctypes+ in pure (NE.head $ CT.mediaTypes ctype, CT.toContentType ctype)++ responseData <-+ case action of+ BodyRequestData fn -> do+ reqBody <- lazyRequestBody req+ case fn reqBody of+ Right res ->+ nt res `catch` (\(SomeException e) -> throwIO $ UserApplicationError e)+ Left err ->+ throwIO $ ServerError+ { errorStatus = badRequest400+ , errorBody = LBS.fromStrict $ encodeUtf8 err+ , errorHeaders = []+ }+ PureRequestData a ->+ nt a `catch` (\(SomeException e) -> throwIO $ UserApplicationError e)++ resp $ responseLBS status [(hContentType, renderHeader ctype)] (renderContent responseData)++serverErrorToResponse :: ServerError -> Response+serverErrorToResponse err =+ responseLBS (errorStatus err) (errorHeaders err) (errorBody err)++data ServerError = ServerError+ { errorStatus :: Status+ , errorBody :: LBS.ByteString+ , errorHeaders :: [Header]+ } deriving Show+instance Exception ServerError++defaultErrorHandler :: SomeException -> ServerError+defaultErrorHandler _ =+ ServerError+ { errorStatus = internalServerError500+ , errorBody = "Internal Server Error"+ , errorHeaders = []+ }
+ src/Web/Eved/UrlElement.hs view
@@ -0,0 +1,22 @@+module Web.Eved.UrlElement+ where++import Data.Text (Text)+import qualified Web.HttpApiData as HttpApiData++data UrlElement a = UrlElement+ { fromUrlPiece :: Text -> Either Text a+ , toUrlPiece :: a -> Text+ }++auto :: (HttpApiData.FromHttpApiData a, HttpApiData.ToHttpApiData a, Applicative f) => f (UrlElement a)+auto = pure $ UrlElement+ { fromUrlPiece = HttpApiData.parseUrlPiece+ , toUrlPiece = HttpApiData.toUrlPiece+ }++integer :: Applicative f => f (UrlElement Integer)+integer = auto++text :: Applicative f => f (UrlElement Text)+text = auto