From e3d504bd113f76854748929201c7e476c2911ee0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Mar 2020 10:27:00 +0100 Subject: [PATCH 001/309] feat(apis): integrate servant --- messages/uniworx/de-de-formal.msg | 4 +- messages/uniworx/en-eu.msg | 4 +- package.yaml | 6 + routes | 4 + src/Application.hs | 3 + src/Foundation.hs | 22 +--- src/Foundation/Routes.hs | 3 + src/Handler/Swagger.hs | 67 +++++++++++ src/Handler/Term.hs | 16 +-- src/Import/NoModel.hs | 4 +- src/Import/Servant.hs | 18 +++ src/Model/Types/Security.hs | 41 ++++++- src/ServantApi.hs | 15 +++ src/ServantApi/Definition.hs | 189 ++++++++++++++++++++++++++++++ src/ServantApi/ExternalApis.hs | 20 ++++ 15 files changed, 386 insertions(+), 30 deletions(-) create mode 100644 src/Handler/Swagger.hs create mode 100644 src/Import/Servant.hs create mode 100644 src/ServantApi.hs create mode 100644 src/ServantApi/Definition.hs create mode 100644 src/ServantApi/ExternalApis.hs diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 854adf135..d0a0bf301 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -923,7 +923,7 @@ CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in Uni2work ausgelöst hat. -InvitationUniWorXTip: Uni2work ist ein webbasiertes Lehrverwaltungssystem der LMU München. +InvitationUniWorXTip: Uni2work ist ein Lehrverwaltungssystem, welches an der Ludwig-Maximilians-Universität München entwickelt und eingesetzt wird. MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursteilnahme @@ -1293,6 +1293,8 @@ BreadcrumbAllocationUsers: Bewerber BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren +BreadcrumbExternalApis: Externe APIs +BreadcrumbSwagger: API Dokumentation ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index b0b72dc39..64e10e5ca 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -923,7 +923,7 @@ CommCourseSubject: Course message MailSubjectLecturerInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course administrator InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within Uni2work. -InvitationUniWorXTip: Uni2work is a web based teaching management system at LMU Munich. +InvitationUniWorXTip: Uni2work is a teaching management system, developed and deployed at Ludwig-Maximilians-Universität München. MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course participant @@ -1292,6 +1292,8 @@ BreadcrumbAllocationUsers: Applicants BreadcrumbAllocationPriorities: Central priorities BreadcrumbAllocationCompute: Compute allocation BreadcrumbAllocationAccept: Accept allocation +BreadcrumbExternalApis: External APIs +BreadcrumbSwagger: API documentation ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} diff --git a/package.yaml b/package.yaml index 713a25260..bd8f9700e 100644 --- a/package.yaml +++ b/package.yaml @@ -142,6 +142,12 @@ dependencies: - extended-reals - rfc5051 - pandoc + - servant + - servant-server + - servant-swagger + - swagger2 + - haskell-src-meta + - network-uri other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 125b6da56..af3f485dd 100644 --- a/routes +++ b/routes @@ -67,6 +67,8 @@ /help HelpR GET POST !free +/external-apis ExternalApisR ServantApiExternalApis getServantApiExternalApis + /user ProfileR GET POST !free /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free @@ -227,4 +229,6 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists +/swagger.json SwaggerR GET !free + !/*WellKnownFileName WellKnownR GET !free diff --git a/src/Application.hs b/src/Application.hs index 918495cc6..07303e630 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -117,6 +117,9 @@ import Handler.Metrics import Handler.ExternalExam import Handler.Participants import Handler.StorageKey +import Handler.Swagger + +import ServantApi -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index 66568e795..4d289a5a2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1280,30 +1280,13 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem , [ AuthOwner, AuthRated ] -- Submission wide ] -defaultAuthDNF :: AuthDNF -defaultAuthDNF = PredDNF $ Set.fromList - [ impureNonNull . Set.singleton $ PLVariable AuthAdmin - , impureNonNull . Set.singleton $ PLVariable AuthToken - ] - routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF -- ^ DNF up to entailment: -- -- > (A_1 && A_2 && ...) OR' B OR' ... -- -- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs - where - partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) - partition' prev t - | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) - = if - | oany (authTags `Set.isSubsetOf`) prev - -> Right prev - | otherwise - -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev - | otherwise - = Left $ InvalidAuthTag t +routeAuthTags = left InvalidAuthTag . parsePredDNF defaultAuthDNF . Set.toList . routeAttrs evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult -- ^ `tell`s disabled predicates, identified as pivots @@ -2231,6 +2214,9 @@ instance YesodBreadcrumbs UniWorX where EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + + breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing + breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger Nothing -- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index afe77ba0e..36bc627be 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -11,6 +11,8 @@ import Foundation.Type import Foundation.Routes.Definitions +import ServantApi + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers @@ -43,6 +45,7 @@ deriving instance Generic (Route UniWorX) data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where + ChildrenRouteChildren (Route ServantApiExternalApis) = '[] ChildrenRouteChildren (Route EmbeddedStatic) = '[] ChildrenRouteChildren (Route Auth) = '[] ChildrenRouteChildren UUID = '[] diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs new file mode 100644 index 000000000..d4e2bdfa1 --- /dev/null +++ b/src/Handler/Swagger.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Swagger + ( getSwaggerR + ) where + +import Import hiding (host) +import ServantApi + +import Data.Swagger +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 + +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 + app <- getYesod + let docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"] + root <- getApprootText approot app <$> waiRequest + let applyApproot = do + URI{..} <- fmap rectify . parseURIReference $ unpack root + let mbScheme = do + str <- assertM (not . null) $ stripSuffix ":" uriScheme + case str of + "https" -> return Https + "http" -> return Http + _other -> mzero + applyAuthority = do + URIAuth{..} <- uriAuthority + let mbPort = readMaybe . fromMaybe "" $ stripPrefix ":" uriPort + return $ + host ?~ Host uriRegName mbPort + return $ \x -> x + & fromMaybe id applyAuthority + & schemes .~ fmap pure mbScheme + & basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath + + + tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text) + c <- toTextUrl HelpR + + return $ toSwagger uniworxApi + & info.title .~ docMR MsgLogo + & info.description ?~ docMR MsgInvitationUniWorXTip + & info.termsOfService ?~ tos + & info.contact ?~ Contact Nothing (Just $ URL c) Nothing + & info.version .~ $gitDescribe + & fromMaybe id applyApproot diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f43384eac..3be594c33 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -197,14 +197,14 @@ data TermFormTemplate = TermFormTemplate -- | TermFormTemplates form a pointwise-left biased Semigroup instance Semigroup TermFormTemplate where - left <> right = TermFormTemplate - { tftName = tftName left <|> tftName right - , tftStart = tftStart left <|> tftStart right - , tftEnd = tftEnd left <|> tftEnd right - , tftHolidays = tftHolidays left <|> tftHolidays right - , tftLectureStart = tftLectureStart left <|> tftLectureStart right - , tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right - , tftActive = tftActive left <|> tftActive right + l <> r = TermFormTemplate + { tftName = tftName l <|> tftName r + , tftStart = tftStart l <|> tftStart r + , tftEnd = tftEnd l <|> tftEnd r + , tftHolidays = tftHolidays l <|> tftHolidays r + , tftLectureStart = tftLectureStart l <|> tftLectureStart r + , tftLectureEnd = tftLectureEnd l <|> tftLectureEnd r + , tftActive = tftActive l <|> tftActive r } instance Monoid TermFormTemplate where diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 723c699db..8e83cfb89 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -27,6 +27,8 @@ 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 @@ -165,7 +167,7 @@ import Control.Lens as Import import Control.Lens.Extras as Import (is) import Data.Set.Lens as Import -import Control.Arrow as Import (Kleisli(..)) +import Control.Arrow as Import (left, right, Kleisli(..)) import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString) import Data.Encoding.UTF8 as Import (UTF8(UTF8)) diff --git a/src/Import/Servant.hs b/src/Import/Servant.hs new file mode 100644 index 000000000..f4131c854 --- /dev/null +++ b/src/Import/Servant.hs @@ -0,0 +1,18 @@ +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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 71e35fbdf..87add310a 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -9,7 +9,19 @@ module Model.Types.Security ( module Model.Types.Security ) where -import Import.NoModel +import ClassyPrelude + +import Data.Aeson +import Data.Aeson.TH +import Utils.PathPiece +import Model.Types.TH.JSON +import Data.Universe +import Data.Universe.Instances.Reverse () +import Data.Default +import Web.PathPieces +import Data.Proxy + +import qualified Data.Set as Set import qualified Data.Text as Text @@ -17,9 +29,14 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Aeson.Types as Aeson +import Data.Binary (Binary) import qualified Data.Binary as Binary +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Data.NonNull.Instances () import Model.Types.TH.PathPiece import Database.Persist.Sql @@ -138,6 +155,21 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Semigroup, Monoid) +parsePredDNF :: forall a. (Ord a, PathPiece a) => PredDNF a -> [Text] -> Either Text (PredDNF a) +parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms start) + where + partition' :: Set (Set (PredLiteral a)) -> Text -> Either Text (Set (Set (PredLiteral a))) + partition' prev t + | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) + = if + | oany (authTags `Set.isSubsetOf`) prev + -> Right prev + | otherwise + -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev + | otherwise + = Left t + + $(return []) instance ToJSON a => ToJSON (PredDNF a) where @@ -153,6 +185,13 @@ type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag +defaultAuthDNF :: AuthDNF +defaultAuthDNF = PredDNF $ Set.fromList + [ impureNonNull . Set.singleton $ PLVariable AuthAdmin + , impureNonNull . Set.singleton $ PLVariable AuthToken + ] + + data UserGroupName = UserGroupMetrics diff --git a/src/ServantApi.hs b/src/ServantApi.hs new file mode 100644 index 000000000..b0761b9c3 --- /dev/null +++ b/src/ServantApi.hs @@ -0,0 +1,15 @@ +module ServantApi + ( module ServantApi + ) where + +import Import.Servant +import Foundation.Routes.Definitions + + +import ServantApi.ExternalApis as ServantApi + + +mkYesodApi ''UniWorX uniworxRoutes + +uniworxApi :: Proxy UniWorXApi +uniworxApi = Proxy diff --git a/src/ServantApi/Definition.hs b/src/ServantApi/Definition.hs new file mode 100644 index 000000000..4faa7a7be --- /dev/null +++ b/src/ServantApi/Definition.hs @@ -0,0 +1,189 @@ +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 new file mode 100644 index 000000000..f57dc85ff --- /dev/null +++ b/src/ServantApi/ExternalApis.hs @@ -0,0 +1,20 @@ +module ServantApi.ExternalApis + ( ExternalApis + , ServantApiExternalApis + , getServantApiExternalApis + ) where + +import Import.Servant + + +type ExternalApis = EmptyAPI + +type ServantApiExternalApis = ServantApi ExternalApis + + +getServantApiExternalApis :: UniWorX -> ServantApiExternalApis +getServantApiExternalApis _ = ServantApi + { servantContext = \_ -> return EmptyContext + , servantHoist = \_ _ -> id + , servantServer = emptyServer + } -- 2.39.2 From bf2ff2dc9c4a986e9088feca41c00123bf2c785a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 3 Apr 2020 14:40:48 +0200 Subject: [PATCH 002/309] feat(apis): further integrate servant --- config/settings.yml | 2 +- frontend/src/app.sass | 9 + messages/uniworx/de-de-formal.msg | 4 +- package.yaml | 3 + routes | 6 +- src/Application.hs | 3 +- src/CryptoID.hs | 1 + src/Data/CaseInsensitive/Instances.hs | 11 +- src/Foundation.hs | 157 +++++-- src/Foundation/Routes.hs | 25 +- src/Foundation/Servant.hs | 118 +++++ src/Handler/ApiDocs.hs | 29 ++ src/Handler/Swagger.hs | 55 ++- src/Handler/Utils/Form/MassInput.hs | 2 +- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Handler/Utils/Tokens.hs | 22 +- src/Import/NoModel.hs | 9 +- src/Import/Servant.hs | 19 +- src/Import/Servant/NoFoundation.hs | 24 + src/Jose/Jwk/Instances.hs | 12 + src/Jose/Jwt/Instances.hs | 3 + src/Model/Tokens/Bearer.hs | 14 +- src/Model/Types.hs | 1 + src/Model/Types/Apis.hs | 24 + src/Model/Types/Security.hs | 11 +- src/Model/Types/Sheet.hs | 5 +- src/Model/Types/Submission.hs | 4 +- src/ServantApi.hs | 1 - src/ServantApi/Definition.hs | 189 -------- src/ServantApi/ExternalApis.hs | 19 +- src/ServantApi/ExternalApis/Type.hs | 20 + src/Utils.hs | 37 ++ src/Utils/Tokens.hs | 74 +-- src/Web/ServerSession/Frontend/Yesod/Jwt.hs | 3 +- src/Yesod/Core/Instances.hs | 2 - src/Yesod/Servant.hs | 475 ++++++++++++++++++++ src/Yesod/Servant/HttpApiDataInjective.hs | 82 ++++ stack.yaml | 5 + stack.yaml.lock | 28 ++ 39 files changed, 1146 insertions(+), 364 deletions(-) create mode 100644 src/Foundation/Servant.hs create mode 100644 src/Handler/ApiDocs.hs create mode 100644 src/Import/Servant/NoFoundation.hs create mode 100644 src/Jose/Jwk/Instances.hs create mode 100644 src/Model/Types/Apis.hs delete mode 100644 src/ServantApi/Definition.hs create mode 100644 src/ServantApi/ExternalApis/Type.hs create mode 100644 src/Yesod/Servant.hs create mode 100644 src/Yesod/Servant/HttpApiDataInjective.hs diff --git a/config/settings.yml b/config/settings.yml index 449757de4..15bfd8526 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/frontend/src/app.sass b/frontend/src/app.sass index c1f05706c..81f4f803e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d0a0bf301..3c3b045fd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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} diff --git a/package.yaml b/package.yaml index bd8f9700e..dd3b531a1 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/routes b/routes index af3f485dd..be75be25f 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 07303e630..77b2301e9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 02ec64b11..78bebd386 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseNewsId , ''CourseEventId , ''TutorialId + , ''ExternalApiId ] -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 6596fe47e..45e9652e8 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -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) diff --git a/src/Foundation.hs b/src/Foundation.hs index 4d289a5a2..054c1ef50 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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| -

_{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|
+