69 lines
2.1 KiB
Haskell
69 lines
2.1 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, DataKinds
|
|
, KindSignatures
|
|
, TypeFamilies
|
|
, FlexibleInstances
|
|
, TypeOperators
|
|
, RankNTypes
|
|
, PolyKinds
|
|
, RecordWildCards
|
|
, MultiParamTypeClasses
|
|
, ScopedTypeVariables
|
|
, ViewPatterns
|
|
#-}
|
|
|
|
module Handler.CryptoIDDispatch
|
|
( getCryptoUUIDDispatchR
|
|
) where
|
|
|
|
import Import hiding (Proxy)
|
|
|
|
import Data.Proxy
|
|
|
|
import Handler.Utils
|
|
|
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
|
|
|
import qualified Control.Monad.Catch as E (Handler(..))
|
|
|
|
|
|
class CryptoRoute ciphertext plaintext where
|
|
cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
|
|
|
|
instance CryptoRoute UUID SubmissionId where
|
|
cryptoIDRoute _ (CryptoID -> cID) = do
|
|
(smid :: SubmissionId) <- decrypt cID
|
|
(tid,csh,shn) <- runDB $ do
|
|
shid <- submissionSheet <$> get404 smid
|
|
Sheet{..} <- get404 shid
|
|
Course{..} <- get404 sheetCourse
|
|
return (courseTerm, courseShorthand, sheetName)
|
|
return $ CSheetR tid csh shn $ SubmissionR cID
|
|
|
|
|
|
class Dispatch ciphertext (x :: [*]) where
|
|
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
|
|
|
|
instance Dispatch ciphertext '[] where
|
|
dispatchID _ _ = return Nothing
|
|
|
|
instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where
|
|
dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail
|
|
where
|
|
dispatchHead = (Just <$> cryptoIDRoute (Proxy :: Proxy plaintext) ciphertext) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ]
|
|
where
|
|
handleHCError :: HandlerContents -> Handler (Maybe a)
|
|
handleHCError (HCError NotFound) = return Nothing
|
|
handleHCError e = throwM e
|
|
handleCryptoID :: CryptoIDError -> Handler (Maybe a)
|
|
handleCryptoID _ = return Nothing
|
|
dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
|
|
|
|
|
|
getCryptoUUIDDispatchR :: UUID -> Handler ()
|
|
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
|
|
where
|
|
p :: Proxy '[ SubmissionId
|
|
]
|
|
p = Proxy
|