diff --git a/src/Foundation.hs b/src/Foundation.hs index 3014250a6..1e7d8db89 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -71,6 +71,7 @@ import Handler.Utils.SchoolLdap import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.Course import Handler.Utils.Profile +import Handler.Utils.Routes import Utils.Form import Utils.Sheet import Utils.SystemMessage @@ -96,86 +97,12 @@ import qualified Ldap.Client as Ldap import UnliftIO.Pool - --- 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 --- --- Note that this is really half the story; in Application.hs, mkYesodDispatch --- generates the rest of the code. Please see the following documentation --- for an explanation for this split: --- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules --- --- This function also generates the following type synonyms: --- type Handler x = HandlerT UniWorX IO x --- type Widget = WidgetT UniWorX IO () -mkYesodData "UniWorX" uniworxRoutes - -deriving instance Generic CourseR -deriving instance Generic SheetR -deriving instance Generic SubmissionR -deriving instance Generic MaterialR -deriving instance Generic TutorialR -deriving instance Generic ExamR -deriving instance Generic CourseApplicationR -deriving instance Generic AllocationR -deriving instance Generic SchoolR -deriving instance Generic ExamOfficeR -deriving instance Generic CourseNewsR -deriving instance Generic CourseEventR -deriving instance Generic (Route UniWorX) - -data RouteChildren -type instance Children RouteChildren a = ChildrenRouteChildren a -type family ChildrenRouteChildren a where - ChildrenRouteChildren (Route EmbeddedStatic) = '[] - ChildrenRouteChildren (Route Auth) = '[] - ChildrenRouteChildren UUID = '[] - ChildrenRouteChildren (Key a) = '[] - ChildrenRouteChildren (CI a) = '[] - - ChildrenRouteChildren a = Children ChGeneric a - -- | Convenient Type Synonyms: type DB = YesodDB UniWorX type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerFor UniWorX) a --- Pattern Synonyms for convenience -pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX -pattern CSheetR tid ssh csh shn ptn - = CourseR tid ssh csh (SheetR shn ptn) - -pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX -pattern CMaterialR tid ssh csh mnm ptn - = CourseR tid ssh csh (MaterialR mnm ptn) - -pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX -pattern CTutorialR tid ssh csh tnm ptn - = CourseR tid ssh csh (TutorialR tnm ptn) - -pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX -pattern CExamR tid ssh csh tnm ptn - = CourseR tid ssh csh (ExamR tnm ptn) - -pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX -pattern CSubmissionR tid ssh csh shn cid ptn - = CSheetR tid ssh csh shn (SubmissionR cid ptn) - -pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX -pattern CApplicationR tid ssh csh appId ptn - = CourseR tid ssh csh (CourseApplicationR appId ptn) - -pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX -pattern CNewsR tid ssh csh nId ptn - = CourseR tid ssh csh (CourseNewsR nId ptn) - -pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX -pattern CEventR tid ssh csh nId ptn - = CourseR tid ssh csh (CourseEventR nId ptn) - - -- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces @@ -1486,6 +1413,7 @@ siteLayout' headingOverride widget = do primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages mcurrentRoute <- getCurrentRoute + let currentHandler = classifyHandler <$> mcurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. let diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 614bdea6d..0e83a0734 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -1,10 +1,84 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Foundation.Routes - ( uniworxRoutes + ( module Foundation.Routes.Definitions + , module Foundation.Routes ) where -import ClassyPrelude.Yesod -import Yesod.Routes.TH.Types (ResourceTree) +import Import.NoFoundation +import Foundation.Type +import Foundation.Routes.Definitions -uniworxRoutes :: [ResourceTree String] -uniworxRoutes = $(parseRoutesFile "routes") +-- 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 +-- +-- Note that this is really half the story; in Application.hs, mkYesodDispatch +-- generates the rest of the code. Please see the following documentation +-- for an explanation for this split: +-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules +-- +-- This function also generates the following type synonyms: +-- type Handler x = HandlerT UniWorX IO x +-- type Widget = WidgetT UniWorX IO () +mkYesodData "UniWorX" uniworxRoutes + +deriving instance Generic CourseR +deriving instance Generic SheetR +deriving instance Generic SubmissionR +deriving instance Generic MaterialR +deriving instance Generic TutorialR +deriving instance Generic ExamR +deriving instance Generic CourseApplicationR +deriving instance Generic AllocationR +deriving instance Generic SchoolR +deriving instance Generic ExamOfficeR +deriving instance Generic CourseNewsR +deriving instance Generic CourseEventR +deriving instance Generic (Route UniWorX) + +data RouteChildren +type instance Children RouteChildren a = ChildrenRouteChildren a +type family ChildrenRouteChildren a where + ChildrenRouteChildren (Route EmbeddedStatic) = '[] + ChildrenRouteChildren (Route Auth) = '[] + ChildrenRouteChildren UUID = '[] + ChildrenRouteChildren (Key a) = '[] + ChildrenRouteChildren (CI a) = '[] + + ChildrenRouteChildren a = Children ChGeneric a + +-- Pattern Synonyms for convenience +pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX +pattern CSheetR tid ssh csh shn ptn + = CourseR tid ssh csh (SheetR shn ptn) + +pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX +pattern CMaterialR tid ssh csh mnm ptn + = CourseR tid ssh csh (MaterialR mnm ptn) + +pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX +pattern CTutorialR tid ssh csh tnm ptn + = CourseR tid ssh csh (TutorialR tnm ptn) + +pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX +pattern CExamR tid ssh csh tnm ptn + = CourseR tid ssh csh (ExamR tnm ptn) + +pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX +pattern CSubmissionR tid ssh csh shn cid ptn + = CSheetR tid ssh csh shn (SubmissionR cid ptn) + +pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX +pattern CApplicationR tid ssh csh appId ptn + = CourseR tid ssh csh (CourseApplicationR appId ptn) + +pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX +pattern CNewsR tid ssh csh nId ptn + = CourseR tid ssh csh (CourseNewsR nId ptn) + +pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX +pattern CEventR tid ssh csh nId ptn + = CourseR tid ssh csh (CourseEventR nId ptn) diff --git a/src/Foundation/Routes/Definitions.hs b/src/Foundation/Routes/Definitions.hs new file mode 100644 index 000000000..4908a25ee --- /dev/null +++ b/src/Foundation/Routes/Definitions.hs @@ -0,0 +1,10 @@ +module Foundation.Routes.Definitions + ( uniworxRoutes + ) where + +import ClassyPrelude.Yesod +import Yesod.Routes.TH.Types (ResourceTree) + + +uniworxRoutes :: [ResourceTree String] +uniworxRoutes = $(parseRoutesFile "routes") diff --git a/src/Handler/Utils/Routes.hs b/src/Handler/Utils/Routes.hs index 52a93dfed..345718bcb 100644 --- a/src/Handler/Utils/Routes.hs +++ b/src/Handler/Utils/Routes.hs @@ -2,7 +2,9 @@ module Handler.Utils.Routes ( classifyHandler ) where -import Import +import Import.NoFoundation +import Foundation.Routes +import Foundation.Type import Utils.TH.Routes