81 lines
2.8 KiB
Haskell
81 lines
2.8 KiB
Haskell
module Handler.CryptoIDDispatch
|
|
( getCryptoUUIDDispatchR
|
|
, getCryptoFileNameDispatchR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
|
|
|
import qualified Control.Monad.Catch as E (Handler(..))
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
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
|
|
cID' <- encrypt smid
|
|
(tid,ssh,csh,shn) <- runDB $ do
|
|
shid <- submissionSheet <$> get404 smid
|
|
Sheet{..} <- get404 shid
|
|
Course{..} <- get404 sheetCourse
|
|
return (courseTerm, courseSchool, courseShorthand, sheetName)
|
|
return $ CSubmissionR tid ssh csh shn cID' SubShowR
|
|
|
|
instance CryptoRoute (CI FilePath) SubmissionId where
|
|
cryptoIDRoute _ ciphertext
|
|
| Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
|
|
smid <- decrypt cID
|
|
(tid,ssh,csh,shn) <- runDB $ do
|
|
shid <- submissionSheet <$> get404 smid
|
|
Sheet{..} <- get404 shid
|
|
Course{..} <- get404 sheetCourse
|
|
return (courseTerm, courseSchool, courseShorthand, sheetName)
|
|
return $ CSubmissionR tid ssh csh shn cID SubShowR
|
|
| otherwise = notFound
|
|
|
|
instance CryptoRoute UUID UserId where
|
|
cryptoIDRoute _ (CryptoID -> cID) = do
|
|
(_ :: UserId) <- decrypt cID
|
|
return $ AdminUserR 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
|
|
, UserId
|
|
]
|
|
p = Proxy
|
|
|
|
getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
|
|
getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectWith found302)
|
|
where
|
|
p :: Proxy '[ SubmissionId ]
|
|
p = Proxy
|