feat(apis): further integrate servant
This commit is contained in:
Gregor Kleen
parent
e3d504bd11
commit
bf2ff2dc9c
@ -146,7 +146,7 @@ server-sessions:
|
||||
secure-cookies: "_env:SERVER_SESSION_COOKIES_SECURE:true"
|
||||
session-token-expiration: 28807
|
||||
session-token-encoding: HS256
|
||||
session-samesite: strict
|
||||
session-samesite: lax
|
||||
|
||||
user-defaults:
|
||||
max-favourites: 12
|
||||
|
||||
@ -1262,3 +1262,12 @@ a.breadcrumbs__home
|
||||
|
||||
&__label
|
||||
grid-area: label
|
||||
|
||||
code
|
||||
display: block
|
||||
box-shadow: inset 0 0 4px 4px var(--color-grey-light)
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
overflow-x: auto
|
||||
tab-size: 2
|
||||
padding: 10px
|
||||
|
||||
@ -1224,6 +1224,7 @@ MenuAllocationUsers: Bewerber
|
||||
MenuAllocationPriorities: Zentrale Dringlichkeiten
|
||||
MenuAllocationCompute: Platzvergabe berechnen
|
||||
MenuAllocationAccept: Platzvergabe akzeptieren
|
||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
BreadcrumbSubmissionFile: Datei
|
||||
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
|
||||
@ -1294,7 +1295,8 @@ BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
|
||||
BreadcrumbAllocationCompute: Platzvergabe berechnen
|
||||
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
|
||||
BreadcrumbExternalApis: Externe APIs
|
||||
BreadcrumbSwagger: API Dokumentation
|
||||
BreadcrumbApiDocs: API Dokumentation
|
||||
BreadcrumbSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
|
||||
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
|
||||
|
||||
@ -145,9 +145,12 @@ dependencies:
|
||||
- servant
|
||||
- servant-server
|
||||
- servant-swagger
|
||||
- servant-docs
|
||||
- swagger2
|
||||
- haskell-src-meta
|
||||
- network-uri
|
||||
- insert-ordered-containers
|
||||
- vault
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
6
routes
6
routes
@ -67,7 +67,7 @@
|
||||
|
||||
/help HelpR GET POST !free
|
||||
|
||||
/external-apis ExternalApisR ServantApiExternalApis getServantApiExternalApis
|
||||
/external-apis ExternalApisR ServantApiExternalApis getServantApi
|
||||
|
||||
/user ProfileR GET POST !free
|
||||
/user/profile ProfileDataR GET !free
|
||||
@ -229,6 +229,8 @@
|
||||
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
|
||||
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
|
||||
|
||||
/swagger.json SwaggerR GET !free
|
||||
/api ApiDocsR GET !free
|
||||
/swagger SwaggerR GET !free
|
||||
/swagger.json SwaggerJsonR GET !free
|
||||
|
||||
!/*WellKnownFileName WellKnownR GET !free
|
||||
|
||||
@ -117,9 +117,10 @@ import Handler.Metrics
|
||||
import Handler.ExternalExam
|
||||
import Handler.Participants
|
||||
import Handler.StorageKey
|
||||
import Handler.ApiDocs
|
||||
import Handler.Swagger
|
||||
|
||||
import ServantApi
|
||||
import ServantApi () -- YesodSubDispatch instances
|
||||
|
||||
|
||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||
|
||||
@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''CourseNewsId
|
||||
, ''CourseEventId
|
||||
, ''TutorialId
|
||||
, ''ExternalApiId
|
||||
]
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
|
||||
@ -6,7 +6,7 @@ module Data.CaseInsensitive.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (lift)
|
||||
import ClassyPrelude.Yesod hiding (lift, Proxy(..))
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -28,6 +28,10 @@ import Web.HttpApiData
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import qualified Data.Swagger as Swagger
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
|
||||
instance PersistField (CI Text) where
|
||||
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
|
||||
@ -88,6 +92,8 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
||||
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
||||
toUrlPiece = toUrlPiece . CI.original
|
||||
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
|
||||
toHeader = toHeader . CI.original
|
||||
toQueryParam = toQueryParam . CI.original
|
||||
|
||||
instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where
|
||||
parseUrlPiece = fmap CI.mk . parseUrlPiece
|
||||
@ -101,3 +107,6 @@ instance Csv.ToField s => Csv.ToField (CI s) where
|
||||
|
||||
instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
|
||||
parseField = fmap CI.mk . Csv.parseField
|
||||
|
||||
instance Swagger.ToParamSchema s => Swagger.ToParamSchema (CI s) where
|
||||
toParamSchema _ = Swagger.toParamSchema (Proxy @s)
|
||||
|
||||
@ -22,7 +22,9 @@ import Auth.LDAP
|
||||
import Auth.PWHash
|
||||
import Auth.Dummy
|
||||
|
||||
import qualified Network.Wai as W (pathInfo)
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types.Header as W
|
||||
import qualified Network.Wai.Middleware.HttpAuth as W
|
||||
|
||||
import Yesod.Core.Types (HandlerContents)
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
@ -312,7 +314,7 @@ askBearerUnsafe :: forall m.
|
||||
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
|
||||
askBearerUnsafe = $cachedHere $ do
|
||||
bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
|
||||
catch (decodeBearer bearer) $ \case
|
||||
catch (liftHandler $ decodeBearer bearer) $ \case
|
||||
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
|
||||
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
|
||||
other -> do
|
||||
@ -1452,7 +1454,7 @@ instance Yesod UniWorX where
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = sameSite $ case appSessionStore of
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
@ -1484,6 +1486,17 @@ instance Yesod UniWorX where
|
||||
= laxSameSiteSessions
|
||||
| otherwise
|
||||
= id
|
||||
notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
||||
notForBearer = fmap $ fmap notForBearer'
|
||||
where notForBearer' :: SessionBackend -> SessionBackend
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just) $ map W.extractBearerAuth aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
in SessionBackend load'
|
||||
|
||||
maximumContentLength app _ = app ^. _appMaximumContentLength
|
||||
|
||||
@ -1494,8 +1507,12 @@ instance Yesod UniWorX where
|
||||
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
|
||||
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
|
||||
yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
|
||||
yesodMiddleware = observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityHeaderMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . csrfMiddleware . updateFavouritesMiddleware
|
||||
where
|
||||
securityHeaderMiddleware :: Handler a -> Handler a
|
||||
securityHeaderMiddleware handler = (*> handler) $ do
|
||||
addHeader "X-Frame-Options" "sameorigin"
|
||||
addHeader "X-Content-Type-Options" "nosniff"
|
||||
updateFavouritesMiddleware :: Handler a -> Handler a
|
||||
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
@ -1528,48 +1545,78 @@ instance Yesod UniWorX where
|
||||
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
|
||||
observeYesodCacheSizeMiddleware :: Handler a -> Handler a
|
||||
observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
|
||||
csrfMiddleware :: Handler a -> Handler a
|
||||
csrfMiddleware handler = do
|
||||
hasBearer <- is _Just <$> lookupBearerAuth
|
||||
|
||||
if | hasBearer -> handler
|
||||
| otherwise -> defaultCsrfMiddleware handler
|
||||
|
||||
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
||||
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
||||
|
||||
errorHandler err = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
encrypted :: ToJSON a => a -> Widget -> Widget
|
||||
encrypted plaintextJson plaintext = do
|
||||
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
||||
shouldEncrypt <- getsYesod $ view _appEncryptErrors
|
||||
if
|
||||
| shouldEncrypt
|
||||
, not canDecrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
||||
shouldEncrypt <- do
|
||||
canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
|
||||
shouldEncrypt <- getsYesod $ view _appEncryptErrors
|
||||
return $ shouldEncrypt && not canDecrypt
|
||||
|
||||
[whamlet|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{ciphertext}
|
||||
selectRep $ do
|
||||
provideRep $ do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
encrypted :: ToJSON a => a -> Widget -> Widget
|
||||
encrypted plaintextJson plaintext = do
|
||||
if
|
||||
| shouldEncrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
||||
|
||||
[whamlet|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{ciphertext}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
|
||||
errPage = case err of
|
||||
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
||||
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
|
||||
InvalidArgs errs -> [whamlet|
|
||||
<ul>
|
||||
$forall err' <- errs
|
||||
<li .errMsg>#{err'}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
|
||||
errPage = case err of
|
||||
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
|
||||
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
|
||||
InvalidArgs errs -> [whamlet|
|
||||
<ul>
|
||||
$forall err' <- errs
|
||||
<li .errMsg>#{err'}
|
||||
|]
|
||||
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
||||
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
|
||||
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
||||
fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
||||
toWidget
|
||||
[cassius|
|
||||
.errMsg
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|]
|
||||
errPage
|
||||
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
|
||||
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
|
||||
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
|
||||
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
|
||||
toWidget
|
||||
[cassius|
|
||||
.errMsg
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|]
|
||||
errPage
|
||||
provideRep . fmap PrettyValue $ case err of
|
||||
PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
ciphertext <- encodedSecretBox SecretBoxShort err'
|
||||
return $ object [ "message" JSON..= ciphertext
|
||||
, "encrypted" JSON..= True
|
||||
]
|
||||
| otherwise -> return $ object [ "message" JSON..= err' ]
|
||||
InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
|
||||
_other -> return $ object []
|
||||
provideRep $ case err of
|
||||
PermissionDenied err' -> return err'
|
||||
InternalError err'
|
||||
| shouldEncrypt -> do
|
||||
addHeader "Encrypted-Error-Message" "True"
|
||||
encodedSecretBox SecretBoxPretty err'
|
||||
| otherwise -> return err'
|
||||
InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
|
||||
_other -> return Text.empty
|
||||
|
||||
defaultLayout = siteLayout' Nothing
|
||||
|
||||
@ -1614,6 +1661,12 @@ instance Yesod UniWorX where
|
||||
|
||||
makeLogger = readTVarIO . snd . appLogger
|
||||
|
||||
-- -- `normalizeRouteMiddleware` takes care of normalization
|
||||
-- cleanPath _ = Right
|
||||
-- joinPath _ ar pieces qs' = Text.encodeUtf8Builder ar <> encodePath pieces qs
|
||||
-- where qs = map (Text.encodeUtf8 *** fmap Text.encodeUtf8 . assertM' (not . Text.null)) qs'
|
||||
|
||||
|
||||
|
||||
-- langForm :: Form (Lang, Route UniWorX)
|
||||
-- langForm csrf = do
|
||||
@ -2216,7 +2269,10 @@ instance YesodBreadcrumbs UniWorX where
|
||||
EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
|
||||
breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing
|
||||
breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger Nothing
|
||||
|
||||
breadcrumb ApiDocsR = i18nCrumb MsgBreadcrumbApiDocs Nothing
|
||||
breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger $ Just ApiDocsR
|
||||
breadcrumb SwaggerJsonR = breadcrumb SwaggerR
|
||||
|
||||
-- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
|
||||
|
||||
@ -3923,6 +3979,19 @@ pageActions ParticipantsListR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions ApiDocsR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuSwagger
|
||||
, navRoute = SwaggerR
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions _ = return []
|
||||
|
||||
pageQuickActions :: ( MonadCatch m
|
||||
@ -4700,12 +4769,12 @@ instance YesodMail UniWorX where
|
||||
return mRes
|
||||
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
instance (MonadThrow m, MonadSite UniWorX m) => MonadCrypto m where
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
cryptoIDKey f = getsYesod appCryptoIDKey >>= f
|
||||
cryptoIDKey f = getsSite appCryptoIDKey >>= f
|
||||
|
||||
instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
|
||||
secretBoxKey = getsYesod appSecretBoxKey
|
||||
instance {-# OVERLAPPING #-} (Monad m, MonadSite UniWorX m) => MonadSecretBox m where
|
||||
secretBoxKey = getsSite appSecretBoxKey
|
||||
|
||||
-- Note: Some functionality previously present in the scaffolding has been
|
||||
-- moved to documentation in the Wiki. Following are some hopefully helpful
|
||||
|
||||
@ -11,7 +11,9 @@ import Foundation.Type
|
||||
|
||||
import Foundation.Routes.Definitions
|
||||
|
||||
import ServantApi
|
||||
|
||||
import ServantApi.ExternalApis.Type
|
||||
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
@ -42,6 +44,27 @@ deriving instance Generic CourseNewsR
|
||||
deriving instance Generic CourseEventR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
|
||||
instance Hashable CourseR
|
||||
instance Hashable SheetR
|
||||
instance Hashable SubmissionR
|
||||
instance Hashable MaterialR
|
||||
instance Hashable TutorialR
|
||||
instance Hashable ExamR
|
||||
instance Hashable EExamR
|
||||
instance Hashable CourseApplicationR
|
||||
instance Hashable AllocationR
|
||||
instance Hashable SchoolR
|
||||
instance Hashable ExamOfficeR
|
||||
instance Hashable CourseNewsR
|
||||
instance Hashable CourseEventR
|
||||
instance Hashable (Route UniWorX)
|
||||
instance Hashable (Route EmbeddedStatic) where
|
||||
hashWithSalt s = hashWithSalt s . renderRoute
|
||||
instance Hashable (Route Auth) where
|
||||
hashWithSalt s = hashWithSalt s . renderRoute
|
||||
|
||||
|
||||
data RouteChildren
|
||||
type instance Children RouteChildren a = ChildrenRouteChildren a
|
||||
type family ChildrenRouteChildren a where
|
||||
|
||||
118
src/Foundation/Servant.hs
Normal file
118
src/Foundation/Servant.hs
Normal file
@ -0,0 +1,118 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Foundation.Servant
|
||||
( ServantApiDispatchUniWorX(..)
|
||||
, UniWorXContext
|
||||
, ServantHandler
|
||||
, BearerRestriction(..)
|
||||
) where
|
||||
|
||||
import Import.Servant.NoFoundation
|
||||
import Foundation
|
||||
|
||||
import Handler.Utils.Tokens
|
||||
|
||||
import qualified Data.HashMap.Strict.InsOrd as HashMap
|
||||
|
||||
import Network.Wai (Middleware, modifyResponse, mapResponseHeaders, vault)
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import qualified Data.Vault.Lazy as Vault
|
||||
|
||||
import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal, withRequest)
|
||||
import Servant.Server.Internal.Delayed (addAuthCheck)
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import qualified Yesod.Servant as Servant
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
waiBearerKey :: Vault.Key (Maybe (BearerToken UniWorX))
|
||||
waiBearerKey = unsafePerformIO Vault.newKey
|
||||
{-# NOINLINE waiBearerKey #-}
|
||||
|
||||
waiRouteKey :: Vault.Key (Route UniWorX)
|
||||
waiRouteKey = unsafePerformIO Vault.newKey
|
||||
{-# NOINLINE waiRouteKey #-}
|
||||
|
||||
|
||||
data BearerRestriction (restr :: *) = BearerRestriction
|
||||
|
||||
|
||||
instance ( HasServer sub context
|
||||
, ToJSON restr, FromJSON restr
|
||||
)
|
||||
=> HasServer (BearerRestriction restr :> sub) context
|
||||
where
|
||||
type ServerT (BearerRestriction restr :> sub) m
|
||||
= Maybe restr -> ServerT sub m
|
||||
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s
|
||||
|
||||
route _ context subserver
|
||||
= route (Proxy @sub) context (subserver `addAuthCheck` withRequest bearerCheck)
|
||||
where
|
||||
bearerCheck :: W.Request -> DelayedIO (Maybe restr)
|
||||
bearerCheck req = do
|
||||
let bearer = Vault.lookup waiBearerKey $ vault req
|
||||
cRoute = Vault.lookup waiRouteKey $ vault req
|
||||
|
||||
noRouteStored, noTokenStored, noTokenProvided :: ServerError
|
||||
noTokenStored = err500 { errBody = "servantYesodMiddleware did not store bearer token in WAI vault." }
|
||||
noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." }
|
||||
noRouteStored = err500 { errBody = "servantYesodMiddleware did not store current route in WAI vault." }
|
||||
|
||||
exceptT delayedFailFatal return $ do
|
||||
bearer' <- maybeExceptT' noTokenProvided =<< maybeExceptT' noTokenStored bearer
|
||||
cRoute' <- maybeExceptT' noRouteStored cRoute
|
||||
|
||||
return $ bearer' ^? _bearerRestrictionIx cRoute'
|
||||
|
||||
|
||||
type UniWorXContext = UniWorX ': '[]
|
||||
type ServantHandler = ServantHandlerFor UniWorX
|
||||
|
||||
class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatchUniWorX api where
|
||||
servantServer' :: ServantApi api -> ServerT api ServantHandler
|
||||
|
||||
instance ServantApiDispatchUniWorX api => ServantApiDispatch UniWorXContext ServantHandler UniWorX api where
|
||||
servantContext _ app _ = return $ app :. EmptyContext
|
||||
servantHoist _ app _ _ = ($ app) . unServantHandlerFor
|
||||
servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash
|
||||
servantYesodMiddleware _ _ = fmap appEndo $ foldMapM (fmap Endo) [storeBearerToken, storeCurrentRoute]
|
||||
servantServer proxy _ = servantServer' proxy
|
||||
|
||||
setDefaultHeaders :: ResponseHeaders -> ResponseHeaders
|
||||
setDefaultHeaders existing = HashMap.toList $ HashMap.fromList existing <> defaultHeaders
|
||||
where defaultHeaders = HashMap.fromList
|
||||
[ ("X-Frame-Options", "sameorigin")
|
||||
, ("X-Content-Type-Options", "nosniff")
|
||||
, ("Vary", "Accept")
|
||||
, ("X-XSS-Protection", "1; mode=block")
|
||||
]
|
||||
|
||||
fixTrailingSlash :: Middleware
|
||||
-- ^ `servant-server` contains a special case in their implementation
|
||||
-- of `runRouter`, that discards trailing slashes.
|
||||
--
|
||||
-- Because all slashes matter, this duplicates trailing slashes.
|
||||
fixTrailingSlash = (. fixTrailingSlash')
|
||||
where fixTrailingSlash' req
|
||||
| Just pathInfo' <- fromNullable $ W.pathInfo req
|
||||
, Text.null $ last pathInfo'
|
||||
= req { W.pathInfo = W.pathInfo req ++ [Text.empty] }
|
||||
| otherwise
|
||||
= req
|
||||
|
||||
storeBearerToken, storeCurrentRoute :: HandlerFor UniWorX Middleware
|
||||
storeBearerToken = do
|
||||
restr <- maybeBearerToken
|
||||
return $ \app req -> app req{ vault = Vault.insert waiBearerKey restr $ vault req }
|
||||
storeCurrentRoute = do
|
||||
cRoute <- getCurrentRoute
|
||||
|
||||
$logDebugS "storeCurrentRoute" $ tshow cRoute
|
||||
|
||||
return $ \app req -> app req{ vault = maybe id (Vault.insert waiRouteKey) cRoute $ vault req }
|
||||
29
src/Handler/ApiDocs.hs
Normal file
29
src/Handler/ApiDocs.hs
Normal file
@ -0,0 +1,29 @@
|
||||
module Handler.ApiDocs
|
||||
( getApiDocsR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import ServantApi
|
||||
|
||||
import qualified Servant.Docs as Servant
|
||||
|
||||
import Handler.Utils.Pandoc
|
||||
|
||||
|
||||
getApiDocsR :: Handler TypedContent
|
||||
getApiDocsR = selectRep $ do
|
||||
case htmlDocs of
|
||||
Right html -> provideRep . siteLayoutMsg MsgBreadcrumbApiDocs $ do
|
||||
setTitleI MsgBreadcrumbApiDocs
|
||||
|
||||
toWidget html
|
||||
Left _err -> return ()
|
||||
provideRepType "text/markdown" $ return mdDocs
|
||||
where
|
||||
mdDocs = pack . Servant.markdown $ Servant.docsWith Servant.defaultDocOptions docIntros docExtra uniworxApi
|
||||
htmlDocs = parseMarkdownWith markdownReaderOptions htmlWriterOptions mdDocs
|
||||
|
||||
docIntros = mempty
|
||||
docExtra = mconcat
|
||||
[
|
||||
]
|
||||
@ -1,18 +1,14 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Swagger
|
||||
( getSwaggerR
|
||||
( getSwaggerR, getSwaggerJsonR
|
||||
) where
|
||||
|
||||
import Import hiding (host)
|
||||
import Import hiding (host, Response)
|
||||
import ServantApi
|
||||
|
||||
import Data.Swagger
|
||||
import Data.Swagger.Declare (Declare)
|
||||
import Servant.Swagger
|
||||
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
import Development.GitRev
|
||||
|
||||
import Network.URI
|
||||
@ -20,19 +16,8 @@ import Network.URI
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
|
||||
|
||||
instance ToContent Swagger where
|
||||
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
|
||||
|
||||
instance ToTypedContent Swagger where
|
||||
toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
|
||||
|
||||
instance HasContentType Swagger where
|
||||
getContentType _ = typeJson
|
||||
|
||||
|
||||
getSwaggerR :: Handler Swagger
|
||||
getSwaggerR = do
|
||||
genSwagger :: Handler Swagger
|
||||
genSwagger = do
|
||||
app <- getYesod
|
||||
let docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"]
|
||||
root <- getApprootText approot app <$> waiRequest
|
||||
@ -53,15 +38,39 @@ getSwaggerR = do
|
||||
& fromMaybe id applyAuthority
|
||||
& schemes .~ fmap pure mbScheme
|
||||
& basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath
|
||||
errorResponses :: Map HttpStatusCode (Declare (Definitions Schema) Response)
|
||||
errorResponses = mconcat
|
||||
[ singletonMap 500 $ return mempty
|
||||
, singletonMap 400 $ return mempty
|
||||
, singletonMap 401 $ return mempty
|
||||
, singletonMap 403 $ return mempty
|
||||
, singletonMap 405 $ return mempty
|
||||
]
|
||||
|
||||
|
||||
tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text)
|
||||
c <- toTextUrl HelpR
|
||||
|
||||
|
||||
let supportContact = mempty
|
||||
& name .~ addressName supportAddress
|
||||
& email ?~ addressEmail supportAddress
|
||||
& url ?~ URL c
|
||||
where
|
||||
supportAddress = appMailSupport $ appSettings' app
|
||||
|
||||
return $ toSwagger uniworxApi
|
||||
& info.title .~ docMR MsgLogo
|
||||
& info.description ?~ docMR MsgInvitationUniWorXTip
|
||||
& info.termsOfService ?~ tos
|
||||
& info.contact ?~ Contact Nothing (Just $ URL c) Nothing
|
||||
& info.contact ?~ supportContact
|
||||
& info.version .~ $gitDescribe
|
||||
& fromMaybe id applyApproot
|
||||
& appEndo (ifoldMap ((Endo .) . setResponseWith const) errorResponses)
|
||||
|
||||
|
||||
getSwaggerR :: Handler TypedContent
|
||||
getSwaggerR = selectRep $ do
|
||||
provideRep $ toPrettyJSON <$> genSwagger
|
||||
provideRep $ toYAML <$> genSwagger
|
||||
|
||||
getSwaggerJsonR :: Handler Void
|
||||
getSwaggerJsonR = redirect SwaggerR
|
||||
|
||||
@ -287,7 +287,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
shapeName :: MassInputFieldName (BoxCoord liveliness)
|
||||
shapeName = MassInputShape{..}
|
||||
shapeField :: Field handler (Map (BoxCoord liveliness) cellData)
|
||||
shapeField = secretJsonField
|
||||
shapeField = hoistField liftHandler secretJsonField
|
||||
sentShape <- runMaybeT $ do
|
||||
ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams
|
||||
fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles
|
||||
|
||||
@ -829,7 +829,7 @@ addPIHiddenField DBTable{ dbtIdent } pi form fragment
|
||||
|
||||
addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
|
||||
addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
|
||||
encrypted <- encodedSecretBox SecretBoxShort pKeys
|
||||
encrypted <- liftHandler $ encodedSecretBox SecretBoxShort pKeys
|
||||
form $ fragment <> [shamlet|
|
||||
$newline never
|
||||
<input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
|
||||
|
||||
@ -24,23 +24,23 @@ requireBearerToken = liftHandler $ do
|
||||
return bearer
|
||||
|
||||
requireCurrentBearerRestrictions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
, HandlerSite m ~ UniWorX
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
requireCurrentBearerRestrictions = runMaybeT $ do
|
||||
bearer <- requireBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
||||
|
||||
maybeCurrentBearerRestrictions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
maybeCurrentBearerRestrictions = runMaybeT $ do
|
||||
bearer <- MaybeT maybeBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
|
||||
@ -27,12 +27,13 @@ import Model.Types.TH.Wordlist as Import
|
||||
|
||||
import Mail as Import
|
||||
|
||||
import ServantApi.Definition as Import
|
||||
|
||||
import Yesod.Auth as Import
|
||||
import Yesod.Core.Types as Import (loggerSet)
|
||||
import Yesod.Default.Config2 as Import
|
||||
import Yesod.Core.Types.Instances as Import
|
||||
import Yesod.Servant as Import
|
||||
hiding ( MonadHandler(..), HasRoute(..)
|
||||
)
|
||||
|
||||
import Utils as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
@ -102,7 +103,8 @@ import Control.Monad.Catch as Import hiding (Handler(..))
|
||||
import Control.Monad.Trans.Control as Import hiding (embed)
|
||||
import Control.Monad.Fail as Import
|
||||
|
||||
import Jose.Jwt as Import (Jwt)
|
||||
import Jose.Jwk as Import (JwkSet, Jwk(..))
|
||||
import Jose.Jwt as Import (Jwt(..))
|
||||
|
||||
import Data.Time.Calendar as Import
|
||||
import Data.Time.Clock as Import
|
||||
@ -139,6 +141,7 @@ import Database.Esqueleto.Instances as Import ()
|
||||
import Numeric.Natural.Instances as Import ()
|
||||
import Text.Blaze.Instances as Import ()
|
||||
import Jose.Jwt.Instances as Import ()
|
||||
import Jose.Jwk.Instances as Import ()
|
||||
import Web.PathPieces.Instances as Import ()
|
||||
import Data.Universe.Instances.Reverse.MonoTraversable ()
|
||||
import Data.Universe.Instances.Reverse.WithIndex ()
|
||||
|
||||
@ -2,17 +2,8 @@ module Import.Servant
|
||||
( module Import
|
||||
) where
|
||||
|
||||
import Import.NoFoundation as Import hiding
|
||||
( Context
|
||||
, Authorized, Unauthorized
|
||||
, ServerError
|
||||
, Header
|
||||
, Strict
|
||||
, Headers
|
||||
, addHeader
|
||||
)
|
||||
|
||||
import Foundation.Type as Import
|
||||
|
||||
import Servant.API as Import
|
||||
import Servant.Server as Import
|
||||
import Foundation as Import
|
||||
hiding ( Handler
|
||||
)
|
||||
import Foundation.Servant as Import
|
||||
import Import.Servant.NoFoundation as Import
|
||||
|
||||
24
src/Import/Servant/NoFoundation.hs
Normal file
24
src/Import/Servant/NoFoundation.hs
Normal file
@ -0,0 +1,24 @@
|
||||
module Import.Servant.NoFoundation
|
||||
( module Import
|
||||
) where
|
||||
|
||||
import Import.NoFoundation as Import hiding
|
||||
( Context
|
||||
, Authorized, Unauthorized
|
||||
, ServerError
|
||||
, Header
|
||||
, Strict
|
||||
, Headers
|
||||
, addHeader
|
||||
)
|
||||
|
||||
import Servant.API as Import
|
||||
import Servant.Server as Import
|
||||
import Servant.Docs as Import
|
||||
( ToCapture(..), DocCapture(..)
|
||||
, ToSample(..), noSamples, singleSample, samples
|
||||
, ToParam(..), DocQueryParam(..), ParamKind
|
||||
)
|
||||
import Data.Swagger as Import
|
||||
( ToSchema(..)
|
||||
)
|
||||
12
src/Jose/Jwk/Instances.hs
Normal file
12
src/Jose/Jwk/Instances.hs
Normal file
@ -0,0 +1,12 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Jose.Jwk.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import Model.Types.TH.JSON
|
||||
|
||||
import Jose.Jwk
|
||||
|
||||
|
||||
derivePersistFieldJSON ''JwkSet
|
||||
@ -5,6 +5,7 @@ module Jose.Jwt.Instances
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
import Jose.Jwt
|
||||
|
||||
@ -20,6 +21,8 @@ instance PathPiece Jwt where
|
||||
|
||||
instance Hashable Jwt
|
||||
|
||||
derivePersistFieldPathPiece ''Jwt
|
||||
|
||||
|
||||
deriving instance Generic JwtError
|
||||
deriving instance Typeable JwtError
|
||||
|
||||
@ -10,6 +10,7 @@ module Model.Tokens.Bearer
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
import Yesod.Servant (MonadSite(..))
|
||||
|
||||
import Model
|
||||
import Model.Tokens.Lens
|
||||
@ -99,17 +100,16 @@ bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route si
|
||||
bearerRestrict route (toJSON -> resVal) = over _bearerRestrictions $ HashMap.insert route resVal
|
||||
|
||||
|
||||
|
||||
bearerToJSON :: forall m.
|
||||
( MonadHandler m
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, RenderRoute (HandlerSite m)
|
||||
) => BearerToken (HandlerSite m) -> m Value
|
||||
bearerToJSON :: forall site m.
|
||||
( MonadSite site m
|
||||
, HasCryptoUUID (AuthId site) m
|
||||
, RenderRoute site
|
||||
) => BearerToken site -> m Value
|
||||
-- ^ Encode a `BearerToken` analogously to `toJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
bearerToJSON BearerToken{..} = do
|
||||
cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
|
||||
cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId site)))
|
||||
let stdPayload = Jose.JwtClaims
|
||||
{ jwtIss = Just $ toPathPiece bearerIssuedBy
|
||||
, jwtSub = Nothing
|
||||
|
||||
@ -15,3 +15,4 @@ import Model.Types.Misc as Types
|
||||
import Model.Types.School as Types
|
||||
import Model.Types.Allocation as Types
|
||||
import Model.Types.Languages as Types
|
||||
import Model.Types.Apis as Types
|
||||
|
||||
24
src/Model/Types/Apis.hs
Normal file
24
src/Model/Types/Apis.hs
Normal file
@ -0,0 +1,24 @@
|
||||
module Model.Types.Apis
|
||||
( ExternalApiConfig(..)
|
||||
, GradelistFormatIdent
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
|
||||
type GradelistFormatIdent = CI Text
|
||||
|
||||
data ExternalApiConfig
|
||||
= EApiGradelistFormat
|
||||
{ eapiGradelistFormats :: NonNull (HashSet GradelistFormatIdent)
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ tagSingleConstructors = True
|
||||
, unwrapUnaryRecords = False
|
||||
, sumEncoding = TaggedObject "type" "config"
|
||||
, allNullaryToStringTag = False
|
||||
, constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''ExternalApiConfig
|
||||
derivePersistFieldJSON ''ExternalApiConfig
|
||||
@ -195,15 +195,18 @@ defaultAuthDNF = PredDNF $ Set.fromList
|
||||
|
||||
data UserGroupName
|
||||
= UserGroupMetrics
|
||||
| UserGroupExternalApis
|
||||
| UserGroupCustom { userGroupCustomName :: CI Text }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance PathPiece UserGroupName where
|
||||
toPathPiece UserGroupMetrics = "metrics"
|
||||
toPathPiece (UserGroupCustom t) = CI.original t
|
||||
toPathPiece UserGroupMetrics = "metrics"
|
||||
toPathPiece UserGroupExternalApis = "external-apis"
|
||||
toPathPiece (UserGroupCustom t) = CI.original t
|
||||
fromPathPiece t = Just $ if
|
||||
| "metrics" `ciEq` t -> UserGroupMetrics
|
||||
| otherwise -> UserGroupCustom $ CI.mk t
|
||||
| "external-apis" `ciEq` t -> UserGroupExternalApis
|
||||
| "metrics" `ciEq` t -> UserGroupMetrics
|
||||
| otherwise -> UserGroupCustom $ CI.mk t
|
||||
where
|
||||
ciEq :: Text -> Text -> Bool
|
||||
ciEq = (==) `on` CI.mk
|
||||
|
||||
@ -154,11 +154,8 @@ makeLenses_ ''SheetGroup
|
||||
|
||||
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
deriving anyclass (Universe, Finite, Hashable)
|
||||
derivePersistField "SheetFileType"
|
||||
|
||||
instance Universe SheetFileType
|
||||
instance Finite SheetFileType
|
||||
|
||||
finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
|
||||
|
||||
sheetFile2markup :: SheetFileType -> Markup
|
||||
|
||||
@ -33,9 +33,7 @@ import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
|
||||
instance Universe SubmissionFileType
|
||||
instance Finite SubmissionFileType
|
||||
deriving anyclass (Universe, Finite, Hashable)
|
||||
|
||||
nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
|
||||
|
||||
|
||||
@ -3,7 +3,6 @@ module ServantApi
|
||||
) where
|
||||
|
||||
import Import.Servant
|
||||
import Foundation.Routes.Definitions
|
||||
|
||||
|
||||
import ServantApi.ExternalApis as ServantApi
|
||||
|
||||
@ -1,189 +0,0 @@
|
||||
module ServantApi.Definition
|
||||
( ServantApi(..)
|
||||
, servantApiLink
|
||||
, mkYesodApi
|
||||
, PathPieceHttpApiData(..)
|
||||
, BearerAuth, SessionAuth
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (Handler, fromList)
|
||||
import Control.Lens hiding (Context)
|
||||
|
||||
import Utils
|
||||
import Model.Types.Security
|
||||
|
||||
import Yesod.Core ( RenderRoute(..), ParseRoute(..)
|
||||
, YesodSubDispatch(..)
|
||||
, WaiSubsiteWithAuth(..)
|
||||
, PathPiece(..)
|
||||
)
|
||||
import Yesod.Core.Types ( YesodRunnerEnv(..)
|
||||
, YesodSubRunnerEnv(..)
|
||||
, Route(WaiSubsiteWithAuthRoute)
|
||||
)
|
||||
|
||||
import Servant.Links
|
||||
import Servant.API
|
||||
import Servant.Server
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Network.Wai (Request)
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.Meta.Parse (parseType)
|
||||
import Yesod.Routes.TH.Types
|
||||
|
||||
import Control.Monad.Fail (MonadFail(..))
|
||||
|
||||
import Data.Data (Data)
|
||||
import GHC.Exts (IsList(..))
|
||||
|
||||
import Servant.Swagger
|
||||
import Data.Swagger
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Network.URI
|
||||
import Network.HTTP.Types.URI
|
||||
|
||||
|
||||
data ServantApi api where
|
||||
ServantApi :: forall (context :: [*]) (api :: *) (m :: * -> *).
|
||||
HasServer api context
|
||||
=> { servantContext :: Request -> IO (Context context)
|
||||
, servantHoist :: Request -> Context context -> (forall a. m a -> Handler a)
|
||||
, servantServer :: ServerT api m
|
||||
}
|
||||
-> ServantApi api
|
||||
|
||||
instance RenderRoute (ServantApi api) where
|
||||
data Route (ServantApi api) = ServantApiRoute [Text] [(Text,Text)]
|
||||
deriving (Show, Eq, Read, Ord)
|
||||
renderRoute (ServantApiRoute ps qs) = (ps,qs)
|
||||
|
||||
instance ParseRoute (ServantApi api) where
|
||||
parseRoute (ps, qs) = Just $ ServantApiRoute ps qs
|
||||
|
||||
instance YesodSubDispatch (ServantApi api) master where
|
||||
yesodSubDispatch YesodSubRunnerEnv{..} = case ysreGetSub $ yreSite ysreParentEnv of
|
||||
ServantApi{ servantContext = (servantContext :: Request -> IO (Context context)), .. }
|
||||
-> let subEnv' :: YesodSubRunnerEnv WaiSubsiteWithAuth master
|
||||
subEnv' = YesodSubRunnerEnv
|
||||
{ ysreGetSub = \_ -> WaiSubsiteWithAuth $ \req respond -> do
|
||||
ctx <- servantContext req
|
||||
let server' = hoistServerWithContext (Proxy @api) (Proxy @context) (servantHoist req ctx) servantServer
|
||||
serveWithContext (Proxy @api) ctx server' req respond
|
||||
, ysreToParentRoute = ysreToParentRoute . (\(WaiSubsiteWithAuthRoute ps qs) -> ServantApiRoute ps qs)
|
||||
, ..
|
||||
}
|
||||
in yesodSubDispatch subEnv'
|
||||
|
||||
servantApiLink :: forall p1 p2 api endpoint.
|
||||
( IsElem endpoint api, HasLink endpoint )
|
||||
=> p1 api
|
||||
-> p2 endpoint
|
||||
-> MkLink endpoint (Route (ServantApi api))
|
||||
servantApiLink _ _ = safeLink' mkRoute (Proxy @api) (Proxy @endpoint)
|
||||
where
|
||||
mkRoute :: Link -> Route (ServantApi api)
|
||||
mkRoute (linkURI -> uri@URI{..}) = ServantApiRoute
|
||||
(map pack $ pathSegments uri)
|
||||
(over (mapped . _2) (fromMaybe mempty) . parseQueryText . encodeUtf8 $ pack uriQuery)
|
||||
|
||||
|
||||
newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (PathPiece, ToParamSchema)
|
||||
instance PathPiece a => FromHttpApiData (PathPieceHttpApiData a) where
|
||||
parseUrlPiece = maybe (Left "Could not convert from HttpApiData via PathPiece") Right . fromPathPiece
|
||||
instance PathPiece a => ToHttpApiData (PathPieceHttpApiData a) where
|
||||
toUrlPiece = toPathPiece
|
||||
|
||||
|
||||
data BearerAuth
|
||||
data SessionAuth
|
||||
|
||||
instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where
|
||||
toSwagger _ = toSwagger (Proxy @(SessionAuth :> sub))
|
||||
& securityDefinitions <>~ fromList [(defnKey, defn)]
|
||||
& allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]]
|
||||
where defnKey :: Text
|
||||
defnKey = "bearer"
|
||||
defn = SecurityScheme
|
||||
{ _securitySchemeType
|
||||
= SecuritySchemeApiKey ApiKeyParams
|
||||
{ _apiKeyName = "Authorization"
|
||||
, _apiKeyIn = ApiKeyHeader
|
||||
}
|
||||
, _securitySchemeDescription = Just
|
||||
"JSON Web Token-based API key"
|
||||
}
|
||||
|
||||
instance HasSwagger sub => HasSwagger (SessionAuth :> sub) where
|
||||
toSwagger _ = toSwagger (Proxy @sub)
|
||||
& securityDefinitions <>~ fromList [(defnKey, defn)]
|
||||
& allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]]
|
||||
where defnKey :: Text
|
||||
defnKey = "session"
|
||||
defn = SecurityScheme
|
||||
{ _securitySchemeType
|
||||
= SecuritySchemeApiKey ApiKeyParams
|
||||
{ _apiKeyName = "Cookie"
|
||||
, _apiKeyIn = ApiKeyHeader
|
||||
}
|
||||
, _securitySchemeDescription = Just
|
||||
"JSON Web Token-based session identification as provided be the web interface"
|
||||
}
|
||||
|
||||
instance HasLink sub => HasLink (BearerAuth :> sub) where
|
||||
type MkLink (BearerAuth :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy @sub)
|
||||
|
||||
instance HasLink sub => HasLink (SessionAuth :> sub) where
|
||||
type MkLink (SessionAuth :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy @sub)
|
||||
|
||||
|
||||
|
||||
mkYesodApi :: Name -> [ResourceTree String] -> DecsQ
|
||||
mkYesodApi (nameBase -> masterN) ress = do
|
||||
let toPiecesApi :: [Piece String]
|
||||
-> ResourceTree String
|
||||
-> MaybeT Q [([Piece String], Type, [Text])]
|
||||
toPiecesApi ps (ResourceLeaf Resource{..}) = do
|
||||
Subsite{..} <- pure resourceDispatch
|
||||
Just tn <- lift $ lookupTypeName subsiteType
|
||||
TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn
|
||||
guard $ conN == ''ServantApi
|
||||
return $ pure (ps <> resourcePieces, apiT, map pack resourceAttrs)
|
||||
toPiecesApi ps (ResourceParent _ _ ps' cs)
|
||||
= lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs
|
||||
apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress
|
||||
|
||||
let apiType
|
||||
| Just apiRess' <- fromNullable $ map apiEndpoint apiRess
|
||||
= ofoldr1 (\e acc -> conT ''(:<|>) `appT` e `appT` acc) apiRess'
|
||||
| otherwise
|
||||
= conT ''EmptyAPI
|
||||
|
||||
apiEndpoint (pieces, apiT, attrs) = withAuth attrs $
|
||||
foldr (\p acc -> conT ''(:>) `appT` apiPiece p `appT` acc) (return apiT) pieces
|
||||
|
||||
withAuth attrs typ = case authDNF of
|
||||
Left t
|
||||
-> fail $ "Invalid auth tag: " <> unpack t
|
||||
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthFree) `Set.member` dnfTerms
|
||||
-> typ
|
||||
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthToken) `Set.member` dnfTerms
|
||||
-> conT ''(:>) `appT` conT ''BearerAuth `appT` typ
|
||||
Right _
|
||||
-> conT ''(:>) `appT` conT ''SessionAuth `appT` typ
|
||||
where authDNF = parsePredDNF defaultAuthDNF attrs
|
||||
|
||||
apiPiece (Static str) = litT $ strTyLit str
|
||||
apiPiece (Dynamic str) = conT ''PathPieceHttpApiData `appT` either fail return (parseType str)
|
||||
|
||||
sequence
|
||||
[ tySynD (mkName $ masterN <> "Api") [] apiType
|
||||
]
|
||||
@ -1,20 +1,15 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module ServantApi.ExternalApis
|
||||
( ExternalApis
|
||||
, ServantApiExternalApis
|
||||
, getServantApiExternalApis
|
||||
( module ServantApi.ExternalApis.Type
|
||||
) where
|
||||
|
||||
import Import.Servant
|
||||
|
||||
import ServantApi.ExternalApis.Type
|
||||
|
||||
type ExternalApis = EmptyAPI
|
||||
|
||||
type ServantApiExternalApis = ServantApi ExternalApis
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
getServantApiExternalApis :: UniWorX -> ServantApiExternalApis
|
||||
getServantApiExternalApis _ = ServantApi
|
||||
{ servantContext = \_ -> return EmptyContext
|
||||
, servantHoist = \_ _ -> id
|
||||
, servantServer = emptyServer
|
||||
}
|
||||
instance ServantApiDispatchUniWorX ExternalApis where
|
||||
servantServer' _ = return . ReplayedText . CI.original
|
||||
|
||||
20
src/ServantApi/ExternalApis/Type.hs
Normal file
20
src/ServantApi/ExternalApis/Type.hs
Normal file
@ -0,0 +1,20 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module ServantApi.ExternalApis.Type where
|
||||
|
||||
import Import.Servant.NoFoundation
|
||||
|
||||
|
||||
type ExternalApis = "echo" :> Capture "citext" (CI Text) :> Get '[PlainText] ReplayedText
|
||||
|
||||
type ServantApiExternalApis = ServantApi ExternalApis
|
||||
|
||||
instance ToCapture (Capture "citext" (CI Text)) where
|
||||
toCapture _ = DocCapture "citext" "a text to be replayed"
|
||||
|
||||
|
||||
newtype ReplayedText = ReplayedText Text
|
||||
deriving newtype (MimeRender PlainText, MimeUnrender PlainText, ToSchema)
|
||||
|
||||
instance ToSample ReplayedText where
|
||||
toSamples _ = singleSample $ ReplayedText "Hello, World!"
|
||||
37
src/Utils.hs
37
src/Utils.hs
@ -61,6 +61,8 @@ import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import Data.Universe
|
||||
|
||||
@ -89,6 +91,9 @@ import Data.Constraint (Dict(..))
|
||||
import Control.Monad.Random.Class (MonadRandom)
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
import Data.Data (Data)
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
{-# ANN module ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -130,6 +135,35 @@ maybeAttribute _ _ Nothing = []
|
||||
maybeAttribute a c (Just v) = [(a,c v)]
|
||||
|
||||
|
||||
newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent PrettyValue where
|
||||
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
|
||||
instance ToTypedContent PrettyValue where
|
||||
toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
|
||||
instance HasContentType PrettyValue where
|
||||
getContentType _ = typeJson
|
||||
|
||||
toPrettyJSON :: ToJSON a => a -> PrettyValue
|
||||
toPrettyJSON = PrettyValue . toJSON
|
||||
|
||||
|
||||
newtype YamlValue = YamlValue { unYamlValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent YamlValue where
|
||||
toContent = toContent . Yaml.encode
|
||||
instance ToTypedContent YamlValue where
|
||||
toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
|
||||
instance HasContentType YamlValue where
|
||||
getContentType _ = "text/vnd.yaml"
|
||||
|
||||
toYAML :: ToJSON a => a -> YamlValue
|
||||
toYAML = YamlValue . toJSON
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
@ -588,6 +622,9 @@ whenIsRight (Left _) _ = return ()
|
||||
|
||||
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeExceptT err act = lift act >>= maybe (throwE err) return
|
||||
|
||||
maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
|
||||
maybeExceptT' err = maybe (throwE err) return
|
||||
|
||||
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
||||
|
||||
@ -14,7 +14,6 @@ import Model
|
||||
import Model.Tokens
|
||||
|
||||
import Jose.Jwk (JwkSet(..))
|
||||
import Jose.Jwt (Jwt(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Data.Aeson.Types (Parser)
|
||||
@ -32,41 +31,42 @@ import CryptoID
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
|
||||
bearerParseJSON' :: forall m.
|
||||
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
, MonadHandler m
|
||||
bearerParseJSON' :: forall site m.
|
||||
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute site
|
||||
, Hashable (Route site)
|
||||
, MonadSite site m
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
)
|
||||
=> m (Value -> Parser (BearerToken (HandlerSite m)))
|
||||
=> m (Value -> Parser (BearerToken site))
|
||||
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
|
||||
bearerParseJSON' = do
|
||||
cidKey <- cryptoIDKey return
|
||||
return $ flip runReaderT cidKey . bearerParseJSON
|
||||
|
||||
|
||||
bearerToken :: forall m.
|
||||
( MonadHandler m
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, HasClusterID (HandlerSite m) ClusterId
|
||||
, HasAppSettings (HandlerSite m)
|
||||
bearerToken :: forall site m.
|
||||
( MonadSite site m
|
||||
, MonadIO m
|
||||
, HasInstanceID site InstanceId
|
||||
, HasClusterID site ClusterId
|
||||
, HasAppSettings site
|
||||
)
|
||||
=> Either Value (AuthId (HandlerSite m))
|
||||
-> Maybe (HashSet (Route (HandlerSite m)))
|
||||
=> Either Value (AuthId site)
|
||||
-> Maybe (HashSet (Route site))
|
||||
-> Maybe AuthDNF
|
||||
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
|
||||
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
|
||||
-> m (BearerToken (HandlerSite m))
|
||||
-> m (BearerToken site)
|
||||
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
|
||||
bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
|
||||
bearerIdentifier <- liftIO getRandom
|
||||
bearerIssuedAt <- liftIO getCurrentTime
|
||||
bearerIssuedBy <- getsYesod $ view instanceID
|
||||
bearerIssuedFor <- getsYesod $ view clusterID
|
||||
bearerIssuedBy <- getsSite $ view instanceID
|
||||
bearerIssuedFor <- getsSite $ view clusterID
|
||||
|
||||
defaultExpiration <- getsYesod $ view _appBearerExpiration
|
||||
defaultExpiration <- getsSite $ view _appBearerExpiration
|
||||
|
||||
let bearerExpiresAt
|
||||
| Just t <- mBearerExpiresAt
|
||||
@ -80,19 +80,20 @@ bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerSt
|
||||
return BearerToken{..}
|
||||
|
||||
|
||||
encodeBearer :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, RenderRoute (HandlerSite m)
|
||||
encodeBearer :: forall site m.
|
||||
( MonadSite site m
|
||||
, MonadIO m
|
||||
, HasJSONWebKeySet site JwkSet
|
||||
, HasAppSettings site
|
||||
, HasCryptoUUID (AuthId site) m
|
||||
, RenderRoute site
|
||||
)
|
||||
=> BearerToken (HandlerSite m) -> m Jwt
|
||||
=> BearerToken site -> m Jwt
|
||||
-- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
|
||||
encodeBearer token = do
|
||||
payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
jwtEncoding <- getsYesod $ view _appBearerEncoding
|
||||
JwkSet jwks <- getsSite $ view jsonWebKeySet
|
||||
jwtEncoding <- getsSite $ view _appBearerEncoding
|
||||
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
|
||||
|
||||
|
||||
@ -105,21 +106,22 @@ data BearerTokenException
|
||||
|
||||
instance Exception BearerTokenException
|
||||
|
||||
decodeBearer :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
decodeBearer :: forall site m.
|
||||
( MonadSite site m
|
||||
, MonadIO m
|
||||
, HasJSONWebKeySet site JwkSet
|
||||
, HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCrypto m
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
, ParseRoute site
|
||||
, Hashable (Route site)
|
||||
)
|
||||
=> Jwt -> m (BearerToken (HandlerSite m))
|
||||
=> Jwt -> m (BearerToken site)
|
||||
-- ^ Decode a `Jwt` and call `bearerParseJSON`
|
||||
--
|
||||
-- Throws `bearerTokenException`s
|
||||
decodeBearer (Jwt bs) = do
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
JwkSet jwks <- getsSite $ view jsonWebKeySet
|
||||
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
|
||||
content' <- case content of
|
||||
Jose.Unsecured _ -> throwM BearerTokenUnsecured
|
||||
@ -135,7 +137,7 @@ decodeBearer (Jwt bs) = do
|
||||
return bearer
|
||||
|
||||
|
||||
askBearer :: forall m. ( MonadHandler m )
|
||||
askBearer :: forall m. MonadHandler m
|
||||
=> m (Maybe Jwt)
|
||||
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
|
||||
askBearer = runMaybeT $ asum
|
||||
|
||||
@ -18,8 +18,7 @@ import Model.Types.Common
|
||||
|
||||
import Model.Tokens.Session
|
||||
|
||||
import Jose.Jwk (JwkSet)
|
||||
import Jose.Jwt (Jwt(..), JwtEncoding(..))
|
||||
import Jose.Jwt (JwtEncoding(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
import qualified Jose.Jwk as Jose
|
||||
|
||||
|
||||
@ -66,8 +66,6 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
|
||||
put = Binary.put . toPathPiece
|
||||
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
|
||||
|
||||
instance RenderRoute site => Hashable (Route site) where
|
||||
hashWithSalt s = hashWithSalt s . routeToPathPiece
|
||||
|
||||
|
||||
instance Monad FormResult where
|
||||
|
||||
475
src/Yesod/Servant.hs
Normal file
475
src/Yesod/Servant.hs
Normal file
@ -0,0 +1,475 @@
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Yesod.Servant
|
||||
( HasRoute(..)
|
||||
, ServantApi(..), getServantApi
|
||||
, ServantApiDispatch(..)
|
||||
, servantApiLink
|
||||
, ServantHandlerFor(..)
|
||||
, MonadServantHandler(..), MonadHandler(..), MonadSite(..)
|
||||
, mkYesodApi
|
||||
, PathPieceHttpApiData(..)
|
||||
, BearerAuth, SessionAuth
|
||||
, ServantErrorResponse, getServantErrorResponse
|
||||
, module Yesod.Servant.HttpApiDataInjective
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (Handler, fromList, link)
|
||||
import Control.Lens hiding (Context)
|
||||
import Control.Lens.Extras
|
||||
|
||||
import Utils hiding (HasRoute)
|
||||
import Model.Types.Security
|
||||
|
||||
import Yesod.Core ( RenderRoute(..), ParseRoute(..)
|
||||
, YesodSubDispatch(..)
|
||||
, PathPiece(..)
|
||||
)
|
||||
import Yesod.Core.Types ( YesodRunnerEnv(..)
|
||||
, YesodSubRunnerEnv(..)
|
||||
)
|
||||
import qualified Yesod.Core as Yesod
|
||||
import qualified Yesod.Core.Types as Yesod
|
||||
|
||||
import Servant.Links
|
||||
import Servant.API
|
||||
import Servant.Server hiding (route)
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Network.Wai (Request, Middleware)
|
||||
import qualified Network.Wai as W
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.Meta.Parse (parseType)
|
||||
import Yesod.Routes.TH.Types
|
||||
|
||||
import Control.Monad.Fail (MonadFail(..))
|
||||
|
||||
import Data.Data (Data)
|
||||
import GHC.Exts (IsList(..), Constraint)
|
||||
|
||||
import Servant.Swagger
|
||||
import Data.Swagger
|
||||
|
||||
import Servant.Docs
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Network.HTTP.Types.Status
|
||||
import Network.HTTP.Types.URI
|
||||
|
||||
import Control.Monad.Trans.Class (MonadTrans)
|
||||
import Control.Monad.Catch (MonadThrow(..), MonadCatch, MonadMask)
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Control.Monad.Error.Class (MonadError)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.Typeable (eqT, typeRep)
|
||||
|
||||
import Network.URI
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
|
||||
import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P)
|
||||
import Text.Show (showParen, showString)
|
||||
import qualified Text.ParserCombinators.ReadP as R
|
||||
import qualified Data.Char as Char
|
||||
|
||||
import Yesod.Servant.HttpApiDataInjective
|
||||
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
||||
import qualified Data.Binary.Builder as Builder
|
||||
|
||||
|
||||
renderServantRoute :: Link -> ([Text], [(Text, Text)])
|
||||
renderServantRoute link
|
||||
= ( linkSegments link <&> pack . unEscapeString
|
||||
, linkQueryParams link <&> paramToPair
|
||||
)
|
||||
where paramToPair (FlagParam str ) = (pack $ unEscapeString str, Text.empty)
|
||||
paramToPair (ArrayElemParam str val) = (pack $ unEscapeString str, val )
|
||||
paramToPair (SingleParam str val) = (pack $ unEscapeString str, val )
|
||||
|
||||
|
||||
escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text
|
||||
escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym
|
||||
|
||||
class HasLink api => HasRoute api where
|
||||
parseServantRoute :: ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi api))
|
||||
|
||||
instance HasRoute EmptyAPI where
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance (Typeable m, Typeable k) => HasRoute (NoContentVerb (m :: k)) where
|
||||
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(NoContentVerb m)) id mempty mempty
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance (Typeable m, Typeable k, Typeable s, Typeable ct, Typeable a, IsSubList ct ct ~ (() :: Constraint)) => HasRoute (Verb (m :: k) s ct a) where
|
||||
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Verb m s ct a)) id mempty mempty
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typeable a) => HasRoute (Stream (m :: k) status fr ct a) where
|
||||
parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Stream m status fr ct a)) id mempty mempty
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance HasRoute sub => HasRoute (HttpVersion :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs
|
||||
|
||||
instance HasRoute sub => HasRoute (Vault :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs
|
||||
|
||||
instance HasRoute sub => HasRoute (IsSecure :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs
|
||||
|
||||
instance HasRoute sub => HasRoute (RemoteHost :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs
|
||||
|
||||
instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where
|
||||
parseServantRoute (p : ps, qs)
|
||||
| p == escapedSymbol (Proxy @sym)
|
||||
= parseServantRoute @sub (ps, qs) <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs'
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where
|
||||
parseServantRoute args = asum
|
||||
[ parseServantRoute @a args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
|
||||
, parseServantRoute @b args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
|
||||
]
|
||||
|
||||
instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: *) :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs
|
||||
|
||||
instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v, Show v) => HasRoute (Capture' mods sym (v :: *) :> sub) where
|
||||
parseServantRoute ((p : ps), qs)
|
||||
| Right v <- traceShowId $ parseUrlPiece @v p
|
||||
= parseServantRoute @sub (ps, qs) <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
|
||||
|
||||
data ServantApi (api :: *) = ServantApi
|
||||
|
||||
getServantApi :: forall master api. master -> ServantApi api
|
||||
getServantApi _ = ServantApi
|
||||
|
||||
instance HasRoute api => RenderRoute (ServantApi api) where
|
||||
data Route (ServantApi api) = forall endpoint.
|
||||
( IsElem endpoint api ~ (() :: Constraint)
|
||||
, HasRoute endpoint
|
||||
, Typeable endpoint
|
||||
)
|
||||
=> ServantApiRoute
|
||||
(Proxy endpoint)
|
||||
(forall a. MkLink endpoint a -> a)
|
||||
[Text] (HashMap Text [Text])
|
||||
renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @api) (Proxy @endpoint)
|
||||
|
||||
instance HasRoute api => Eq (Route (ServantApi api)) where
|
||||
(ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
|
||||
= case eqT @endpoint @endpoint' of
|
||||
Just Refl -> ps == ps' && qs == qs'
|
||||
Nothing -> False
|
||||
|
||||
instance HasRoute api => Hashable (Route (ServantApi api)) where
|
||||
hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
|
||||
|
||||
instance HasRoute api => Read (Route (ServantApi api)) where
|
||||
readPrec = readP_to_Prec $ \d -> do
|
||||
when (d > 10) . void $ R.char '('
|
||||
R.skipSpaces
|
||||
void $ R.string "ServantApiRoute "
|
||||
R.skipSpaces
|
||||
void $ R.string "_ "
|
||||
R.skipSpaces
|
||||
asum [ do
|
||||
void $ R.char '('
|
||||
R.skipMany . R.manyTill (R.satisfy $ const True) $ R.char ')'
|
||||
void $ R.char ' '
|
||||
, R.skipMany . R.manyTill (R.satisfy $ not . Char.isSpace) $ R.satisfy Char.isSpace
|
||||
]
|
||||
R.skipSpaces
|
||||
ps <- readPrec_to_P readPrec 11
|
||||
void $ R.char ' '
|
||||
R.skipSpaces
|
||||
qs <- readPrec_to_P readPrec 11 :: R.ReadP (HashMap Text [Text])
|
||||
R.skipSpaces
|
||||
when (d > 10) . void $ R.char ')'
|
||||
maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs)
|
||||
instance HasRoute api => Show (Route (ServantApi api)) where
|
||||
showsPrec d (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = showParen (d > 10)
|
||||
$ showString "ServantApiRoute "
|
||||
. showsPrec 11 (typeRep $ Proxy @endpoint)
|
||||
. showString " _ "
|
||||
. showsPrec 11 ps
|
||||
. showString " "
|
||||
. showsPrec 11 qs
|
||||
|
||||
instance HasRoute api => ParseRoute (ServantApi api) where
|
||||
parseRoute = parseServantRoute
|
||||
|
||||
newtype ServantErrorResponse
|
||||
= ServantErrorResponse { getServantErrorResponse :: W.Response }
|
||||
|
||||
class (HasServer api context, HasRoute api) => ServantApiDispatch context m master api | master api -> context m where
|
||||
servantContext :: ServantApi api -> master -> Request -> Yesod.HandlerFor master (Context context)
|
||||
servantHoist :: ServantApi api -> master -> Request -> Context context -> (forall a. m a -> Handler a)
|
||||
servantMiddleware :: ServantApi api -> master -> Context context -> Middleware
|
||||
servantYesodMiddleware :: ServantApi api -> master -> Yesod.HandlerFor master Middleware
|
||||
servantServer :: ServantApi api -> master -> ServerT api m
|
||||
|
||||
instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi api) master where
|
||||
yesodSubDispatch YesodSubRunnerEnv{..} req
|
||||
= ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req
|
||||
where
|
||||
master :: master
|
||||
master = yreSite ysreParentEnv
|
||||
proxy :: ServantApi api
|
||||
proxy = ysreGetSub master
|
||||
|
||||
route = parseRoute ( W.pathInfo req
|
||||
, over (traverse . _2) (fromMaybe Text.empty) . queryToQueryText $ W.queryString req
|
||||
)
|
||||
|
||||
handlerT :: Yesod.HandlerFor master Yesod.TypedContent
|
||||
handlerT = do
|
||||
yesodMiddleware <- servantYesodMiddleware proxy master
|
||||
ctx <- servantContext proxy master req
|
||||
|
||||
let server' = hoistServerWithContext (Proxy @api) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
|
||||
toTypedContent = error "Servant handler did not shortcircuit"
|
||||
sendResponse res = case yesodError of
|
||||
Just err -> do
|
||||
Yesod.cacheSet $ ServantErrorResponse res
|
||||
throwM . Yesod.HCError =<< liftIO (err <$> resText)
|
||||
Nothing -> do
|
||||
when (is _Nothing route) $
|
||||
$(Yesod.logErrorS) "Servant" "Could not parse route even though servant responded successfully"
|
||||
|
||||
Yesod.sendWaiResponse res
|
||||
where
|
||||
status = W.responseStatus res
|
||||
resText = toText <$> getResBS
|
||||
where
|
||||
toText bs = case Text.decodeUtf8' bs of
|
||||
Right t -> t
|
||||
Left _ -> Text.decodeUtf8 $ Base64.encode bs
|
||||
|
||||
(_, _, resStream) = W.responseToStream res
|
||||
getResBS = resStream $ \runStream -> do
|
||||
resVar <- newTVarIO Builder.empty
|
||||
runStream (\chunk -> atomically $ modifyTVar' resVar (<> chunk)) (return ())
|
||||
toStrict . Builder.toLazyByteString <$> readTVarIO resVar
|
||||
|
||||
yesodError :: Maybe (Text -> Yesod.ErrorResponse)
|
||||
yesodError
|
||||
| status == notFound404
|
||||
= Just $ const Yesod.NotFound
|
||||
| status == internalServerError500
|
||||
= Just $ Yesod.InternalError
|
||||
| status == badRequest400
|
||||
= Just $ Yesod.InvalidArgs . pure
|
||||
| status == unauthorized401
|
||||
= Just $ const Yesod.NotAuthenticated
|
||||
| status == forbidden403
|
||||
= Just $ Yesod.PermissionDenied
|
||||
| status == methodNotAllowed405
|
||||
= Just . const . Yesod.BadMethod $ W.requestMethod req
|
||||
| otherwise = Nothing
|
||||
|
||||
fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
|
||||
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @api) ctx server') req $ unliftIO . sendResponse
|
||||
|
||||
servantApiLink :: forall p1 p2 api endpoint.
|
||||
( IsElem endpoint api ~ (() :: Constraint), HasRoute api, HasLink endpoint, Typeable endpoint )
|
||||
=> p1 api
|
||||
-> p2 endpoint
|
||||
-> MkLink endpoint (Route (ServantApi api))
|
||||
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @api . renderServantRoute) (Proxy @api) (Proxy @endpoint)
|
||||
where
|
||||
guardEndpoint :: Maybe (Route (ServantApi api)) -> Maybe (Route (ServantApi api))
|
||||
guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
|
||||
| Just Refl <- eqT @endpoint @endpoint' = x
|
||||
guardEndpoint _ = Nothing
|
||||
|
||||
|
||||
newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: site -> Handler a }
|
||||
deriving (Generic, Typeable)
|
||||
deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT site Handler)
|
||||
|
||||
class MonadIO m => MonadServantHandler site m where
|
||||
liftServantHandler :: forall a. ServantHandlerFor site a -> m a
|
||||
|
||||
instance MonadServantHandler site (ServantHandlerFor site) where
|
||||
liftServantHandler = id
|
||||
|
||||
instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadServantHandler site (t (ServantHandlerFor site)) where
|
||||
liftServantHandler = lift
|
||||
|
||||
class MonadIO m => MonadHandler m where
|
||||
liftHandler :: forall a. Handler a -> m a
|
||||
|
||||
instance MonadHandler (ServantHandlerFor site) where
|
||||
liftHandler = ServantHandlerFor . const
|
||||
|
||||
instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadHandler (t (ServantHandlerFor site)) where
|
||||
liftHandler = lift . ServantHandlerFor . const
|
||||
|
||||
class Monad m => MonadSite site m | m -> site where
|
||||
getSite :: m site
|
||||
|
||||
getsSite :: (site -> a) -> m a
|
||||
getsSite f = f <$> getSite
|
||||
|
||||
instance MonadSite site (ServantHandlerFor site) where
|
||||
getSite = liftServantHandler $ ServantHandlerFor return
|
||||
|
||||
instance MonadSite site (Reader site) where
|
||||
getSite = ask
|
||||
getsSite = asks
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, site ~ Yesod.HandlerSite m) => MonadSite site m where
|
||||
getSite = Yesod.getYesod
|
||||
getsSite = Yesod.getsYesod
|
||||
|
||||
instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site))) => MonadSite site (t (ServantHandlerFor site)) where
|
||||
getSite = lift getSite
|
||||
getsSite = lift . getsSite
|
||||
|
||||
|
||||
newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (PathPiece, ToParamSchema)
|
||||
instance PathPiece a => FromHttpApiData (PathPieceHttpApiData a) where
|
||||
parseUrlPiece = maybe (Left "Could not convert from HttpApiData via PathPiece") Right . fromPathPiece
|
||||
instance PathPiece a => ToHttpApiData (PathPieceHttpApiData a) where
|
||||
toUrlPiece = toPathPiece
|
||||
|
||||
|
||||
data BearerAuth
|
||||
data SessionAuth
|
||||
|
||||
instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where
|
||||
toSwagger _ = toSwagger (Proxy @sub)
|
||||
& securityDefinitions <>~ fromList [(defnKey, defn)]
|
||||
& allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]]
|
||||
where defnKey :: Text
|
||||
defnKey = "bearer"
|
||||
defn = SecurityScheme
|
||||
{ _securitySchemeType
|
||||
= SecuritySchemeApiKey ApiKeyParams
|
||||
{ _apiKeyName = "Authorization"
|
||||
, _apiKeyIn = ApiKeyHeader
|
||||
}
|
||||
, _securitySchemeDescription = Just
|
||||
"JSON Web Token-based API key"
|
||||
}
|
||||
|
||||
instance HasSwagger sub => HasSwagger (SessionAuth :> sub) where
|
||||
toSwagger _ = toSwagger (Proxy @sub)
|
||||
& allOperations . security <>~ [SecurityRequirement mempty]
|
||||
-- We do not expect API clients to be able/willing to conform with
|
||||
-- our CSRF mitigation, so we mark routes that require it as
|
||||
-- having unfullfillable security requirements
|
||||
|
||||
instance HasLink sub => HasLink (BearerAuth :> sub) where
|
||||
type MkLink (BearerAuth :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy @sub)
|
||||
|
||||
instance HasLink sub => HasLink (SessionAuth :> sub) where
|
||||
type MkLink (SessionAuth :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy @sub)
|
||||
|
||||
instance HasDocs sub => HasDocs (BearerAuth :> sub) where
|
||||
docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
|
||||
where action' = action & authInfo %~ (|> authInfo')
|
||||
authInfo' = DocAuthentication
|
||||
""
|
||||
"A JSON Web Token-based API key"
|
||||
|
||||
instance HasDocs sub => HasDocs (SessionAuth :> sub) where
|
||||
docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
|
||||
where action' = action & authInfo %~ (|> authInfo')
|
||||
authInfo' = DocAuthentication
|
||||
"When a web session is used for authorization, CSRF-mitigation measures must be observed."
|
||||
"An active web session identifying the user as one with sufficient authorization"
|
||||
|
||||
|
||||
|
||||
mkYesodApi :: Name -> [ResourceTree String] -> DecsQ
|
||||
mkYesodApi (nameBase -> masterN) ress = do
|
||||
let toPiecesApi :: [Piece String]
|
||||
-> ResourceTree String
|
||||
-> MaybeT Q [([Piece String], Type, [Text])]
|
||||
toPiecesApi ps (ResourceLeaf Resource{..}) = do
|
||||
Subsite{..} <- pure resourceDispatch
|
||||
Just tn <- lift $ lookupTypeName subsiteType
|
||||
TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn
|
||||
guard $ conN == ''ServantApi
|
||||
return $ pure (ps <> resourcePieces, apiT, map pack resourceAttrs)
|
||||
toPiecesApi ps (ResourceParent _ _ ps' cs)
|
||||
= lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs
|
||||
apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress
|
||||
|
||||
let apiType
|
||||
| Just apiRess' <- fromNullable $ map apiEndpoint apiRess
|
||||
= ofoldr1 (\e acc -> conT ''(:<|>) `appT` e `appT` acc) apiRess'
|
||||
| otherwise
|
||||
= conT ''EmptyAPI
|
||||
|
||||
apiEndpoint (pieces, apiT, attrs) = withAuth attrs $
|
||||
foldr (\p acc -> conT ''(:>) `appT` apiPiece p `appT` acc) (return apiT) pieces
|
||||
|
||||
withAuth attrs typ = case authDNF of
|
||||
Left t
|
||||
-> fail $ "Invalid auth tag: " <> unpack t
|
||||
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthFree) `Set.member` dnfTerms
|
||||
-> typ
|
||||
Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthToken) `Set.member` dnfTerms
|
||||
-> conT ''(:>) `appT` conT ''BearerAuth `appT` typ
|
||||
Right _
|
||||
-> conT ''(:>) `appT` conT ''SessionAuth `appT` typ
|
||||
where authDNF = parsePredDNF defaultAuthDNF attrs
|
||||
|
||||
apiPiece (Static str) = litT $ strTyLit str
|
||||
apiPiece (Dynamic str) = conT ''PathPieceHttpApiData `appT` either fail return (parseType str)
|
||||
|
||||
sequence
|
||||
[ tySynD (mkName $ masterN <> "Api") [] apiType
|
||||
]
|
||||
82
src/Yesod/Servant/HttpApiDataInjective.hs
Normal file
82
src/Yesod/Servant/HttpApiDataInjective.hs
Normal file
@ -0,0 +1,82 @@
|
||||
module Yesod.Servant.HttpApiDataInjective
|
||||
( ToHttpApiDataInjective(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (Builder)
|
||||
import Web.HttpApiData
|
||||
import Network.HTTP.Types.URI (encodePathSegmentsRelative)
|
||||
|
||||
import qualified Data.Text.Lazy as Lazy (Text)
|
||||
|
||||
import Data.Binary.Builder (Builder)
|
||||
|
||||
import Data.Void (Void)
|
||||
import Data.Int (Int8, Int16)
|
||||
import Data.Word (Word16)
|
||||
import Numeric.Natural (Natural)
|
||||
import Data.Fixed (HasResolution, Fixed)
|
||||
import Data.UUID (UUID)
|
||||
import Data.Time (ZonedTime, LocalTime, TimeOfDay, NominalDiffTime, DayOfWeek)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive.Instances ()
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Version (Version)
|
||||
import Data.Monoid (Any, All)
|
||||
|
||||
|
||||
class ToHttpApiData a => ToHttpApiDataInjective a where
|
||||
toUrlPieceInjective :: a -> Text
|
||||
toUrlPieceInjective = toUrlPiece
|
||||
|
||||
toEncodedUrlPieceInjective :: a -> Builder
|
||||
toEncodedUrlPieceInjective = encodePathSegmentsRelative . pure . toUrlPiece
|
||||
|
||||
-- | Convert to HTTP header value.
|
||||
toHeaderInjective :: a -> ByteString
|
||||
toHeaderInjective = encodeUtf8 . toUrlPiece
|
||||
|
||||
-- | Convert to query param value.
|
||||
toQueryParamInjective :: a -> Text
|
||||
toQueryParamInjective = toQueryParam
|
||||
|
||||
instance ToHttpApiDataInjective ()
|
||||
instance ToHttpApiDataInjective Bool
|
||||
instance ToHttpApiDataInjective Ordering
|
||||
instance ToHttpApiDataInjective Void
|
||||
instance ToHttpApiDataInjective Double
|
||||
instance ToHttpApiDataInjective Float
|
||||
instance ToHttpApiDataInjective Int
|
||||
instance ToHttpApiDataInjective Int8
|
||||
instance ToHttpApiDataInjective Int16
|
||||
instance ToHttpApiDataInjective Int32
|
||||
instance ToHttpApiDataInjective Int64
|
||||
instance ToHttpApiDataInjective Integer
|
||||
instance ToHttpApiDataInjective Natural
|
||||
instance ToHttpApiDataInjective Word
|
||||
instance ToHttpApiDataInjective Word8
|
||||
instance ToHttpApiDataInjective Word16
|
||||
instance ToHttpApiDataInjective Word32
|
||||
instance ToHttpApiDataInjective Word64
|
||||
instance HasResolution a => ToHttpApiDataInjective (Fixed a)
|
||||
instance ToHttpApiDataInjective Char
|
||||
instance ToHttpApiDataInjective Text
|
||||
instance ToHttpApiDataInjective Lazy.Text
|
||||
instance ToHttpApiDataInjective String
|
||||
instance ToHttpApiDataInjective str => ToHttpApiDataInjective (CI str) where
|
||||
toUrlPieceInjective = toUrlPieceInjective . CI.foldedCase
|
||||
toEncodedUrlPieceInjective = toEncodedUrlPieceInjective . CI.foldedCase
|
||||
toHeaderInjective = toHeaderInjective . CI.foldedCase
|
||||
toQueryParamInjective = toQueryParamInjective . CI.foldedCase
|
||||
instance ToHttpApiDataInjective Version
|
||||
instance ToHttpApiDataInjective All
|
||||
instance ToHttpApiDataInjective Any
|
||||
instance ToHttpApiDataInjective UTCTime
|
||||
instance ToHttpApiDataInjective ZonedTime
|
||||
instance ToHttpApiDataInjective LocalTime
|
||||
instance ToHttpApiDataInjective TimeOfDay
|
||||
instance ToHttpApiDataInjective NominalDiffTime
|
||||
instance ToHttpApiDataInjective Day
|
||||
instance ToHttpApiDataInjective DayOfWeek
|
||||
instance ToHttpApiDataInjective UUID
|
||||
instance ToHttpApiDataInjective a => ToHttpApiDataInjective (Maybe a)
|
||||
-- ^ Assumes @a@ never encodes to @"nothing"@
|
||||
@ -102,5 +102,10 @@ extra-deps:
|
||||
|
||||
- acid-state-0.16.0
|
||||
|
||||
- servant-0.17
|
||||
- servant-server-0.17
|
||||
- servant-client-0.17
|
||||
- servant-swagger-1.1.8
|
||||
|
||||
resolver: lts-15.0
|
||||
allow-newer: true
|
||||
|
||||
@ -274,6 +274,34 @@ packages:
|
||||
sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
|
||||
original:
|
||||
hackage: acid-state-0.16.0
|
||||
- completed:
|
||||
hackage: servant-0.17@sha256:e78734cb6b75c5d1e52e8f5e16bc3f557154a580bbde4932a7e1a6a90da7eb04,5029
|
||||
pantry-tree:
|
||||
size: 2392
|
||||
sha256: 36561a606c35393386aa48b7cc2407fa4013aba62a19d69f004ec9c2010209aa
|
||||
original:
|
||||
hackage: servant-0.17
|
||||
- completed:
|
||||
hackage: servant-server-0.17@sha256:1a5adf564f0b703535eb733f249b282ef2ca7b587a303c357b549fb88e7a6dcd,5388
|
||||
pantry-tree:
|
||||
size: 2460
|
||||
sha256: ea65ba54acb4362efedbfa7db616a51023579a6c83f18ab6d2ea6a84dea56021
|
||||
original:
|
||||
hackage: servant-server-0.17
|
||||
- completed:
|
||||
hackage: servant-client-0.17@sha256:433be65dd541b9a387eaaced22715a028ea846d72d141419c40ddf6fd5e3409b,4573
|
||||
pantry-tree:
|
||||
size: 1299
|
||||
sha256: 1f8f57c6ce96ed4f1316460aaab48f3765b2addbf1e2cd363c72bbc41fdcf907
|
||||
original:
|
||||
hackage: servant-client-0.17
|
||||
- completed:
|
||||
hackage: servant-swagger-1.1.8@sha256:9b0282fce7e0895f7b6e47cfea461f59ba7a1cc98e20f5b4a66e7fa24897f361,4622
|
||||
pantry-tree:
|
||||
size: 1636
|
||||
sha256: 2f1a79c09eb4fff96e6f948f15ed5d17d10eeb52de9299d57d853dbaebbda26e
|
||||
original:
|
||||
hackage: servant-swagger-1.1.8
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 488576
|
||||
|
||||
Reference in New Issue
Block a user