Framework & dispatch submissions

package.yaml

@@ -75,6 +75,7 @@ dependencies:
 - yesod-auth-ldap
 - LDAP
 - parsec
+- uuid
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -29,5 +29,7 @@
 !/submission/archive/#FilePath SubmissionDownloadArchiveR GET
 !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
 
+!/#UUID CryptoUUIDDispatchR GET
+
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/Application.hs

@@ -46,6 +46,7 @@ import Handler.Term
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
+import Handler.CryptoIDDispatch
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/Foundation.hs

@@ -133,6 +133,7 @@ instance Yesod UniWorX where
     isAuthorized  CourseListR        _ = return Authorized
     isAuthorized (CourseListTermR _) _ = return Authorized
     isAuthorized (CourseShowR _ _)   _ = return Authorized
+    isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
     isAuthorized  SubmissionListR    _ = isAuthenticated
     isAuthorized  SubmissionDownloadMultiArchiveR _ = isAuthenticated
 --     isAuthorized  TestR        _ = return Authorized

src/Handler/CryptoIDDispatch.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , KindSignatures
+           , TypeFamilies
+           , FlexibleInstances
+           , TypeOperators
+           , RankNTypes
+           , PolyKinds
+           , RecordWildCards
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+  #-}
+
+module Handler.CryptoIDDispatch
+  ( getCryptoUUIDDispatchR
+  ) where
+
+import GHC.TypeLits
+import Import hiding (Proxy)
+
+import Data.Proxy
+
+
+class KnownSymbol namespace => CryptoRoute ciphertext namespace where
+  cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX)
+
+instance CryptoRoute UUID "Submission" where
+  cryptoIDRoute = return . SubmissionR
+
+
+class Dispatch ciphertext (x :: [Symbol]) where
+  dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
+
+instance Dispatch ciphertext '[] where
+  dispatchID _ _ = return Nothing
+
+instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where
+  dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail
+    where
+      headID :: CryptoID namespace ciphertext
+      headID = CryptoID{..}
+      dispatchHead = (Just <$> cryptoIDRoute headID) `catchAny` (\_ -> return Nothing)
+      dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext
+  
+
+getCryptoUUIDDispatchR :: UUID -> Handler ()
+getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound redirect
+  where
+    p :: Proxy '["Submission"]
+    p = Proxy

src/Import/NoFoundation.hs

@@ -14,3 +14,4 @@ import Yesod.Default.Config2 as Import
 import Data.Fixed            as Import
 
 import CryptoID              as Import
+import Data.UUID             as Import (UUID)