mig 0.1.0.1 → 0.1.0.2

raw patch · 9 files changed

+94/−143 lines, 9 filesdep +case-insensitivedep +http-api-datadep −randomdep −wai-extraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive, http-api-data

Dependencies removed: random, wai-extra

API changes (from Hackage documentation)

Files

• README.md +10/−9
• mig.cabal +3/−3
• src/Mig.hs +21/−60
• src/Mig/Common.hs +3/−3
• src/Mig/Html.hs +7/−10
• src/Mig/Html/IO.hs +7/−10
• src/Mig/Internal/Types.hs +29/−28
• src/Mig/Json.hs +7/−10
• src/Mig/Json/IO.hs +7/−10

@@ -164,16 +164,17 @@  We have newtypes for: -* `Query "name" type` - required query parameter-* `Optional "name" type` - optional query parameter-* `Capture type` - capture part of the URI between slashes `/`.-* `Body type` - input JSON body-* `RawBody` - input body as raw lazy bytestring-* `RawFormData` - input of the html-form-* `FormJson` - input f html-form as Json (see examples/Html.hs)-* `Header "name"` - access header by name-* `PathInfo` - access path info relative to the server+* `Query "name" type` - required query parameter (`FromHttpApiData`)+* `Optional "name" type` - optional query parameter (`FromHttpApiData`)+* `Capture type` - capture part of the URI between slashes `/`. (`FromHttpApiData`)+* `Body type` - input JSON body (`FromJSON`)+* `RawBody` - input body as raw lazy bytestring (is `ByteString`)+* `FormBody` - input URL-encoded form (it often comes from HTML-forms) (`FromForm`)+* `Header "name" ty` - access header by name (`FromHttpApiData`)+* `PathInfo` - access path info relative to the server (is `[Text]`) +Class at in the parens is which class is used for convertion.+Often we can derive the instance of that class with newtype-deriving or with Generic-deriving. We can change the number of arguments because the function `(/.)` is overloaded by second argument and it can accept anything convertible to `Server` or an instance of the class `ToServer`.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mig-version:        0.1.0.1+version:        0.1.0.2 synopsis:       Build lightweight and composable servers description:    With library mig we can build lightweight and composable servers.                 There are only couple of combinators to assemble servers from parts.@@ -105,13 +105,13 @@     , blaze-html     , blaze-markup     , bytestring+    , case-insensitive     , containers     , exceptions+    , http-api-data     , http-types     , mtl-    , random     , text     , wai-    , wai-extra     , warp   default-language: GHC2021

@@ -41,9 +41,7 @@   , Body (..)   , RawBody (..)   , Header (..)-  , RawFormData (..)   , FormBody (..)-  , FormJson (..)   , PathInfo (..)    -- ** response@@ -87,7 +85,8 @@ import Mig.Internal.Types import Mig.Internal.Types qualified as Resp (Resp (..)) -+import Web.HttpApiData as X+import Web.FormUrlEncoded as X import Data.Bifunctor import Data.Kind import Data.String@@ -113,7 +112,6 @@ import Network.Wai.Handler.Warp qualified as Warp import Control.Exception (throw) import Data.Typeable-import Data.Aeson.Key qualified as Json  -- | Path constructor (right associative). Example: --@@ -172,19 +170,19 @@ toWithQuery name act = Server $ \req ->   unServer (act (Map.lookup name req.query)) req -withQuery' :: FromText a => QueryName a -> (Maybe a -> Server m) -> Server m+withQuery' :: FromHttpApiData a => QueryName a -> (Maybe a -> Server m) -> Server m withQuery' (QueryName name) act = toWithQuery (Text.encodeUtf8 name) $ \mVal ->   let     -- TODO: do not ignore parse failure-    mArg = fromText =<< either (const Nothing) Just . Text.decodeUtf8' =<< mVal+    mArg = either (const Nothing) Just . (parseQueryParam <=< first (Text.pack . show) . Text.decodeUtf8') =<< mVal   in     act mArg -withQuery :: (Applicative m, FromText a) => QueryName a -> (a -> Server m) -> Server m+withQuery :: (Applicative m, FromHttpApiData a) => QueryName a -> (a -> Server m) -> Server m withQuery (QueryName name) act = toWithQuery (Text.encodeUtf8 name) $ \mVal ->   let     -- TODO: do not ignore parse failure-    mArg = fromText =<< either (const Nothing) Just . Text.decodeUtf8' =<< mVal+    mArg = either (const Nothing) Just . (parseQueryParam <=< first (Text.pack . show) . Text.decodeUtf8') =<< mVal   in     case mArg of       Just arg -> act arg@@ -507,7 +505,7 @@ -- > handleFoo (Query arg) = ... newtype Query (sym :: Symbol) a = Query a -instance (FromText a, ToServer b, KnownSymbol sym) => ToServer (Query sym a -> b) where+instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Query sym a -> b) where   type ServerMonad (Query sym a -> b) = ServerMonad b   toServer act = withQuery (QueryName (Text.pack $ symbolVal (Proxy @sym))) (toServer . act . Query) @@ -521,11 +519,11 @@ -- > handleFoo (Optional maybeArg) = ... newtype Optional (sym :: Symbol) a = Optional (Maybe a) -instance (FromText a, ToServer b, KnownSymbol sym) => ToServer (Optional sym a -> b) where+instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Optional sym a -> b) where   type ServerMonad (Optional sym a -> b) = ServerMonad b   toServer act = withQuery' (QueryName (fromString $ symbolVal (Proxy @sym))) (toServer . act . Optional) --- Capture+-- | Capture  -- Captures part of the path. Example --@@ -534,12 +532,12 @@ -- It will parse the paths: "api/foo/358" and pass 358 to @handleFoo@. newtype Capture a = Capture a -instance (FromText a, ToServer b) => ToServer (Capture a -> b) where+instance (FromHttpApiData a, ToServer b) => ToServer (Capture a -> b) where   type ServerMonad (Capture a -> b) = ServerMonad b   toServer act = toWithCapture $ \txt ->-    case fromText txt of-      Just val -> toServer $ act $ Capture val-      Nothing -> toConst $ pure $ badRequest "Failed to parse capture"+    case parseUrlPiece txt of+      Right val -> toServer $ act $ Capture val+      Left err -> toConst $ pure $ badRequest ("Failed to parse capture: " <> err)  -- Read Body input @@ -564,49 +562,12 @@   type ServerMonad (RawBody -> b) = ServerMonad b   toServer act = toWithBody $ toServer . act . RawBody --- | Parse raw form body. It includes named form arguments and file info.--- Note that we can not use FormBody and JSON-body at the same time.--- They occupy the same field in the HTTP-request.-newtype RawFormData = RawFormData FormBody--instance (ToServer b, MonadIO (ServerMonad b)) => ToServer (RawFormData -> b) where-  type ServerMonad (RawFormData -> b) = ServerMonad b-  toServer act = toWithFormData $ toServer . act . RawFormData---- | It reads form as plain JSON-object where name of the form's field becomes--- a field of JSON-object and every value is Text.------ For example if submit a form with fields: name, password, date.--- We can read it in the data type:------ > data User = User--- >  { name :: Text--- >  , passord :: Text--- >  , date :: Text--- >  }------ Note that we can not use FormBody and JSON-body at the same time.--- They occupy the same field in the HTTP-request.-newtype FormJson a = FormJson a--instance (ToServer b, MonadIO (ServerMonad b), FromJSON a) => ToServer (FormJson a -> b) where-  type ServerMonad (FormJson a -> b) = ServerMonad b-  toServer act = toWithFormData $ \formBody -> do-    case formDataToJson formBody.params of-      Right v -> toServer $ act $ FormJson v-      Left err -> toConst $-        pure $ badRequest $ "Failed to parse form data as JSON body: " <> err+-- | Reads the URL encoded Form input+newtype FormBody a = FormBody a -formDataToJson :: FromJSON a => [(ByteString, ByteString)] -> Either Text a-formDataToJson rawPairs = do-  jsonVal <- Json.object <$> mapM toPair rawPairs-  case Json.fromJSON jsonVal of-    Json.Success result -> Right result-    Json.Error err -> Left (Text.pack $ show err)-  where-    toPair (key, val) =-      first (Text.pack . show) $-        (\k v -> (Json.fromText k, Json.String v)) <$> Text.decodeUtf8' key <*> Text.decodeUtf8' val+instance (ToServer b, MonadIO (ServerMonad b), FromForm a) => ToServer (FormBody a -> b) where+  type ServerMonad (FormBody a -> b) = ServerMonad b+  toServer act = toWithFormData (toServer . act . FormBody)  -- Request Headers @@ -615,10 +576,10 @@ -- > "api" /. (\(Header @"Trace-Id" traceId) -> Post @Json (handleFoo traceId)) -- > -- > handleFoo :: Maybe ByteString -> IO FooResponse-newtype Header (sym :: Symbol) = Header (Maybe ByteString)+newtype Header (sym :: Symbol) a = Header (Maybe a) -instance (ToServer b, KnownSymbol sym) => ToServer (Header sym -> b) where-  type ServerMonad (Header sym -> b) = ServerMonad b+instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Header sym a -> b) where+  type ServerMonad (Header sym a -> b) = ServerMonad b   toServer act = toWithHeader (fromString $ symbolVal (Proxy @sym)) (toServer . act . Header)  -- | Reads current path info

@@ -16,9 +16,7 @@   , Body (..)   , RawBody (..)   , Header (..)-  , RawFormData (..)   , FormBody (..)-  , FormJson (..)   , PathInfo (..)    -- * response@@ -46,7 +44,9 @@  import Mig   ( Server (..), ToServer (..), ToText (..), ToHtmlResp (..), FromText (..), handleError, PathInfo (..)-  , (/.), Capture (..), Query (..), Optional (..), Body (..), RawBody (..), Header (..), RawFormData (..), FormBody (..), FormJson (..), AddHeaders (..), SetStatus (..)+  , (/.), Capture (..), Query (..), Optional (..), Body (..), RawBody (..), Header (..), FormBody (..), AddHeaders (..), SetStatus (..)   , setStatus, addHeaders, HasServer (..), fromReader, ServerConfig (..), toApplication, runServer, badRequest, Error (..), withServerAction)  import Network.HTTP.Types.Status as X+import Web.HttpApiData as X+import Web.FormUrlEncoded as X

@@ -20,46 +20,43 @@  -- Get +-- | Get method. Note that we can not use body input with Get-method, use Post for that.+-- So with Get we can use only URI inputs (Query, Optional, Capture) newtype Get m a = Get (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Get m a) where   type ServerMonad (Get m a) = m   toServer (Get act) = toMethod methodGet (toHtmlResp <$> act) --- Post-+-- | Post method newtype Post m a = Post (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Post m a) where   type ServerMonad (Post m a) = m   toServer (Post act) = toMethod methodPost (toHtmlResp <$> act) --- Put-+-- | Put method newtype Put m a = Put (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Put m a) where   type ServerMonad (Put m a) = m   toServer (Put act) = toMethod methodPut (toHtmlResp <$> act) --- Delete-+-- | Delete method newtype Delete m a = Delete (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Delete m a) where   type ServerMonad (Delete m a) = m   toServer (Delete act) = toMethod methodDelete (toHtmlResp <$> act) --- Patch-+-- | Patch method newtype Patch m a = Patch (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Patch m a) where   type ServerMonad (Patch m a) = m   toServer (Patch act) = toMethod methodPatch (toHtmlResp <$> act) --- Options-+-- | Options method newtype Options m a = Options (m a)  instance (Monad m, ToHtmlResp a) => ToServer (Options m a) where

@@ -20,46 +20,43 @@  -- Get +-- | Get method. Note that we can not use body input with Get-method, use Post for that.+-- So with Get we can use only URI inputs (Query, Optional, Capture) newtype Get a = Get (IO a)  instance (ToHtmlResp a) => ToServer (Get a) where   type ServerMonad (Get a) = IO   toServer (Get act) = toMethod methodGet (toHtmlResp <$> act) --- Post-+-- | Post method newtype Post a = Post (IO a)  instance (ToHtmlResp a) => ToServer (Post a) where   type ServerMonad (Post a) = IO   toServer (Post act) = toMethod methodPost (toHtmlResp <$> act) --- Put-+-- | Put method newtype Put a = Put (IO a)  instance (ToHtmlResp a) => ToServer (Put a) where   type ServerMonad (Put a) = IO   toServer (Put act) = toMethod methodPut (toHtmlResp <$> act) --- Delete-+-- | Delete method newtype Delete a = Delete (IO a)  instance (ToHtmlResp a) => ToServer (Delete a) where   type ServerMonad (Delete a) = IO   toServer (Delete act) = toMethod methodDelete (toHtmlResp <$> act) --- Patch-+-- | Patch method newtype Patch a = Patch (IO a)  instance (ToHtmlResp a) => ToServer (Patch a) where   type ServerMonad (Patch a) = IO   toServer (Patch act) = toMethod methodPatch (toHtmlResp <$> act) --- Options-+-- | Options method newtype Options a = Options (IO a)  instance (ToHtmlResp a) => ToServer (Options a) where

@@ -17,7 +17,6 @@   , toWithHeader   , toWithFormData   , toWithPathInfo-  , FormBody (..)   -- * responses   , text   , json@@ -67,7 +66,10 @@ import Control.Monad.IO.Class import Control.Monad.Catch import Data.Typeable-import Network.Wai.Parse qualified as Parse+import Web.FormUrlEncoded+import Web.HttpApiData+import Data.Either (fromRight)+import Data.CaseInsensitive qualified as CI  -- | Http response data Resp = Resp@@ -103,14 +105,8 @@     -- ^ request method   , readBody :: IO (Either (Error Text) BL.ByteString)     -- ^ lazy body reader. Error can happen if size is too big (configured on running the server)-  , readFormBody :: IO (Either (Error Text) FormBody)   } -data FormBody = FormBody-  { params :: [(ByteString, ByteString)]-  , files :: [(ByteString, Parse.FileInfo BL.ByteString)]-  }- -- Errors  -- | Errors@@ -181,9 +177,11 @@ -- * @Either (Error err)@ - to response with errors newtype Server m = Server { unServer :: Req -> m (Maybe Resp) } +-- | Replies to any http-method toConst :: Functor m => m Resp -> Server m toConst act = Server $ const $ Just <$> act +-- | Specify which method to reply toMethod :: Monad m => Method -> m Resp -> Server m toMethod method act = Server $ checkMethod method act @@ -192,6 +190,7 @@   | null req.path && req.method == method = Just <$> act   | otherwise = pure Nothing +-- | Reads full body as lazy bytestring toWithBody :: MonadIO m => (BL.ByteString -> Server m) -> Server m toWithBody act = Server $ \req -> do   eBody <- liftIO req.readBody@@ -199,14 +198,13 @@     Right body -> unServer (act body) req     Left err -> pure $ Just $ setRespStatus err.status (text err.body) --- TODO: make it size limited by HTTP-body size-toWithFormData :: MonadIO m => (FormBody -> Server m) -> Server m+-- | Reads URL-encoded form data+toWithFormData :: (FromForm a, MonadIO m) => (a -> Server m) -> Server m toWithFormData act = Server $ \req -> do-  eFormBody <- liftIO req.readFormBody-  case eFormBody of-    Right formBody -> unServer (act formBody) req-    Left err -> pure $ Just $ setRespStatus err.status (text err.body)-+  eBody <- first (\(Error _ details) -> details) <$> liftIO req.readBody+  case eBody >>= urlDecodeForm >>= fromForm of+    Right a -> unServer (act a) req+    Left err -> pure $ Just $ setRespStatus status413 $ badRequest err  -- | Size of the input body type Kilobytes = Int@@ -231,6 +229,7 @@       Just size -> \current -> current > size       Nothing -> const False +-- | Match path prefix toWithPath :: Monad m => Text -> Server m -> Server m toWithPath route act = Server $ \req ->   case hasPath route req.path of@@ -245,22 +244,34 @@   | otherwise = Nothing hasPath _ _ = Nothing +-- | Reads capture URL-piece element toWithCapture :: Monad m => (Text -> Server m) -> Server m toWithCapture act = Server $ \req ->   case pathHead req of     Just (arg, nextReq) -> unServer (act arg) nextReq     Nothing -> pure Nothing +-- | Match on path prefix pathHead :: Req -> Maybe (Text, Req) pathHead req =   case req.path of     hd : tl -> Just (hd, req { path = tl })     _ -> Nothing -toWithHeader :: HeaderName -> (Maybe ByteString -> Server m) -> Server m+-- | Read info from header+toWithHeader :: (Monad m, FromHttpApiData a) => HeaderName -> (Maybe a -> Server m) -> Server m toWithHeader name act = Server $ \req ->-  unServer (act (fmap snd $ List.find ((== name) . fst) req.headers)) req+  case fmap snd $ List.find ((== name) . fst) req.headers of+    Just bs ->+      case parseHeader bs of+        Right val -> unServer (act (Just val)) req+        Left err -> pure $ Just $ badRequest (errMessage err)+    Nothing -> unServer (act Nothing) req+  where+    errMessage :: Text -> Text+    errMessage err = "Failed to parse header " <> (fromRight "" $ Text.decodeUtf8' $ CI.original name) <> ": " <> err +-- | reads path info toWithPathInfo :: ([Text] -> Server m) -> Server m toWithPathInfo act = Server $ \req ->   unServer (act req.path) req@@ -298,6 +309,7 @@ setContent contentType =   [("Content-Type", contentType <>"; charset=utf-8")] +-- | Sets response status setRespStatus :: Status -> Resp -> Resp setRespStatus status (Resp _ headers body) = Resp status headers body @@ -368,16 +380,5 @@     , headers = requestHeaders req     , method = requestMethod req     , readBody = fmap (fmap BL.fromChunks) $ readRequestBody (getRequestBodyChunk req) maxSize-    , readFormBody = getReadFormBody req     }--getReadFormBody :: Request -> IO (Either (Error Text) FormBody)-getReadFormBody req = do-  case Parse.getRequestBodyType req of-    Nothing -> pure $ Right (FormBody [] [])-    Just reqBodyType -> do-      eResult <- try @IO @SomeException (Parse.sinkRequestBody Parse.lbsBackEnd reqBodyType (getRequestBodyChunk req))-      pure $ bimap (const toError) (uncurry FormBody) eResult-  where-    toError = Error status413 (Text.pack $ "Request is too big!") 

@@ -21,46 +21,43 @@  -- Get +-- | Get method. Note that we can not use body input with Get-method, use Post for that.+-- So with Get we can use only URI inputs (Query, Optional, Capture) newtype Get m a = Get (m a)  instance (Monad m, ToJsonResp a) => ToServer (Get m a) where   type ServerMonad (Get m a) = m   toServer (Get act) = toMethod methodGet (toJsonResp <$> act) --- Post-+-- | Post method newtype Post m a = Post (m a)  instance (Monad m, ToJsonResp a) => ToServer (Post m a) where   type ServerMonad (Post m a) = m   toServer (Post act) = toMethod methodPost (toJsonResp <$> act) --- Put-+-- | Put method newtype Put m a = Put (m a)  instance (Monad m, ToJsonResp a) => ToServer (Put m a) where   type ServerMonad (Put m a) = m   toServer (Put act) = toMethod methodPut (toJsonResp <$> act) --- Delete-+-- | Delete method newtype Delete m a = Delete (m a)  instance (Monad m, ToJsonResp a) => ToServer (Delete m a) where   type ServerMonad (Delete m a) = m   toServer (Delete act) = toMethod methodDelete (toJsonResp <$> act) --- Patch-+-- | Patch method newtype Patch m a = Patch (m a)  instance (Monad m, ToJsonResp a) => ToServer (Patch m a) where   type ServerMonad (Patch m a) = m   toServer (Patch act) = toMethod methodPatch (toJsonResp <$> act) --- Options-+-- | Options method newtype Options m a = Options (m a)  instance (Monad m, ToJsonResp a) => ToServer (Options m a) where

@@ -21,46 +21,43 @@  -- Get +-- | Get method. Note that we can not use body input with Get-method, use Post for that.+-- So with Get we can use only URI inputs (Query, Optional, Capture) newtype Get a = Get (IO a)  instance (ToJsonResp a) => ToServer (Get a) where   type ServerMonad (Get a) = IO   toServer (Get act) = toMethod methodGet (toJsonResp <$> act) --- Post-+-- | Post method newtype Post a = Post (IO a)  instance (ToJsonResp a) => ToServer (Post a) where   type ServerMonad (Post a) = IO   toServer (Post act) = toMethod methodPost (toJsonResp <$> act) --- Put-+-- | Put method newtype Put a = Put (IO a)  instance (ToJsonResp a) => ToServer (Put a) where   type ServerMonad (Put a) = IO   toServer (Put act) = toMethod methodPut (toJsonResp <$> act) --- Delete-+-- | Delete method newtype Delete a = Delete (IO a)  instance (ToJsonResp a) => ToServer (Delete a) where   type ServerMonad (Delete a) = IO   toServer (Delete act) = toMethod methodDelete (toJsonResp <$> act) --- Patch-+-- | Patch method newtype Patch a = Patch (IO a)  instance (ToJsonResp a) => ToServer (Patch a) where   type ServerMonad (Patch a) = IO   toServer (Patch act) = toMethod methodPatch (toJsonResp <$> act) --- Options-+-- | Options method newtype Options a = Options (IO a)  instance (ToJsonResp a) => ToServer (Options a) where