feat(foundation): move stuff out of Foundation

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

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)

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")

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