{-# LANGUAGE OverloadedStrings #-}

module Server.Website.Main
( handleRoot
) where

import Core
import Serializer (personalizedExerciseToJSON, validateExerciseAnswer)
import qualified Study.Courses.English.Grammar.Introduction.Course
import qualified Study.Courses.English.Grammar.Crash.Course
import qualified Study.Courses.English.Vocabulary.Attitudinals.Course
import qualified Study.Courses.English.Vocabulary.Brivla.Course
import qualified Study.Decks.English.ContextualizedBrivla
import qualified Study.Decks.Eberban.English.Roots
import Server.Core
import Server.Util (forceSlash, getBody)
import Server.Authentication.Utils (retrieveRequestHeaderRefererIfAllowed)
import Server.Website.Views.Core
import Server.Website.Views.Home (displayHome)
import Server.Website.Views.Courses (displayCoursesHome)
import Server.Website.Views.Decks (displayDecksHome)
import Server.Website.Views.Deck (displayDeckHome, displayDeckExercise)
import Server.Website.Views.Resources (displayResourcesHome)
import Server.Website.Views.FAQ (displayFAQHome)
import Server.Website.Views.Login (displayLoginHome)
import Server.Website.Views.Offline (displayOfflineHome)
import Server.Website.Views.NotFound (displayNotFoundHome)
import Server.Website.Views.Course (displayCourseHome)
import Server.Website.Views.Lesson (displayLessonHome, displayLessonExercise)
import Control.Monad (msum, guard)
import Control.Monad.IO.Class (liftIO)
import System.Random (newStdGen, mkStdGen)
import Data.ByteString.Builder (toLazyByteString)
import qualified Server.Authentication.Main as Authentication
import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as BS
import qualified Network.HTTP.Types.URI as URI
import qualified Data.UUID.V4 as UUIDv4
import Happstack.Server

-- TODO: consider adding breadcrumbs (https://getbootstrap.com/docs/4.0/components/breadcrumb/)

-- * Handlers
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    Maybe UserIdentity
userIdentityMaybe <- ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
Authentication.readUserIdentityFromCookies 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
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"courses" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleCourses ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"decks" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources -> Maybe UserIdentity -> ServerPart Response
handleDecks ServerConfiguration
serverConfiguration ServerResources
serverResources Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"resources" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleResources ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"FAQ" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleFAQ ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"login" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleLogin ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"offline" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleOffline ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        ]

handleHome :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleHome :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe

handleCourses :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleCourses :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleCourses ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayCoursesHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"introduction" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> ServerPart Response
handleCourse ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
TopbarCourses Course
Study.Courses.English.Grammar.Introduction.Course.course
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"crash" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> ServerPart Response
handleCourse ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
TopbarCourses Course
Study.Courses.English.Grammar.Crash.Course.course
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"attitudinals" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> ServerPart Response
handleCourse ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
TopbarCourses Course
Study.Courses.English.Vocabulary.Attitudinals.Course.course
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"brivla" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> ServerPart Response
handleCourse ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
TopbarCourses Course
Study.Courses.English.Vocabulary.Brivla.Course.course
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleDecks :: ServerConfiguration -> ServerResources -> Maybe UserIdentity -> ServerPart Response
handleDecks :: ServerConfiguration
-> ServerResources -> Maybe UserIdentity -> ServerPart Response
handleDecks ServerConfiguration
serverConfiguration ServerResources
serverResources Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayDecksHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"contextualized-brivla" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Maybe UserIdentity
-> Deck
-> ServerPart Response
handleDeck ServerConfiguration
serverConfiguration ServerResources
serverResources Maybe UserIdentity
userIdentityMaybe Deck
Study.Decks.English.ContextualizedBrivla.deck
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"eberban-roots" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> ServerResources
-> Maybe UserIdentity
-> Deck
-> ServerPart Response
handleDeck ServerConfiguration
serverConfiguration ServerResources
serverResources Maybe UserIdentity
userIdentityMaybe Deck
Study.Decks.Eberban.English.Roots.deck
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleResources :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleResources :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleResources ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayResourcesHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleFAQ :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleFAQ :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleFAQ ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayFAQHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleLogin :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleLogin :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleLogin ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ ServerPart Response
handleLogin'
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ] where
        handleLogin' :: ServerPart Response
handleLogin' = ServerPart Response -> ServerPart Response
forceSlash (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ case Maybe UserIdentity
userIdentityMaybe of
            Maybe UserIdentity
Nothing -> do
                Maybe Text
refererMaybe <- ServerPart (Maybe Text)
retrieveRequestHeaderRefererIfAllowed -- TODO: from cookie OR request header (if there is an error, and /authentication/(register|login) redirects back to /login)
                UUID
uuid <- IO UUID -> ServerPartT IO UUID
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UUID -> ServerPartT IO UUID) -> IO UUID -> ServerPartT IO UUID
forall a b. (a -> b) -> a -> b
$ IO UUID
UUIDv4.nextRandom
                Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity -> Maybe Text -> UUID -> Html
displayLoginHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe Maybe Text
refererMaybe UUID
uuid
            Maybe UserIdentity
_ -> Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect (Text
"/" :: T.Text) (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
"You are already signed in." :: T.Text)

handleOffline :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleOffline :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleOffline ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayOfflineHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleNotFound :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound :: ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Html
displayNotFoundHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleCourse :: ServerConfiguration -> Maybe UserIdentity -> TopbarCategory -> Course -> ServerPart Response
handleCourse :: ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> ServerPart Response
handleCourse ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory Course
course =
    let lessons :: [Lesson]
lessons = Course -> [Lesson]
courseLessons Course
course
    in [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)
-> (Course -> ServerPart Response) -> Course -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> Response) -> (Course -> Html) -> Course -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerConfiguration
-> Maybe UserIdentity -> TopbarCategory -> Course -> Html
displayCourseHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory (Course -> ServerPart Response) -> Course -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Course
course
        , (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
$ \Int
n -> (Bool -> ServerPartT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ServerPartT IO ()) -> Bool -> ServerPartT IO ()
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ([Lesson] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Lesson]
lessons)) ServerPartT IO () -> ServerPart Response -> ServerPart Response
forall a b.
ServerPartT IO a -> ServerPartT IO b -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> Int
-> ServerPart Response
handleLesson ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory Course
course Int
n)
        , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
        ]

handleDeck :: ServerConfiguration -> ServerResources -> Maybe UserIdentity -> Deck -> ServerPart Response
handleDeck :: ServerConfiguration
-> ServerResources
-> Maybe UserIdentity
-> Deck
-> ServerPart Response
handleDeck ServerConfiguration
serverConfiguration ServerResources
serverResources Maybe UserIdentity
userIdentityMaybe 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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Deck -> Html
displayDeckHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe 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
$ do
        Maybe UserIdentity
identityMaybe <- ServerConfiguration
-> ServerResources -> ServerPart (Maybe UserIdentity)
Authentication.readUserIdentityFromCookies ServerConfiguration
serverConfiguration ServerResources
serverResources
        case Maybe UserIdentity
identityMaybe of
            Maybe UserIdentity
Nothing -> do
                --tempRedirect ("./" :: T.Text) . toResponse $ ("You must be signed in." :: T.Text)
                Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Text -> Html
includeInlineScript (Text
"alert('To practice with decks, you need to sign in.'); window.location.href='./';" :: T.Text)
            Just UserIdentity
identity -> Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> Deck -> Html
displayDeckExercise ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe Deck
deck
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleLesson :: ServerConfiguration -> Maybe UserIdentity -> TopbarCategory -> Course -> Int -> ServerPart Response
handleLesson :: ServerConfiguration
-> Maybe UserIdentity
-> TopbarCategory
-> Course
-> Int
-> ServerPart Response
handleLesson ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory Course
course Int
lessonNumber = [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity -> TopbarCategory -> Course -> Int -> Html
displayLessonHome ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory Course
course Int
lessonNumber
    , String -> ServerPart Response -> ServerPart Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"report" (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ Course -> Int -> ServerPart Response
handleLessonReport Course
course Int
lessonNumber
    , 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
$ [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)
-> (Html -> ServerPart Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ServerPart Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> ServerPart Response)
-> (Html -> Response) -> Html -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Response
forall a. ToMessage a => a -> Response
toResponse (Html -> ServerPart Response) -> Html -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration
-> Maybe UserIdentity -> TopbarCategory -> Course -> Int -> Html
displayLessonExercise ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe TopbarCategory
topbarCategory Course
course Int
lessonNumber
        , (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
$ \Int
n ->
            let
                lesson :: Lesson
lesson = (Course -> [Lesson]
courseLessons Course
course) [Lesson] -> Int -> Lesson
forall a. HasCallStack => [a] -> Int -> a
!! (Int
lessonNumber Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                exercise :: Exercise
exercise = Lesson -> ExerciseGenerator
lessonExercises Lesson
lesson (Int -> StdGen
mkStdGen Int
n)
                shouldDisplayHint :: Bool
shouldDisplayHint = Bool
False
                personalizedExercise :: PersonalizedExercise
personalizedExercise = Exercise -> Bool -> PersonalizedExercise
PersonalizedExercise Exercise
exercise Bool
shouldDisplayHint
            in [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 -> 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
$
                    case Exercise -> ByteString -> Maybe Value
validateExerciseAnswer Exercise
exercise ByteString
body of
                        Maybe Value
Nothing -> [(Key
"success", Bool -> Value
A.Bool Bool
False)]
                        Just Value
data' -> [(Key
"success", Bool -> Value
A.Bool Bool
True), (Key
"data", Value
data')]
                ]
        ]
    , ServerPart Response -> ServerPart Response
forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => m r -> m r
anyPath (ServerPart Response -> ServerPart Response)
-> ServerPart Response -> ServerPart Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> Maybe UserIdentity -> ServerPart Response
handleNotFound ServerConfiguration
serverConfiguration Maybe UserIdentity
userIdentityMaybe
    ]

handleLessonReport :: Course -> Int -> ServerPart Response
handleLessonReport :: Course -> Int -> ServerPart Response
handleLessonReport Course
course Int
lessonNumber =
    -- The only reason for using `tempRedirect` is that we may want to change the target url in the future
    ServerPart Response -> ServerPart Response
forceSlash (ServerPart Response -> ServerPart Response)
-> (Text -> ServerPart Response) -> Text -> ServerPart Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response -> ServerPart Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect Text
url (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
"To report an issue, please visit our GitHub repository." :: T.Text) where
        lesson :: Lesson
        lesson :: Lesson
lesson = (Course -> [Lesson]
courseLessons Course
course) [Lesson] -> Int -> Lesson
forall a. HasCallStack => [a] -> Int -> a
!! (Int
lessonNumber Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        url :: T.Text
        url :: Text
url = Text
"https://github.com/jqueiroz/lojban.io/issues/new" Text -> Text -> Text
`T.append` Text
queryString
        queryString :: T.Text
        queryString :: Text
queryString = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (Builder -> ByteString) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> QueryText -> Builder
URI.renderQueryText Bool
True
            [ (Text
"labels", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"reported-lesson")
            , (Text
"title", Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Feedback regarding lesson: " Text -> Text -> Text
`T.append` (Lesson -> Text
lessonTitle Lesson
lesson))
            , (Text
"body", Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"Please provide your feedback here...\n\n### Context\nFor context, this feedback refers to the lesson \"" Text -> Text -> Text
`T.append` (Lesson -> Text
lessonTitle Lesson
lesson) Text -> Text -> Text
`T.append` Text
"\" in the course \"" Text -> Text -> Text
`T.append` (Course -> Text
courseTitle Course
course) Text -> Text -> Text
`T.append` Text
"\".")
            ]