{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Server.Api.V0.Main (handleRoot) where

import Core
import Server.Core
import Study.Courses.CourseStore (courseStore)
import Study.Decks.DeckStore (deckStore)
import Server.Logic.Redis (runRedis)
import Server.Logic.Decks (retrieveDeckPreferences, retrieveDeckProficiency, retrieveDeckActiveCards, updateDeckPreferencesByTogglingCard, updateDeckProficiencyByRegisteringExerciseAttempt)
import Control.Monad (msum)
import Server.Util (forceSlash, getBody)
import Server.Api.V0.Serializers (serializeCourse, serializeDeck)
import Happstack.Server
import Control.Monad.Trans (liftIO)
import System.Random (StdGen, mkStdGen, newStdGen)
import Serializer (personalizedExerciseToJSON, validateExerciseAnswer)
import Util (chooseItem, combineGenerators)
import qualified Server.Authentication.Main as Authentication
import qualified Database.Redis as Redis
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as AKM

handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ ServerPart Response -> ServerPart Response
forceSlash (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (ByteString -> Response) -> ByteString -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> ServerPart Response)
-> ByteString -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
A.object [(Key
"success", Bool -> Value
A.Bool Bool
True)]
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"course" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text -> ServerPart Response) -> ServerPart Response
forall a (m :: * -> *) b.
(FromReqURI a, MonadPlus m, ServerMonad m) =>
(a -> m b) -> m b
path Text -> ServerPart Response
handleCourse
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"deck" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text -> ServerPart Response) -> ServerPart Response
forall a (m :: * -> *) b.
(FromReqURI a, MonadPlus m, ServerMonad m) =>
(a -> m b) -> m b
path (ServerConfiguration
-> ServerResources -> Text -> ServerPart Response
handleDeck ServerConfiguration
serverConfiguration ServerResources
serverResources)
    ]

handleCourse :: T.Text -> ServerPart Response
handleCourse :: Text -> ServerPart Response
handleCourse Text
courseId =
    let courseLookup :: Maybe Course
courseLookup = Text -> Map Text Course -> Maybe Course
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
courseId (CourseStore -> Map Text Course
courseStoreCourses CourseStore
courseStore)
    in case Maybe Course
courseLookup of
        Maybe Course
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"" :: T.Text)
        Just Course
course -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Course -> Response) -> Course -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> (Course -> ByteString) -> Course -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Course -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Course -> ServerPart Response) -> Course -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Course -> Course
serializeCourse Course
course

handleDeck :: ServerConfiguration -> ServerResources -> T.Text -> ServerPart Response
handleDeck :: ServerConfiguration
-> ServerResources -> Text -> ServerPart Response
handleDeck ServerConfiguration
serverConfiguration ServerResources
serverResources Text
deckId =
    let deckLookup :: Maybe Deck
deckLookup = Text -> Map Text Deck -> Maybe Deck
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
deckId (DeckStore -> Map Text Deck
deckStoreDecks DeckStore
deckStore)
    in case Maybe Deck
deckLookup of
        Maybe Deck
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"" :: T.Text)
        Just Deck
deck -> [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
            [ ServerPart Response -> ServerPart Response
forceSlash (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources -> Deck -> ServerPart Response
handleDeckRetrieve ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck
            , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"setCardStatus" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text -> ServerPart Response) -> ServerPart Response
forall a (m :: * -> *) b.
(FromReqURI a, MonadPlus m, ServerMonad m) =>
(a -> m b) -> m b
path (ServerConfiguration
-> ServerResources -> Deck -> Text -> ServerPart Response
handleDeckSetCardStatus ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck)
            , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"exercises" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Int -> ServerPart Response) -> ServerPart Response
forall a (m :: * -> *) b.
(FromReqURI a, MonadPlus m, ServerMonad m) =>
(a -> m b) -> m b
path ((Int -> ServerPart Response) -> ServerPart Response)
-> (Int -> ServerPart Response) -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources -> Deck -> Int -> ServerPart Response
handleDeckExercises ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck
            ]

handleDeckRetrieve :: ServerConfiguration -> ServerResources -> Deck -> ServerPart Response
handleDeckRetrieve :: ServerConfiguration
-> ServerResources -> Deck -> ServerPart Response
handleDeckRetrieve ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck = do
    Maybe UserIdentity
identityMaybe <- ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
Authentication.readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources
    let identifierMaybe :: Maybe UserIdentifier
identifierMaybe = UserIdentity -> UserIdentifier
userIdentifier (UserIdentity -> UserIdentifier)
-> Maybe UserIdentity -> Maybe UserIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserIdentity
identityMaybe
    Maybe DeckPreferences
deckPreferencesMaybe <- case Maybe UserIdentifier
identifierMaybe of
        Maybe UserIdentifier
Nothing -> Maybe DeckPreferences -> ServerPartT IO (Maybe DeckPreferences)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DeckPreferences
forall a. Maybe a
Nothing
        Just UserIdentifier
identifier -> IO (Maybe DeckPreferences)
-> ServerPartT IO (Maybe DeckPreferences)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DeckPreferences)
 -> ServerPartT IO (Maybe DeckPreferences))
-> IO (Maybe DeckPreferences)
-> ServerPartT IO (Maybe DeckPreferences)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Maybe DeckPreferences)
-> IO (Maybe DeckPreferences)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Maybe DeckPreferences) -> IO (Maybe DeckPreferences))
-> Redis (Maybe DeckPreferences) -> IO (Maybe DeckPreferences)
forall a b. (a -> b) -> a -> b
$ DeckPreferences -> Maybe DeckPreferences
forall a. a -> Maybe a
Just (DeckPreferences -> Maybe DeckPreferences)
-> Redis DeckPreferences -> Redis (Maybe DeckPreferences)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserIdentifier -> Deck -> Redis DeckPreferences
retrieveDeckPreferences UserIdentifier
identifier Deck
deck
    Maybe DeckProficiency
deckProficiencyMaybe <- case Maybe UserIdentifier
identifierMaybe of
        Maybe UserIdentifier
Nothing -> Maybe DeckProficiency -> ServerPartT IO (Maybe DeckProficiency)
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DeckProficiency
forall a. Maybe a
Nothing
        Just UserIdentifier
identifier -> IO (Maybe DeckProficiency)
-> ServerPartT IO (Maybe DeckProficiency)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DeckProficiency)
 -> ServerPartT IO (Maybe DeckProficiency))
-> IO (Maybe DeckProficiency)
-> ServerPartT IO (Maybe DeckProficiency)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Maybe DeckProficiency)
-> IO (Maybe DeckProficiency)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Maybe DeckProficiency) -> IO (Maybe DeckProficiency))
-> Redis (Maybe DeckProficiency) -> IO (Maybe DeckProficiency)
forall a b. (a -> b) -> a -> b
$ DeckProficiency -> Maybe DeckProficiency
forall a. a -> Maybe a
Just (DeckProficiency -> Maybe DeckProficiency)
-> Redis DeckProficiency -> Redis (Maybe DeckProficiency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserIdentifier -> Deck -> Redis DeckProficiency
retrieveDeckProficiency UserIdentifier
identifier Deck
deck
    Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Deck -> Response) -> Deck -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> (Deck -> ByteString) -> Deck -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deck -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Deck -> ServerPart Response) -> Deck -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Deck -> Maybe DeckPreferences -> Maybe DeckProficiency -> Deck
serializeDeck Deck
deck Maybe DeckPreferences
deckPreferencesMaybe Maybe DeckProficiency
deckProficiencyMaybe

handleDeckSetCardStatus :: ServerConfiguration -> ServerResources -> Deck -> T.Text -> ServerPart Response
handleDeckSetCardStatus :: ServerConfiguration
-> ServerResources -> Deck -> Text -> ServerPart Response
handleDeckSetCardStatus ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Text
cardTitle = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"AlreadyMastered" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Deck
-> Text
-> CardStatus
-> ServerPart Response
handleDeckSetCardStatus' ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Text
cardTitle CardStatus
CardAlreadyMastered
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"CurrentlyLearning" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Deck
-> Text
-> CardStatus
-> ServerPart Response
handleDeckSetCardStatus' ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Text
cardTitle CardStatus
CardCurrentlyLearning
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"NotStarted" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Deck
-> Text
-> CardStatus
-> ServerPart Response
handleDeckSetCardStatus' ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Text
cardTitle CardStatus
CardNotStarted
    ]

handleDeckSetCardStatus' :: ServerConfiguration -> ServerResources -> Deck -> T.Text -> CardStatus -> ServerPart Response
handleDeckSetCardStatus' :: ServerConfiguration
-> ServerResources
-> Deck
-> Text
-> CardStatus
-> ServerPart Response
handleDeckSetCardStatus' ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Text
cardTitle CardStatus
cardNewStatus = do
    Maybe UserIdentity
identityMaybe <- ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
Authentication.readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources
    case Maybe UserIdentity
identityMaybe of
        Maybe UserIdentity
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> (Text -> ByteString) -> Text -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"You must be signed in." :: T.Text)
        Just UserIdentity
identity -> do
            Either Reply Status
redisResponse <- IO (Either Reply Status) -> ServerPartT IO (Either Reply Status)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply Status) -> ServerPartT IO (Either Reply Status))
-> IO (Either Reply Status) -> ServerPartT IO (Either Reply Status)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Either Reply Status)
-> IO (Either Reply Status)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Either Reply Status) -> IO (Either Reply Status))
-> Redis (Either Reply Status) -> IO (Either Reply Status)
forall a b. (a -> b) -> a -> b
$ UserIdentifier
-> Deck -> Text -> CardStatus -> Redis (Either Reply Status)
updateDeckPreferencesByTogglingCard (UserIdentity -> UserIdentifier
userIdentifier UserIdentity
identity) Deck
deck Text
cardTitle CardStatus
cardNewStatus
            case Either Reply Status
redisResponse of
                Right Status
Redis.Ok -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"Successfully updated card status." :: T.Text)
                Either Reply Status
_ -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"Failed to update card status." :: T.Text)

handleDeckExercises :: ServerConfiguration -> ServerResources -> Deck -> Int -> ServerPart Response
handleDeckExercises :: ServerConfiguration
-> ServerResources -> Deck -> Int -> ServerPart Response
handleDeckExercises ServerConfiguration
serverConfiguration ServerResources
serverResources Deck
deck Int
exerciseId = do
    Maybe UserIdentity
identityMaybe <- ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
Authentication.readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources
    case Maybe UserIdentity
identityMaybe of
        Maybe UserIdentity
Nothing -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized (Response -> ServerPart Response)
-> (Text -> Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> (Text -> ByteString) -> Text -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Text -> ServerPart Response) -> Text -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (Text
"You must be signed in." :: T.Text)
        Just UserIdentity
identity -> do
            [CardWithUserFeatures]
cardsWithUserFeatures <- IO [CardWithUserFeatures] -> ServerPartT IO [CardWithUserFeatures]
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CardWithUserFeatures]
 -> ServerPartT IO [CardWithUserFeatures])
-> IO [CardWithUserFeatures]
-> ServerPartT IO [CardWithUserFeatures]
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis [CardWithUserFeatures]
-> IO [CardWithUserFeatures]
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis [CardWithUserFeatures] -> IO [CardWithUserFeatures])
-> Redis [CardWithUserFeatures] -> IO [CardWithUserFeatures]
forall a b. (a -> b) -> a -> b
$ UserIdentifier -> Deck -> Redis [CardWithUserFeatures]
retrieveDeckActiveCards (UserIdentity -> UserIdentifier
userIdentifier UserIdentity
identity) Deck
deck
            let r0 :: StdGen
r0 = Int -> StdGen
mkStdGen Int
exerciseId
            let (CardWithUserFeatures
selectedCardWithUserFeatures, StdGen
r1) = [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCardWithBiasTowardsLowScoreOnes [CardWithUserFeatures]
cardsWithUserFeatures StdGen
r0
            let selectedCard :: Card
selectedCard = CardWithUserFeatures -> Card
card CardWithUserFeatures
selectedCardWithUserFeatures
            let selectedExercise :: Exercise
selectedExercise = (Card -> ExerciseGenerator
cardExercises Card
selectedCard) StdGen
r1
            let personalizedExercise :: PersonalizedExercise
personalizedExercise = Exercise -> Bool -> PersonalizedExercise
PersonalizedExercise Exercise
selectedExercise (CardWithUserFeatures -> Bool
cardShouldDisplayHint CardWithUserFeatures
selectedCardWithUserFeatures)
            [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
                [ String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"get" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ (IO StdGen -> ServerPartT IO StdGen
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StdGen -> ServerPartT IO StdGen)
-> IO StdGen -> ServerPartT IO StdGen
forall a b. (a -> b) -> a -> b
$ IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen) ServerPartT IO StdGen
-> (StdGen -> ServerPart Response) -> ServerPart Response
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (StdGen -> Response) -> StdGen -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> (StdGen -> ByteString) -> StdGen -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> (StdGen -> Value) -> StdGen -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersonalizedExercise -> StdGen -> Value
personalizedExerciseToJSON PersonalizedExercise
personalizedExercise
                , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"submit" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerPart ByteString
getBody ServerPart ByteString
-> (ByteString -> ServerPart Response) -> ServerPart Response
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
body -> do
                    let errorResponse :: ServerPart Response
errorResponse = Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> ([Pair] -> Response) -> [Pair] -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> ([Pair] -> ByteString) -> [Pair] -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> ([Pair] -> Value) -> [Pair] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
A.object ([Pair] -> ServerPart Response) -> [Pair] -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ [(Key
"success", Bool -> Value
A.Bool Bool
False)]
                    case Exercise -> ByteString -> Maybe Value
validateExerciseAnswer Exercise
selectedExercise ByteString
body of
                        Maybe Value
Nothing -> ServerPart Response
errorResponse
                        Just Value
responseData -> do
                            let Value -> Maybe Bool
extractCorrect :: A.Value -> Maybe Bool = \case
                                    A.Object Object
responseObject ->
                                        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AKM.lookup Key
"correct" Object
responseObject of
                                            Just (A.Bool Bool
correct) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
correct
                                            Maybe Value
_ -> Maybe Bool
forall a. Maybe a
Nothing
                                    Value
_ -> Maybe Bool
forall a. Maybe a
Nothing
                            case Value -> Maybe Bool
extractCorrect Value
responseData of
                                Maybe Bool
Nothing -> ServerPart Response
errorResponse
                                Just Bool
isCorrect -> do
                                    Either Reply Status
redisStatus <- IO (Either Reply Status) -> ServerPartT IO (Either Reply Status)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply Status) -> ServerPartT IO (Either Reply Status))
-> IO (Either Reply Status) -> ServerPartT IO (Either Reply Status)
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Redis (Either Reply Status)
-> IO (Either Reply Status)
forall a. ServerConfiguration -> ServerResources -> Redis a -> IO a
runRedis ServerConfiguration
serverConfiguration ServerResources
serverResources (Redis (Either Reply Status) -> IO (Either Reply Status))
-> Redis (Either Reply Status) -> IO (Either Reply Status)
forall a b. (a -> b) -> a -> b
$ UserIdentifier
-> Deck -> Text -> Bool -> Redis (Either Reply Status)
updateDeckProficiencyByRegisteringExerciseAttempt (UserIdentity -> UserIdentifier
userIdentifier UserIdentity
identity) Deck
deck (Card -> Text
cardTitle Card
selectedCard) Bool
isCorrect
                                    Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> ([Pair] -> Response) -> [Pair] -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse (ByteString -> Response)
-> ([Pair] -> ByteString) -> [Pair] -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> ([Pair] -> Value) -> [Pair] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
A.object ([Pair] -> ServerPart Response) -> [Pair] -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ [(Key
"success", Bool -> Value
A.Bool Bool
True), (Key
"data", Value
responseData)]
                ]

selectCardWithBiasTowardsLowScoreOnes :: [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCardWithBiasTowardsLowScoreOnes :: [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCardWithBiasTowardsLowScoreOnes [CardWithUserFeatures]
cards = [(Int, StdGen -> (CardWithUserFeatures, StdGen))]
-> StdGen -> (CardWithUserFeatures, StdGen)
forall a. [(Int, StdGen -> a)] -> StdGen -> a
combineGenerators [(Int
probabilityOfSelectingLowScoreCards, StdGen -> (CardWithUserFeatures, StdGen)
selectLowScoreCard), (Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
probabilityOfSelectingLowScoreCards, StdGen -> (CardWithUserFeatures, StdGen)
selectGeneralCard)] where
    -- | Low-score cards.
    lowScoreCards :: [CardWithUserFeatures]
lowScoreCards = (CardWithUserFeatures -> Bool)
-> [CardWithUserFeatures] -> [CardWithUserFeatures]
forall a. (a -> Bool) -> [a] -> [a]
filter CardWithUserFeatures -> Bool
hasLowScore [CardWithUserFeatures]
cards
    -- | Probability of selecting low-score cards.
    probabilityOfSelectingLowScoreCards :: Int
probabilityOfSelectingLowScoreCards = Int -> Int
decideProbabilityOfSelectingLowScoreCardsGivenTheirCount ([CardWithUserFeatures] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CardWithUserFeatures]
lowScoreCards)
    -- | Decides the probability of selecting low-score cards.
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount :: Int -> Int
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount :: Int -> Int
decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
0 = Int
0
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
1 = Int
10
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
2 = Int
15
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
3 = Int
20
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
4 = Int
25
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
5 = Int
30
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
6 = Int
35
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
7 = Int
40
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
8 = Int
45
    decideProbabilityOfSelectingLowScoreCardsGivenTheirCount Int
_ = Int
50
    -- | Decides whether the given card has low score.
    hasLowScore :: CardWithUserFeatures -> Bool
    hasLowScore :: CardWithUserFeatures -> Bool
hasLowScore CardWithUserFeatures
cardWithUserFeatures = (CardWithUserFeatures -> Double
cardProficiencyScore CardWithUserFeatures
cardWithUserFeatures) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.4
    -- | Randomly selects a card among those with low score.
    selectLowScoreCard :: StdGen -> (CardWithUserFeatures, StdGen)
selectLowScoreCard = [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCard [CardWithUserFeatures]
lowScoreCards
    -- | Randomly selects a card among all of them.
    selectGeneralCard :: StdGen -> (CardWithUserFeatures, StdGen)
selectGeneralCard = [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCard [CardWithUserFeatures]
cards

selectCard :: [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCard :: [CardWithUserFeatures] -> StdGen -> (CardWithUserFeatures, StdGen)
selectCard [CardWithUserFeatures]
cardsWithUserFeatures StdGen
r0 = StdGen
-> [(Int, CardWithUserFeatures)] -> (CardWithUserFeatures, StdGen)
forall a. StdGen -> [(Int, a)] -> (a, StdGen)
chooseItem StdGen
r0 ([(Int, CardWithUserFeatures)] -> (CardWithUserFeatures, StdGen))
-> [(Int, CardWithUserFeatures)] -> (CardWithUserFeatures, StdGen)
forall a b. (a -> b) -> a -> b
$ (CardWithUserFeatures -> (Int, CardWithUserFeatures))
-> [CardWithUserFeatures] -> [(Int, CardWithUserFeatures)]
forall a b. (a -> b) -> [a] -> [b]
map (\CardWithUserFeatures
cardWithUserFeatures -> (CardWithUserFeatures -> Int
cardProficiencyWeight CardWithUserFeatures
cardWithUserFeatures, CardWithUserFeatures
cardWithUserFeatures)) [CardWithUserFeatures]
cardsWithUserFeatures