minion-wai-extra (empty) → 0.1.0.0
raw patch · 9 files changed
+502/−0 lines, 9 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, http-media, http-types, minion, minion-wai-extra, resourcet, string-conversions, text, transformers, wai, wai-extra, warp
Files
- LICENSE +20/−0
- README.md +45/−0
- app/Multipart.hs +9/−0
- app/ServerEvent.hs +9/−0
- minion-wai-extra.cabal +98/−0
- src/Web/Minion/Examples/Multipart.hs +74/−0
- src/Web/Minion/Examples/ServerEvent.hs +42/−0
- src/Web/Minion/Request/Multipart.hs +163/−0
- src/Web/Minion/Response/ServerEvent.hs +42/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 goosedb++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,45 @@+# Minion++Minion is Haskell library for developing web applications. It stands between [Scotty](https://hackage.haskell.org/package/scotty) and [Servant](https://hackage.haskell.org/package/servant-server) ++| | Scotty | Minion | Servant |+| ---------------- | ------ | ------ | ------- |+| As simple as ABC | Yes | No | No |+| At term level | Yes | Yes | No |+| Typesafe | No | Yes | Yes |+| Introspectable | No | Yes | Yes |+| Generated client | No | No | Yes |++ +Since Minion defines servers at the term level, it's easier to start and without excess verbosity.++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Main where++import Web.Minion+import Network.Wai.Handler.Warp qualified as Warp++main :: IO ()+main = Warp.run 9001 app++app :: ApplicationM IO+app = serve api ++api :: Router Void IO+api = "api" /> + [ "about" /> handlePlainText @String GET (pure "Hello-World Minion server")+ , "hello" /> capture @String "name" + .> handlePlainText @String GET (\name -> pure $ "Hello, " <> name <> "!")+ ]+```++Documentation and examples can be found on [Hackage](https://hackage.haskell.org/package/minion) ++Minion ecosystem also contains following libraries:+* [minion-conduit](https://hackage.haskell.org/package/minion-conduit) +* [minion-htmx](https://hackage.haskell.org/package/minion-htmx) +* [minion-jwt](https://hackage.haskell.org/package/minion-jwt) +* [minion-wai-extra](https://hackage.haskell.org/package/minion-wai-extra) +* [minion-openapi3](https://hackage.haskell.org/package/minion-openapi3)
+ app/Multipart.hs view
@@ -0,0 +1,9 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.Multipart qualified++main :: IO ()+main = do+ app <- Web.Minion.Examples.Multipart.app+ Warp.run 9001 app
+ app/ServerEvent.hs view
@@ -0,0 +1,9 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.ServerEvent qualified++main :: IO ()+main = do+ app <- Web.Minion.Examples.ServerEvent.app+ Warp.run 9001 app
+ minion-wai-extra.cabal view
@@ -0,0 +1,98 @@+cabal-version: 3.0+name: minion-wai-extra+version: 0.1.0.0+license: MIT+license-file: LICENSE+author: goosedb+maintainer: goosedb@yandex.ru+category: Web+synopsis: Minion wrappers for wai-extra+build-type: Simple+extra-source-files: README.md++common common+ ghc-options: -Wall+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingStrategies+ DuplicateRecordFields+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ OverloadedLists+ OverloadedRecordDot+ OverloadedRecordDot+ OverloadedStrings+ PolyKinds+ RankNTypes+ RecordWildCards+ RoleAnnotations+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++library+ import: common+ exposed-modules:+ Web.Minion.Examples.Multipart+ Web.Minion.Examples.ServerEvent+ Web.Minion.Request.Multipart+ Web.Minion.Response.ServerEvent++ build-depends:+ , base >= 4.16 && < 5+ , binary+ , bytestring+ , http-media+ , http-types+ , minion+ , resourcet+ , string-conversions+ , text+ , transformers+ , wai+ , wai-extra++ hs-source-dirs: src+ default-language: Haskell2010++executable minion-wai-extra-server-event-example+ import: common+ main-is: ServerEvent.hs+ build-depends:+ , base+ , minion-wai-extra+ , warp++ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options: -threaded++executable minion-wai-extra-multipart-example+ import: common+ main-is: Multipart.hs+ build-depends:+ , base+ , minion-wai-extra+ , warp++ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options: -threaded
+ src/Web/Minion/Examples/Multipart.hs view
@@ -0,0 +1,74 @@+module Web.Minion.Examples.Multipart (app) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encode+import Data.Void+import Network.Wai.Parse (FileInfo (..))+import System.Environment (getArgs)+import Web.Minion+import Web.Minion.Request.Multipart++app :: IO (ApplicationM IO)+app =+ getArgs >>= \case+ ["tmp"] -> do+ putStrLn "Tmp mode running"+ pure do+ serve apiMem+ ["mem"] -> do+ putStrLn "Mem mode running"+ pure do+ \req resp -> runResourceT (serve apiTmp req resp)+ _ -> error "Mode required"++data ReportMem = ReportMem+ { reporter :: Text+ , report :: Bytes.Lazy.ByteString+ }++data ReportTmp = ReportTmp+ { reporter :: Text+ , report :: FilePath+ }++instance FromMultipart Mem ReportMem where+ fromMultipart =+ ReportMem+ <$> (Text.Encode.decodeUtf8 <$> getParam "reporter")+ <*> (fileContent <$> getFile "report")++instance FromMultipart Tmp ReportTmp where+ fromMultipart =+ ReportTmp+ <$> (Text.Encode.decodeUtf8 <$> getParam "reporter")+ <*> (fileContent <$> getFile "report")++apiMem :: Router Void IO+apiMem =+ "api"+ /> "multipart"+ /> multipartBody @Mem @ReportMem+ .> handle @NoBody POST endpoint+ where+ endpoint ReportMem{..} = do+ putStrLn $ "Reporter: " <> Text.unpack reporter+ putStrLn $ "Report size: " <> show (Bytes.Lazy.length report)+ pure NoBody++-- multipartBody @Tmp requires MonadResource+apiTmp :: Router Void (ResourceT IO)+apiTmp =+ "api"+ /> "multipart"+ /> multipartBody @Tmp @ReportTmp+ .> handle @NoBody POST endpoint+ where+ endpoint ReportTmp{..} = liftIO do+ putStrLn $ "Reporter: " <> Text.unpack reporter+ reportSize <- Bytes.Lazy.length <$> Bytes.Lazy.readFile report+ putStrLn $ "Report size: " <> show reportSize+ pure NoBody
+ src/Web/Minion/Examples/ServerEvent.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.Minion.Examples.ServerEvent (app) where++import Control.Concurrent (Chan, forkIO, newChan, readChan, writeChan)+import Control.Monad (forever)+import Control.Monad.Trans.Reader+import Data.Binary.Builder as Binary+import Web.Minion+import Web.Minion.Response.ServerEvent++{- FOURMOLU_DISABLE -}+-- The server accepts strings from the console and sends them to clients via SSE.+-- $ cabal run minion-wai-extra-sse-example -v0 |+-- | $ curl localhost:9001/api/sse+-- hello |+-- | event:typed_string+-- | data:hello+-- how are you |+-- | event:typed_string+-- | data:how are you+-- ^C |+-- | curl: (18) transfer closed with outstanding read data remaining+{- FOURMOLU_ENABLE -}+app :: IO (ApplicationM IO)+app = do+ chan <- newChan @String+ _ <- forkIO $ forever do+ getLine >>= writeChan chan+ pure $ \req resp -> runReaderT (serve api req resp) chan++api :: Router Void (ReaderT (Chan String) IO)+api = "api" /> "sse" /> handle GET sse++sse :: ReaderT (Chan String) IO (EventSource ServerEvent)+sse = do+ chan <- ask+ pure $ EventSource do+ ServerEvent (Just $ Binary.putStringUtf8 "typed_string") Nothing+ . pure+ . Binary.putStringUtf8+ <$> readChan chan
+ src/Web/Minion/Request/Multipart.hs view
@@ -0,0 +1,163 @@+module Web.Minion.Request.Multipart (+ Multipart (..),+ multipartBody,+ Backend (..),+ Tmp,+ Mem,+ MultipartData (..),+ FromMultipart (..),+ MultipartM,+ getParam,+ lookupParam,+ getFile,+ lookupFile,+ Wai.File,+ Wai.Param,+) where++import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Kind (Type)+import Network.Wai.Parse qualified as Wai++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.Trans.Except (Except, except, runExcept)+import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)+import Control.Monad.Trans.Resource+import Data.ByteString qualified as Bytes+import Data.String.Conversions (ConvertibleStrings (..))+import Data.Text (Text)+import Data.Text.Encoding qualified as Text.Encode+import Network.HTTP.Types qualified as Http+import Web.Minion.Args (WithReq)+import Web.Minion.Introspect qualified as I+import Web.Minion.Request (IsRequest (..))+import Web.Minion.Router++data Tmp+data Mem++newtype Multipart backend a = Multipart a++instance IsRequest (Multipart backend a) where+ type RequestValue (Multipart backend a) = a+ getRequestValue (Multipart a) = a++type MultipartM backend = ReaderT (MultipartData backend) (Except Text)++class (MonadIO m) => Backend m backend where+ type BackendFile backend :: Type+ waiBackend :: m (Wai.BackEnd (BackendFile backend))++instance (MonadResource m) => Backend m Tmp where+ type BackendFile Tmp = FilePath+ waiBackend = liftResourceT do+ Wai.tempFileBackEnd <$> getInternalState++instance (MonadIO m) => Backend m Mem where+ type BackendFile Mem = Bytes.Lazy.ByteString+ waiBackend = pure Wai.lbsBackEnd++data MultipartData backend = MultipartData+ { params :: [Wai.Param]+ , files :: [Wai.File (BackendFile backend)]+ }++class FromMultipart backend a where+ fromMultipart :: MultipartM backend a++instance FromMultipart backend (MultipartData backend) where+ fromMultipart = ask++{- | Extracts multipart data from request body++@+... /> 'multipartBody' \@'Tmp' @Foo .> ...+@+-}+multipartBody ::+ forall backend r m i ts.+ (I.Introspection i I.Request (Multipart backend r)) =>+ (MonadThrow m) =>+ (FromMultipart backend r) =>+ (Backend m backend) =>+ -- | .+ ValueCombinator i (WithReq m (Multipart backend r)) ts m+multipartBody = Request \makeError req -> do+ backend <- (waiBackend @m @backend)+ (params, files) <- liftIO $ Wai.parseRequestBody backend req+ case runExcept $ runReaderT (fromMultipart @backend @r) MultipartData{..} of+ Left e -> throwM $ makeError req Http.status400 (convertString e)+ Right v -> pure $ Multipart v++{- |+@+instance 'FromMultipart' 'Tmp' MyData where+ 'fromMultipart' = do+ param1 <- 'getParam' "param1"+ param2 <- 'getParam' "param2"+ pure MyData {..}+@+-}+getParam :: Bytes.ByteString -> MultipartM backend Bytes.ByteString+getParam a =+ ask+ >>= lift+ . except+ . maybe (Left $ ("Param not found: " <>) $ Text.Encode.decodeUtf8 a) Right+ . lookup a+ . params++{- |+@+instance 'FromMultipart' 'Tmp' MyData where+ 'fromMultipart' = do+ param1 <- 'getParam' "param1"+ param2 <- 'getParam' "param2"+ pure MyData {..}+@+-}+lookupParam :: Bytes.ByteString -> MultipartM backend (Maybe Bytes.ByteString)+lookupParam a =+ ask+ >>= lift+ . except+ . Right+ . lookup a+ . params++{- |+@+instance 'FromMultipart' 'Tmp' MyData where+ 'fromMultipart' = do+ file1 <- 'lookupFile' "file1"+ file2 <- 'lookupFile' "file2"+ pure MyData {..}+@+-}+lookupFile :: Bytes.ByteString -> MultipartM backend (Maybe (Wai.FileInfo (BackendFile backend)))+lookupFile a =+ ask+ >>= lift+ . except+ . Right+ . lookup a+ . files++{- |+@+instance 'FromMultipart' 'Tmp' MyData where+ 'fromMultipart' = do+ file1 <- 'getFile' "file1"+ file2 <- 'getFile' "file2"+ pure MyData {..}+@+-}+getFile :: Bytes.ByteString -> MultipartM backend (Wai.FileInfo (BackendFile backend))+getFile a =+ ask+ >>= lift+ . except+ . maybe (Left $ ("File not found: " <>) $ Text.Encode.decodeUtf8 a) Right+ . lookup a+ . files
+ src/Web/Minion/Response/ServerEvent.hs view
@@ -0,0 +1,42 @@+module Web.Minion.Response.ServerEvent (+ EventSource (..),+ ToServerEvent (..),+ Wai.ServerEvent (..),+) where++import Data.Function (fix)+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Network.Wai.EventSource qualified as Wai+import Network.Wai.EventSource.EventStream qualified as Wai+import Web.Minion++import Data.Maybe (isJust)+import Network.HTTP.Media++newtype EventSource a = EventSource (IO a)++class ToServerEvent a where+ toServerEvent :: a -> Wai.ServerEvent++instance ToServerEvent Wai.ServerEvent where+ toServerEvent = id++textEventStream :: MediaType+textEventStream = "text" // "event-stream"++instance CanRespond (EventSource a) where+ canRespond [] = True+ canRespond l = any (isJust . matchAccept [textEventStream]) l++instance (Monad m, ToServerEvent a) => ToResponse m (EventSource a) where+ toResponse _ (EventSource poll) = do+ pure $ Wai.responseStream+ Http.status200+ [(Http.hContentType, renderHeader textEventStream)]+ \write flush ->+ flush >> fix \continue -> do+ event <- poll+ case Wai.eventToBuilder $ toServerEvent event of+ Nothing -> pure ()+ Just e -> write e >> flush >> continue