module Handler.Exam.Correct
  ( getECorrectR, postECorrectR
  ) where

import Import

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI (original)

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import Handler.Utils
import Handler.Utils.Exam (fetchExam)


data CorrectInterfaceUser
  = CorrectInterfaceUser
    { ciuSurname     :: Text
    , ciuDisplayName :: Text
    , ciuMatNr       :: Maybe UserMatriculation
    , ciuId          :: CryptoUUIDUser
    } deriving (Eq,Ord)
deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''CorrectInterfaceUser

data CorrectInterfaceResponse
  = CorrectInterfaceResponseSuccess
    { cirsUser       :: CorrectInterfaceUser
    , cirsResults    :: Map ExamPartNumber (Maybe Points)
    , cirsTime       :: UTCTime
    }
  | CorrectInterfaceResponseAmbiguous
    { ciraUsers      :: Set CorrectInterfaceUser
    , ciraMessage    :: Text
    }
  | CorrectInterfaceResponseFailure
    { cirfMessage    :: Text
    }
  | CorrectInterfaceResponseNoOp
    { cirnUsers      :: Set CorrectInterfaceUser
    }
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  , fieldLabelModifier     = camelToPathPiece' 1
  , sumEncoding            = TaggedObject "status" "results"
  } ''CorrectInterfaceResponse
-- E.g.: { "status": "success", "user-ident": "Max Musterstudent", "user-matrikelnummer": "123", "results": { "1a": null, "2a": 7, "2c3.5": 12 } }

data CorrectInterfaceRequest
  = CorrectInterfaceRequest
    { ciqName        :: Text
    , ciqResults     :: Map ExamPartNumber (Maybe Points)
    , ciqOp          :: Bool  -- not no-op
    }
deriveJSON defaultOptions
  { fieldLabelModifier     = camelToPathPiece' 1
  } ''CorrectInterfaceRequest
-- E.g.: { "name": "max", "results": { "1a": null, "2c3.5": 9001.2 }}
 

getECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getECorrectR tid ssh csh examn = do
  MsgRenderer mr <- getMsgRenderer

  (Entity _ Exam{..}, examParts) <- runDB $ do
    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
    examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
    return (exam, entityVal <$> examParts)
  
  let
    heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName
    
    ptsInput :: ExamPartNumber -> Widget
    ptsInput n = do
      name <- newIdent
      fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False
    
    participantHeadTooltip = [whamlet| _{MsgExamCorrectHeadParticipantTooltip} |]

    examCorrectIdent = intercalate "-" [toPathPiece tid, toPathPiece ssh, toPathPiece csh, toPathPiece examn]

  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "exam-correct")


postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Void
postECorrectR tid ssh csh examn = do
  MsgRenderer mr <- getMsgRenderer

  CorrectInterfaceRequest{ciqName,ciqResults,ciqOp} <- requireCheckJsonBody

  response <- runDB $ do
    Entity eId _ <- fetchExam tid ssh csh examn

    participantMatches <- E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
      E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
      E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
      E.where_ $ user E.^. UserMatrikelnummer E.==. E.val (Just ciqName)
           E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val (Just ciqName)
           E.||. user E.^. UserSurname E.==. E.val ciqName
           E.||. user E.^. UserSurname `E.hasInfix` E.val ciqName
           E.||. user E.^. UserFirstName E.==. E.val ciqName
           E.||. user E.^. UserFirstName `E.hasInfix` E.val ciqName
           E.||. user E.^. UserDisplayName E.==. E.val ciqName
           E.||. user E.^. UserDisplayName `E.hasInfix` E.val ciqName
      return user

    let
      userToResponse (Entity uid User{..}) = do
        uuid <- encrypt uid
        return CorrectInterfaceUser
          { ciuSurname     = userSurname
          , ciuDisplayName = userDisplayName
          , ciuMatNr       = userMatrikelnummer
          , ciuId          = uuid
          }

    if
      -- on no-op request, answer with 200 and a set of all participant matches
      | not ciqOp -> do
        users <- traverse userToResponse participantMatches
        return CorrectInterfaceResponseNoOp
          { cirnUsers = Set.fromList users
          }

      -- on match with exactly one exam participant, insert results and answer with 200
      | [match@(Entity uid _)] <- participantMatches -> do
        now <- liftIO getCurrentTime
        newExamPartResults <- iforM ciqResults $ \partNumber mPartResult -> do
            examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber
            mOldResult <- getBy $ UniqueExamPartResult examPartId uid
            if
              | Just (Entity oldId _) <- mOldResult, is _Nothing mPartResult -> do
                delete oldId
                audit $ TransactionExamPartResultDeleted examPartId uid
                return Nothing
              | Just partResult <- mPartResult
              , fmap (examPartResultResult . entityVal) mOldResult /= fmap ExamAttended mPartResult -> do
                newExamPartResult <- upsert ExamPartResult
                  { examPartResultExamPart    = examPartId
                  , examPartResultUser        = uid
                  , examPartResultResult      = ExamAttended partResult
                  , examPartResultLastChanged = now
                  }
                  [ ExamPartResultResult      =. ExamAttended partResult
                  , ExamPartResultLastChanged =. now
                  ]
                audit $ TransactionExamPartResultEdit examPartId uid
                return $ newExamPartResult ^? _entityVal . _examPartResultResult . _ExamAttended
              | otherwise -> return Nothing
        user <- userToResponse match
        return CorrectInterfaceResponseSuccess
          { cirsUser    = user
          , cirsResults = newExamPartResults
          , cirsTime    = now
          }

      -- on match with no exam participant, answer with 400
      | [] <- participantMatches -> return CorrectInterfaceResponseFailure
        { cirfMessage   = mr MsgExamCorrectErrorNoMatchingParticipants
        }

      -- on match with multiple exam participants, answer with 400 and a set of all matches
      | otherwise -> do
        users <- traverse userToResponse participantMatches
        return CorrectInterfaceResponseAmbiguous
          { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants
          , ciraUsers   = Set.fromList users
          }
  
  let
    responseStatus = case response of
      CorrectInterfaceResponseSuccess{} -> ok200
      CorrectInterfaceResponseNoOp{}    -> ok200
      _                                 -> badRequest400

  whenM acceptsJson $
    sendResponseStatus responseStatus $ toJSON response
  
  redirect $ CExamR tid ssh csh examn EShowR
