eved 0.0.1.1 → 0.0.2.0

raw patch · 8 files changed

+119/−46 lines, 8 filesdep +case-insensitivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive

API changes (from Hackage documentation)

Files

• eved.cabal +3/−1
• src/Web/Eved/Auth.hs +14/−10
• src/Web/Eved/Client.hs +17/−7
• src/Web/Eved/ContentType.hs +22/−8
• src/Web/Eved/Header.hs +32/−0
• src/Web/Eved/Internal.hs +2/−0
• src/Web/Eved/Options.hs +12/−13
• src/Web/Eved/Server.hs +17/−7

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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+        }

@@ -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)

@@ -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 

@@ -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 =