46 lines
1.6 KiB
Haskell
46 lines
1.6 KiB
Haskell
module Handler.Sheet.Pseudonym
|
|
( getSPseudonymR, postSPseudonymR
|
|
, ButtonGeneratePseudonym(..)
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
|
|
|
|
data ButtonGeneratePseudonym = BtnGenerate
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonGeneratePseudonym
|
|
instance Finite ButtonGeneratePseudonym
|
|
|
|
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
|
|
|
|
instance Button UniWorX ButtonGeneratePseudonym where
|
|
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
|
|
btnClasses BtnGenerate = [BCIsButton, BCDefault]
|
|
|
|
|
|
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
|
getSPseudonymR = postSPseudonymR
|
|
postSPseudonymR tid ssh csh shn = do
|
|
uid <- requireAuthId
|
|
shId <- runDB $ fetchSheetId tid ssh csh shn
|
|
let
|
|
genPseudonym = do
|
|
inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
|
|
candidate <- liftIO getRandom
|
|
existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
|
|
case existing of
|
|
Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
|
|
Nothing
|
|
-> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
|
|
case inserted of
|
|
Right Nothing -> genPseudonym
|
|
Right (Just ps) -> return ps
|
|
Left ps -> return ps
|
|
ps <- genPseudonym
|
|
selectRep $ do
|
|
provideRep . return $ review _PseudonymText ps
|
|
provideJson ps
|
|
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
|