minion-jwt (empty) → 0.1.0.0

raw patch · 6 files changed

+293/−0 lines, 6 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, http-types, jose, minion, minion-jwt, mtl, text, time, transformers, wai, warp

Files

LICENSE +20/−0
README.md +45/−0
app/Jwt.hs +9/−0
minion-jwt.cabal +83/−0
src/Web/Minion/Auth/Jwt.hs +74/−0
src/Web/Minion/Examples/Jwt.hs +62/−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/Jwt.hs view

@@ -0,0 +1,9 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.Jwt qualified++main :: IO ()+main = do+  app <- Web.Minion.Examples.Jwt.app+  Warp.run 9001 app

+ minion-jwt.cabal view

@@ -0,0 +1,83 @@+cabal-version:      3.0+name:               minion-jwt+version:            0.1.0.0+license:            MIT+license-file:       LICENSE+author:             goosedb+maintainer:         goosedb@yandex.ru+synopsis:           Minion JWT support+category:           Web+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.Auth.Jwt+    Web.Minion.Examples.Jwt++  build-depends:+    , aeson+    , base >= 4.16 && < 5+    , bytestring+    , http-types+    , jose+    , minion+    , mtl+    , text+    , time+    , transformers+    , wai++  hs-source-dirs:   src+  default-language: Haskell2010++executable minion-jwt-example+  import:           common+  main-is:          Jwt.hs+  build-depends:+    , base+    , minion-jwt+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded

+ src/Web/Minion/Auth/Jwt.hs view

@@ -0,0 +1,74 @@+module Web.Minion.Auth.Jwt where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Crypto.JOSE qualified as Jose+import Crypto.JWT (JWTError)+import Crypto.JWT qualified as Jose+import Data.Aeson (FromJSON (..))+import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Time qualified as Time+import Network.HTTP.Types.Header qualified as Http+import Network.Wai qualified as Wai+import Web.Minion++data JwtAuthSettings m payload a = JwtAuthSettings+  { getNow :: m Time.UTCTime+  , jwk :: m Jose.JWK+  , validationSettings :: m Jose.JWTValidationSettings+  , check :: MakeError -> Either JWTError (JwtPayload payload) -> m (AuthResult a)+  }++defaultJwtAuthSettings ::+  (MonadIO m) =>+  m Jose.JWK ->+  -- | Audience predicate+  (Jose.StringOrURI -> Bool) ->+  (MakeError -> Either JWTError (JwtPayload payload) -> m (AuthResult a)) ->+  JwtAuthSettings m payload a+defaultJwtAuthSettings jwk audCheck check =+  JwtAuthSettings+    { getNow = liftIO Time.getCurrentTime+    , jwk = jwk+    , validationSettings = pure (Jose.defaultJWTValidationSettings audCheck)+    , check = check+    }++data JwtPayload a = JwtPayload+  { claims :: Jose.ClaimsSet+  , payload :: a+  }++instance Jose.HasClaimsSet (JwtPayload a) where+  claimsSet f JwtPayload{..} = f claims <&> \c -> JwtPayload{claims = c, ..}++instance (FromJSON a) => FromJSON (JwtPayload a) where+  parseJSON v =+    JwtPayload+      <$> parseJSON v+      <*> parseJSON v++data Bearer payload++instance (MonadIO m, FromJSON payload) => IsAuth (Bearer payload) m a where+  type Settings (Bearer payload) m a = JwtAuthSettings m payload a+  toAuth JwtAuthSettings{..} buildError req = do+    jwk_ <- jwk+    now <- getNow+    settings <- validationSettings+    payload <- Jose.runJOSE $ runMaybeT do+      authHeader <- Wai.requestHeaders req & lookup Http.hAuthorization & hoistMaybe+      compact <- hoistMaybe $ Bytes.stripPrefix prefix authHeader+      jwt <- Jose.decodeCompact $ Bytes.Lazy.fromStrict compact+      Jose.verifyJWTAt settings jwk_ now jwt+    case payload of+      Left e -> check (buildError req) (Left e)+      Right Nothing -> pure Indefinite+      Right (Just (v :: JwtPayload payload)) -> check (buildError req) (Right v)+   where+    prefix = "Bearer "++    hoistMaybe = MaybeT . pure

+ src/Web/Minion/Examples/Jwt.hs view

@@ -0,0 +1,62 @@+module Web.Minion.Examples.Jwt (app) where++import Control.Monad (forM_)+import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT), asks)+import Crypto.JOSE (JWK, bestJWSAlg, fromOctets, newJWSHeader, runJOSE)+import Crypto.JWT (JWTError, encodeCompact, signJWT)+import Data.Aeson (FromJSON, ToJSON)+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Functor (($>))+import Data.Text.Encoding qualified+import Data.Text.IO qualified+import GHC.Generics (Generic)+import Network.HTTP.Types.Status qualified as Http+import System.Environment (getArgs)+import Web.Minion++import Web.Minion.Auth.Jwt++type M = ReaderT Env IO++newtype JwtUserInfo = JwtUserInfo {userId :: UserId}+  deriving (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype UserId = UserId Int+  deriving newtype (FromJSON, Show, Read, ToJSON)++newtype Env = Env+  {authCtx :: HList '[JwtAuthSettings M JwtUserInfo UserId]}++app :: IO (ApplicationM IO)+app = do+  showJwts+  pure $ \req resp ->+    runReaderT (serve api req resp) (Env $ jwtSettings :# HNil)++api :: Router Void M+api = "api" /> "auth" /> myAuth .> handle GET authEndpoint++authEndpoint :: UserId -> ReaderT Env IO NoBody+authEndpoint userId = liftIO (putStrLn $ "User " <> show userId) $> NoBody++myAuth :: ValueCombinator Void (WithReq M (Auth '[Bearer JwtUserInfo] UserId)) ts M+myAuth = auth @'[Bearer JwtUserInfo] @UserId (asks authCtx) \makeError -> \case+  _ -> throwM $ makeError Http.status401 mempty++jwtSettings :: JwtAuthSettings M JwtUserInfo UserId+jwtSettings = defaultJwtAuthSettings (pure myJwk) (const True) do+  const (pure . either (const BadAuth) (\JwtPayload{payload = JwtUserInfo{..}} -> Authenticated userId))++myJwk :: JWK+myJwk = fromOctets @Bytes.Lazy.ByteString "really secret and long enough key"++showJwts :: IO ()+showJwts = do+  userIds <- map (read @UserId) <$> getArgs+  forM_ userIds \userId -> do+    Right jwt <- runJOSE @JWTError do+      alg <- bestJWSAlg myJwk+      signJWT myJwk (newJWSHeader ((), alg)) (JwtUserInfo userId)+    let jwtTxt = Data.Text.Encoding.decodeUtf8 . Bytes.Lazy.toStrict $ encodeCompact jwt+    putStr (show userId <> ": ") >> Data.Text.IO.putStrLn jwtTxt