From 8e28c397fdc397b1bad9760642d2f9cc47157e38 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 15 Oct 2018 08:44:12 +0200
Subject: [PATCH] Return existing in SPseudonymR

---
 routes                     |  2 +-
 src/Handler/Sheet.hs       | 18 +++++++++++++-----
 src/Import/NoFoundation.hs |  1 +
 src/Model/Types.hs         | 32 +++++++++++++++++++++++++++++++-
 4 files changed, 46 insertions(+), 7 deletions(-)

diff --git a/routes b/routes
index 5a4d9b4a6..f30623faa 100644
--- a/routes
+++ b/routes
@@ -80,7 +80,7 @@
       /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
-    /pseudonym                  SPseudonymR   POST            !registeredANDcorrector-submissions
+    /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index bb3e5d78a..181e87494 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -49,6 +49,8 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 -- import qualified Data.List as List
 
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE)
+
 import Network.Mime
 
 import Data.Set (Set)
@@ -346,22 +348,28 @@ getSShowR tid ssh csh shn = do
     $(widgetFile "sheetShow")
 
 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 <- runDB . setSerializable $ do
+      inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
         candidate <- liftIO getRandom
-        fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
+        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
-        Nothing -> genPseudonym
-        Just ps -> return ps
+        Right Nothing -> genPseudonym
+        Right (Just ps) -> return ps
+        Left ps -> return ps
   ps <- genPseudonym
   let ps' = Text.unwords . map CI.original $ review pseudonymWords ps
   selectRep $ do
     provideRep $ return ps'
-    provideRep . return $ Aeson.String ps'
+    provideJson ps
     provideRep (redirect $ CSheetR tid ssh csh shn SShowR :: Handler Html)
 
 
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index fc3bdcda9..e337b361f 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -13,6 +13,7 @@ import Yesod.Auth             as Import
 import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Utils                  as Import
+import Yesod.Core.Json        as Import (provideJson)
 
 
 import Data.Fixed             as Import
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index afb60da3c..5f0e9dab7 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE MultiWayIf #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
@@ -541,7 +542,14 @@ newtype Pseudonym = Pseudonym Word24
 
 instance PersistField Pseudonym where
   toPersistValue p = toPersistValue (fromIntegral p :: Word32)
-  fromPersistValue = fmap (fromIntegral :: Word32 -> Pseudonym) . fromPersistValue
+  fromPersistValue v = do
+    w <- fromPersistValue v :: Either Text Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> Left "Pseudonym out of range"
 
 instance PersistFieldSql Pseudonym where
   sqlType _ = SqlInt32
@@ -550,6 +558,28 @@ instance Random Pseudonym where
   randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
   random = randomR (minBound, maxBound)
 
+instance FromJSON Pseudonym where
+  parseJSON v@(Aeson.Number _) = do
+    w <- parseJSON v :: Aeson.Parser Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> fail "Pseudonym out auf range"
+  parseJSON (Aeson.String (map CI.mk . Text.words -> ws))
+    = case preview pseudonymWords ws of
+        Just p -> return p
+        Nothing -> fail "Could not parse pseudonym"
+  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
+    ws' <- toList . map CI.mk <$> mapM parseJSON ws
+    case preview pseudonymWords ws' of
+      Just p -> return p
+      Nothing -> fail "Could not parse pseudonym words"
+
+instance ToJSON Pseudonym where
+  toJSON = toJSON . (review pseudonymWords :: Pseudonym -> [CI Text])
+
 pseudonymWordlist :: [CI Text]
 pseudonymWordlist = $(wordlist "config/wordlist.txt")