_{MsgErrorResponseEncrypted} -
- #{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|
+ _{MsgErrorResponseEncrypted}
+
+ #{ciphertext}
+ |]
+ | otherwise -> plaintext
+
+ errPage = case err of
+ NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
+ InternalError err' -> encrypted err' [whamlet|
#{err'}|]
+ InvalidArgs errs -> [whamlet|
+
_{MsgErrorResponseNotFound}|] - InternalError err' -> encrypted err' [whamlet|
#{err'}|] - InvalidArgs errs -> [whamlet| -
_{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err' -> [whamlet|
#{err'}|] - BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - toWidget - [cassius| - .errMsg - white-space: pre-wrap - font-family: monospace - |] - errPage + NotAuthenticated -> [whamlet|
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err' -> [whamlet|
#{err'}|] + BadMethod method -> [whamlet|
_{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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 36bc627be..e5c56ef44 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -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 diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs new file mode 100644 index 000000000..5f90c95a8 --- /dev/null +++ b/src/Foundation/Servant.hs @@ -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 } diff --git a/src/Handler/ApiDocs.hs b/src/Handler/ApiDocs.hs new file mode 100644 index 000000000..5b982af15 --- /dev/null +++ b/src/Handler/ApiDocs.hs @@ -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 + [ + ] diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs index d4e2bdfa1..9e4c7fdd1 100644 --- a/src/Handler/Swagger.hs +++ b/src/Handler/Swagger.hs @@ -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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index e612b5fe7..e986bb9d1 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 6943ffb61..7d4454b62 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs index 83266119f..bfdb26819 100644 --- a/src/Handler/Utils/Tokens.hs +++ b/src/Handler/Utils/Tokens.hs @@ -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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 8e83cfb89..189f19602 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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 () diff --git a/src/Import/Servant.hs b/src/Import/Servant.hs index f4131c854..05160ee18 100644 --- a/src/Import/Servant.hs +++ b/src/Import/Servant.hs @@ -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 diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs new file mode 100644 index 000000000..99842c491 --- /dev/null +++ b/src/Import/Servant/NoFoundation.hs @@ -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(..) + ) diff --git a/src/Jose/Jwk/Instances.hs b/src/Jose/Jwk/Instances.hs new file mode 100644 index 000000000..b5a314656 --- /dev/null +++ b/src/Jose/Jwk/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Jose.Jwk.Instances + ( + ) where + +import Model.Types.TH.JSON + +import Jose.Jwk + + +derivePersistFieldJSON ''JwkSet diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs index 0c0c093ef..ee86892a8 100644 --- a/src/Jose/Jwt/Instances.hs +++ b/src/Jose/Jwt/Instances.hs @@ -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 diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index c1c4578fb..775d60166 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3797b0647..8f3a71ffd 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Model/Types/Apis.hs b/src/Model/Types/Apis.hs new file mode 100644 index 000000000..a1fc65cc9 --- /dev/null +++ b/src/Model/Types/Apis.hs @@ -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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 87add310a..568d0dd48 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -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 diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 10ec7ceef..67af2f4b0 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -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 diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index b8ace9549..3a2c4788d 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -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 diff --git a/src/ServantApi.hs b/src/ServantApi.hs index b0761b9c3..e4a66c1bd 100644 --- a/src/ServantApi.hs +++ b/src/ServantApi.hs @@ -3,7 +3,6 @@ module ServantApi ) where import Import.Servant -import Foundation.Routes.Definitions import ServantApi.ExternalApis as ServantApi diff --git a/src/ServantApi/Definition.hs b/src/ServantApi/Definition.hs deleted file mode 100644 index 4faa7a7be..000000000 --- a/src/ServantApi/Definition.hs +++ /dev/null @@ -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 - ] diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs index f57dc85ff..6f9f07b8b 100644 --- a/src/ServantApi/ExternalApis.hs +++ b/src/ServantApi/ExternalApis.hs @@ -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 diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs new file mode 100644 index 000000000..9995fb33d --- /dev/null +++ b/src/ServantApi/ExternalApis/Type.hs @@ -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!" diff --git a/src/Utils.hs b/src/Utils.hs index f8879cf98..f04771074 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index e7853f525..5404e3c3c 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -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 diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index 29c5e081b..22a90725f 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -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 diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index e145d6575..728612383 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -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 diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs new file mode 100644 index 000000000..0e8ae5a74 --- /dev/null +++ b/src/Yesod/Servant.hs @@ -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 + ] diff --git a/src/Yesod/Servant/HttpApiDataInjective.hs b/src/Yesod/Servant/HttpApiDataInjective.hs new file mode 100644 index 000000000..8294b9de4 --- /dev/null +++ b/src/Yesod/Servant/HttpApiDataInjective.hs @@ -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"@ diff --git a/stack.yaml b/stack.yaml index 07c492062..283d5ef92 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock index f8e0d7b61..f5b97ea23 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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