From db92528884d6b8b310470fc0f94ef46d3157682e Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Sun, 14 Jan 2018 01:17:31 +0100
Subject: [PATCH] Framework & dispatch submissions

---
 package.yaml                    |  1 +
 routes                          |  2 ++
 src/Application.hs              |  1 +
 src/Foundation.hs               |  1 +
 src/Handler/CryptoIDDispatch.hs | 50 +++++++++++++++++++++++++++++++++
 src/Import/NoFoundation.hs      |  1 +
 6 files changed, 56 insertions(+)
 create mode 100644 src/Handler/CryptoIDDispatch.hs

diff --git a/package.yaml b/package.yaml
index 9d3b509b1..99ef36dd0 100644
--- a/package.yaml
+++ b/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.
diff --git a/routes b/routes
index 4085fd935..835f50270 100644
--- a/routes
+++ b/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
diff --git a/src/Application.hs b/src/Application.hs
index 403bf072c..4b558617d 100644
--- a/src/Application.hs
+++ b/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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index ae0b849bb..954a132e0 100644
--- a/src/Foundation.hs
+++ b/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
diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs
new file mode 100644
index 000000000..450f6944e
--- /dev/null
+++ b/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
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 324a88840..9b688de60 100644
--- a/src/Import/NoFoundation.hs
+++ b/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)